Require Import VST.floyd.proofauto.
Require Import curve448.
Require Import list_int_functions.
Require Import stdpp.list.
Require Import ZArith.
Require Import compcert.lib.Coqlib.
Require Import list_lemmas.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Local Open Scope Z.

(* curve448Red proof attemp*)

Definition prime: Z := 2^448 - 2^224 - 1.
Definition prime_list : list Z := [-1; -1; -1; -1; -1; -1; -1;
                                   -2; -1; -1; -1; -1; -1; -1].

Definition undef14 :=
       [Vundef; Vundef; Vundef; Vundef; Vundef; Vundef; Vundef;
        Vundef; Vundef; Vundef; Vundef; Vundef; Vundef; Vundef].

Definition curve448Red_spec : ident * funspec :=
DECLARE _curve448Red
WITH    r : val,
        shr : share,
        a : val,
        contents_a : list Z,
        h : Z, (* may need writable share *)
        gv : globals
PRE [ tptr tuint, tptr tuint, tuint ]
    PROP   (writable_share shr;
            Zlength contents_a = 14;
            0 <= (list_to_int contents_a) < (2 * prime);
            forall x : Z, In x contents_a → x < 2 ^ 32 /\ x mod Int.modulus < 2^32
            (*TODO  * @param[in] h The highest term of A*))
    PARAMS (r ; a ; Vint(Int.repr h)) GLOBALS (gv)
    SEP    (data_at_ shr (tarray tuint 14) r;
            data_at Tsh (tarray tuint 14) (map Vint (map Int.repr contents_a)) a)
POST [ tvoid ]
    PROP   ()
    RETURN ()
    SEP    (data_at shr (tarray tuint 14) (* r contains the representation of A mod p *)
   (*cont*)(map Vint (map Int.repr (int_to_list ((list_to_int contents_a) mod prime)))) r ;
            data_at Tsh (tarray tuint 14) (map Vint (map Int.repr contents_a)) a).

Fixpoint allprev_mone_aux (n : nat) (a : list Z) : bool :=
   match n with
   | O   => true
   | S n' => (Int.eq (Int.repr (Znth (Z.of_nat n') a)) Int.mone)
            && allprev_mone_aux n' a
   end.

Definition allprev_mone (i : Z) (a : list Z) := allprev_mone_aux (Z.to_nat i) a.

Definition curve448Red_INV_1    (a : val)  (contents_a : list Z)
                     (b : val)  (r : val) (shr : share)
                     (h : Z) (gv : globals)
:=
    (EX i : Z,
    (PROP   (Zlength contents_a = 14)
    LOCAL   (temp _temp (if allprev_mone i contents_a
               then Vlong Int64.one else Vlong Int64.zero);
            lvar _b (tarray tuint 14) b;
            gvars gv;
            temp _a a; temp _h (Vint (Int.repr h)))
    SEP     (
                data_at_ shr (tarray tuint 14) r;
                data_at Tsh (tarray tuint 14) (map Vint (map Int.repr contents_a)) a;
                data_at Tsh (tarray tuint 14)
                ((sublist.sublist 0 i (map Vint (map Int.repr (int_to_list ((list_to_int contents_a) - prime)))))
                ++ sublist.sublist i 14 undef14) b
            )))%assert.

Definition Gprog : funspecs := ltac:(with_library prog [ curve448Red_spec ]).

Lemma L1 (i : Z) (a : list Z) : 0 <= i ->
   allprev_mone (i + 1) a =
   Int.eq (Int.repr (Znth i a)) Int.mone && allprev_mone i a.
Proof.
   intros.
   unfold allprev_mone.
   replace (i + 1) with (Z.succ i) by easy.
   rewrite Z2Nat.inj_succ by apply H.
   assert (i = Z.of_nat (Z.to_nat i)).
      rewrite Z2Nat.id; auto.
   rewrite H0 at 2.
   induction (Z.to_nat i); auto.
Qed.

Lemma L2 :
Int64.add Int64.one (Int64.repr (Int.modulus - 1)) = Int64.repr Int.modulus.
Proof.
   auto.
   Qed.

Lemma L3 (z : Z) :
0 <= z < Int64.modulus -> Int64.unsigned (Int64.repr z) = z.
Proof.
   intros.
   rewrite Int64.unsigned_repr_eq.
   rewrite Z.mod_small; auto.
Qed.

Lemma  L4' (z : Z):
Int.eq (Int.repr z) Int.mone = false -> z mod Int.modulus ≠ Int.modulus - 1.
Proof.
   intros.
   apply int_eq_false_e in H.
   unfold "≠".
   intros.
   replace (Int.modulus - 1) with (Int.modulus - 1 mod Int.modulus) in H0.
   assert (Int.repr z = Int.repr (Int.modulus - 1)).
   apply modulo_samerepr.
   apply H0.
   replace (Int.repr (Int.modulus - 1)) with (Int.repr (- 1)) in H1.
   contradiction.
   rewrite modulo_samerepr with (y:= Int.modulus - 1); reflexivity.
   apply Zmod_small with (a := Int.modulus - 1) (n:= Int.modulus).
   easy.
Qed.

Lemma L4 (z : Z) :
Int.eq (Int.repr z) Int.mone = false -> z mod Int.modulus < Int.modulus - 1.
Proof.
   intros.
   apply int_eq_false_e in H.
   unfold Int.mone in H.
   apply Znot_ge_lt.
   unfold not.
   intros.
   assert (Int.modulus ≠ 0) by easy.
   apply Z.mod_bound_or with (a := z) in H1.
   destruct H1.
   destruct H1.
   assert (z mod Int.modulus <= Int.modulus - 1).
   apply Zlt_succ_le.
   replace (Z.succ (Int.modulus - 1)) with (Int.modulus) by easy.
   assumption.
   assert ( z mod Int.modulus = Int.modulus - 1).
   apply Z.ge_le in H0.
   apply Z.le_antisymm; assumption.
   replace (Int.modulus - 1) with (- 1 mod Int.modulus) in H4 by easy.
   apply modulo_samerepr in H4.
   contradiction.
   destruct H1.
   assert (Int.modulus < 0).
   apply Z.lt_le_trans with (m:= z mod Int.modulus); assumption.
   discriminate H3.
   Qed.

Lemma L5 (z : Z) : 0 <= z < two_p 32 ->
   Int64.shru (Int64.repr z) (Int64.repr 32) = Int64.zero.
Proof.
   intros.
   rewrite Int64.shru_div_two_p.
   assert (Int64.unsigned (Int64.repr z) / two_p (Int64.unsigned (Int64.repr 32)) = 0).
   rewrite Zdiv_small; try easy.
   split.
   destruct H.
   rewrite L3; try easy.
   split; try easy.
   assert ((two_p 32) < Int64.modulus) by easy.
   apply Z.lt_trans with (two_p 32); assumption.
   replace (Int64.unsigned (Int64.repr 32)) with 32 by easy.
   destruct H.
   rewrite L3; try easy.
   split; try easy.
   assert ((two_p 32) < Int64.modulus) by easy.
   apply Z.lt_trans with (two_p 32); assumption.
   rewrite H0. easy.
   Qed.

   (*****************************)
(* Compute Int64.unsigned (Int64.repr (2^32-1)). *)
(* Search Int.repr (Int64.unsigned(_)).
Compute (Int.repr (-1)).
Compute Int.mone.
Compute (int_to_list (prime)).
Compute ((prime) -
list_to_int([2^32+1; 4294967295; 4294967295; 4294967295; 4294967295;
4294967295; 4294967295; 4294967295; 4294967295; 4294967295;
4294967295; 4294967295; 4294967295; 4294967295])). *)

Lemma repr_eq_32_64: forall n:Z,
   Int.repr (Int64.unsigned (Int64.repr (n))) = Int.repr (Int.unsigned (Int.repr (n))).
Proof.
   intros.
   rewrite Int64.unsigned_repr_eq.
   rewrite Int.unsigned_repr_eq.
   rewrite modulo_samerepr with (y:= n mod Int.modulus); try easy.
   replace (Int64.modulus) with (Int.modulus * Int.modulus) by easy.
   rewrite Zaux.Zmod_mod_mult; try easy.
   symmetry; apply Zmod_mod.
Qed.

Lemma L6: forall x : Z,
0 <= x < Int.modulus -> Int64.unsigned (Int64.repr x) = Int.unsigned (Int.repr x).
Proof.
   intros.
   Search (Int64.unsigned _ = Int.unsigned _).
   assert (x = Int.unsigned(Int.repr x)).
   rewrite Int.unsigned_repr_eq.
   Search (_ mod _ = _).
   rewrite Z.mod_small; try lia.
   rewrite H0.
   rewrite Int64.int_unsigned_repr.
   rewrite H0 at 1.
   easy.
Qed.

Lemma L7:
forall x y,
0 <= x < Int.modulus -> 0 < y <= 32 ->
(Z.land x (Z.ones y)) mod Int.modulus = Z.land x (Z.ones y).
Proof.
   intros.
   rewrite Z.mod_small; try easy.
   split.
   apply Z.land_nonneg.
   lia.
   rewrite Z.land_ones; try lia.
   replace (Int.modulus) with (2^32) by easy.
   assert (A1 : x mod 2 ^ y < 2^y).
   apply Z.mod_pos_bound; lia.
   assert (A2 : 2 ^ y <= 2 ^ 32).
   destruct H0.
   apply Z.pow_le_mono_r; try lia.
   apply Z.lt_le_trans with (m:= 2^y); try lia.
Qed.

   (*****************************)

Lemma body_curve448Red : semax_body Vprog Gprog f_curve448Red curve448Red_spec.
Proof.
   start_function.
   forward.
   forward_for_simple_bound 7
      (curve448Red_INV_1 a contents_a v_b r shr h gv).
   entailer!.
   apply derives_refl.
   repeat forward.
   entailer!.
   rewrite L1 by easy.
   destruct (allprev_mone i contents_a) eqn:E1;
   destruct (Int.eq (Int.repr (Znth i contents_a)) Int.mone) eqn:E2;
   simpl; f_equal; remember (Znth i contents_a) as x.
     apply Int.same_if_eq in E2.
      rewrite E2, Int.unsigned_mone.
      easy.
     unfold Int64.add.
      assert (A : 0 <= x mod Int.modulus < Int64.modulus).
         assert (A0 : 0 < Int.modulus) by easy.
         pose proof (Z.mod_pos_bound x Int.modulus A0); clear A0.
         assert (A0 : Int.modulus < Int64.modulus) by easy.
         destruct H10.
         discriminate H9.
         destruct H11.
         pose proof (Z.lt_trans (x mod Int.modulus) Int.modulus Int64.modulus H13 A0);
         split; try easy.
      rewrite Int64.unsigned_one, L5; try rewrite !Int.unsigned_repr_eq;
         try rewrite L3; try easy.
      split.
      assert (A0 : 0 < Int.modulus) by easy.
      pose proof (Z.mod_pos_bound x Int.modulus A0); clear A0.
      rewrite (Z.add_nonneg_nonneg 1 (x mod Int.modulus)); easy.
      replace (32 mod Int.modulus) with (32) by easy.
      apply L4 in E2.
      apply Zplus_lt_compat_l with (p := 1) in E2.
      replace (1 + (Int.modulus - 1)) with Int.modulus in E2 by lia.
      replace (two_p 32) with (Int.modulus) by easy; auto.
     apply Int.same_if_eq in E2.
      rewrite E2, Int.unsigned_mone.
      easy.
     rewrite Int64.add_zero_l, !Int.unsigned_repr_eq.
      replace (32 mod Int.modulus) with (32) by easy.
      rewrite L5; auto.
      replace (two_p 32) with (Int.modulus) by easy.
      assert (A0 : 0 < Int.modulus) by easy.
      pose proof (Z.mod_pos_bound x Int.modulus A0); clear A0.
      apply H11.
      (* Prove that if loop inv holds after i then it holds after doing the
         i+1 iteration. *)
      destruct  (allprev_mone i contents_a) eqn:E.
         (* Case allprev_mone i contents_a = true. Means temp = 1. *)
         assert ((upd_Znth i
            (sublist.sublist 0 i
               (map Vint
                  (map Int.repr (int_to_list (list_to_int contents_a - prime)))) ++
            sublist.sublist i 14 undef14)
            (force_val
               (sem_cast_l2i I32 Unsigned
                  (force_val
                     (sem_and tulong tuint
                        (force_val
                           (both_long
                              (λ n1 n2 : int64, Some (Vlong (Int64.add n1 n2)))
                              sem_cast_pointer (sem_cast_i2l Unsigned)
                              (Vlong Int64.one)
                              (Vint (Int.repr (Znth i contents_a)))))
                        (Vint (Int.repr (-1))))))))
      = (sublist.sublist 0 (i + 1)
               (map Vint
                  (map Int.repr (int_to_list (list_to_int contents_a - prime)))) ++
            sublist.sublist (i + 1) 14 undef14)
         ) as H_v_b.

      rewrite <- !(sublist_rejoin 0 i (i+1)); try easy.
      rewrite <- app_assoc.
      rewrite upd_list_app_upper.
      rewrite Zlength_sublist; try easy.
      autorewrite with sublist.
      rewrite sublist_update_0th_gen; try easy; try lia.
      repeat f_equal.

      rewrite sublist_len_1.
      rewrite Znth_map_Vint_map_Int_repr.
      simpl.   (* simpl works really well here! *)
      f_equal; f_equal.
      unfold Int64.and.
      rewrite repr_eq_32_64.
      unfold Int64.add.
      rewrite Int64.unsigned_one.
      rewrite Int.unsigned_repr_eq.
      (* rewrite modulo_samerepr with ( y:= (Znth i (int_to_list (list_to_int contents_a - prime)))); try easy. *)
      replace (Int64.unsigned (Int64.repr (Int.unsigned (Int.repr (-1))))) with (Z.ones 32) by easy.
      rewrite Int.unsigned_repr_eq.
      (* replace (i) with (Z.of_nat (Z.to_nat i)) by lia.
      rewrite Znth_int_to_list.
      replace (Z.of_nat (Z.to_nat i)) with i by lia. *)
      rewrite L6.
      rewrite L6.
      replace (Int.unsigned (Int.repr (Znth i contents_a mod Int.modulus)))
         with (Znth i contents_a mod Int.modulus).
      rewrite L7; try easy; try apply Int.unsigned_range.
      rewrite Z.land_ones; try easy.
      rewrite Int.unsigned_repr_eq.
      replace (Int.modulus) with (2^32) by easy.
      repeat rewrite Z.mod_mod; try easy.
      replace (2 ^ (32 * i)) with
         (two_p (Int.unsigned(Int.repr ((32 * i))))).
      replace ((list_to_int contents_a - prime)) with (Int.unsigned (Int.repr ((list_to_int contents_a - prime)))).
      replace (Int.repr
      ((Int.unsigned (Int.repr (list_to_int contents_a - prime)) /
        two_p (Int.unsigned (Int.repr (32 * i)))))) with Int.zero. (*BAD*)
        rewrite <- Int.shru_div_two_p.

      apply modulo_samerepr.
      (* shru_div_two_p
      Search Int.shru.
      two_p_equiv
          *)
      apply H1.

      (* HERE *)
      assert ((Znth i contents_a = -1) \/ (Znth i contents_a <> -1)) by
      lia.
      destruct H10; try rewrite H10.
      replace ((Int64.add Int64.one (Int64.repr (Int.unsigned (Int.repr (-1))))))
         with (Int64.repr(2^32)) by easy.
      replace ((Int64.and (Int64.repr (2 ^ 32))
      (Int64.repr (Int.unsigned (Int.repr (-1)))))) with (Int64.zero) by easy.
      replace (Int.repr (Int64.unsigned Int64.zero)) with (Int.repr 0) by easy.

      assert (((list_to_int contents_a - prime) / 2 ^ (32 * i)) mod 2 ^ 32=
         ((list_to_int contents_a) / 2 ^ (32 * i)) mod 2 ^ 32
            -((prime) / 2 ^ (32 * i)) mod 2 ^ 32).

      simpl.
      Search (_ - _ mod _).

      rewrite eq_dec.
      assert (Int64.and
      (Int64.add Int64.one
         (Int64.repr (Int.unsigned (Int.repr (Znth i contents_a)))))
      (Int64.repr (Int.unsigned (Int.repr (-1)))) =
      Int64.repr( Int64.intval (Int64.and
            (Int64.add Int64.one
               (Int64.repr (Int.unsigned (Int.repr (Znth i contents_a)))))
            (Int64.repr (Int.unsigned (Int.repr (-1))))))).

      unfold Int64.and.

      (*****************************)

      admit.

      autorewrite with sublist; rewrite int_to_list_length; lia.
      autorewrite with sublist; rewrite int_to_list_length; lia.

      rewrite Zlength_sublist; try lia.
      autorewrite with sublist; rewrite int_to_list_length; lia.
      autorewrite with sublist; rewrite int_to_list_length; lia.

      rewrite H_v_b; cancel.

      assert(upd_Znth i
      (sublist.sublist 0 i (map Vint (map Int.repr (int_to_list (list_to_int contents_a mod prime)))) ++
         sublist.sublist i 14 undef14)
      (force_val
         (sem_cast_l2i I32 Unsigned
            (force_val
               (sem_and tulong tuint
                  (force_val
                     (both_long (λ n1 n2 : int64, Some (Vlong (Int64.add n1 n2))) sem_cast_pointer
                        (sem_cast_i2l Unsigned) (Vlong Int64.zero) (Vint (Int.repr (Znth i contents_a)))))
                  (Vint (Int.repr (-1)))))))
         = sublist.sublist 0 (i + 1) (map Vint (map Int.repr (int_to_list (list_to_int contents_a mod prime)))) ++
         sublist.sublist (i + 1) 14 undef14).

      rewrite <- !(sublist_rejoin 0 i (i+1)); try easy.
      rewrite <- app_assoc.
      rewrite upd_list_app_upper.
      rewrite Zlength_sublist; try easy.
      autorewrite with sublist.
      rewrite sublist_update_0th_gen; try easy; try lia.
      rewrite sublist_len_1.
      repeat f_equal.
      simpl.

      Compute (Int64.repr (Int.unsigned (Int.repr (-1)))).
      Compute (Int64.repr (2^32-1)).
         (*****************************)

      (* Need to show that (int_to_list list_to_int) combo preserves length. *)

   (* I proved (modulo the lemmas L1--L5) the part that the contents of
   * temp is as defined in the loop invariant.
   * The part that the contents of b are as in the loop invariant is ugly.
   * One need to prove that whatever its been done
   * in the code with the temp is does indeed the least significant 7 limbs
   * of B = A - (2^448 - 2^224 - 1). A Lemma (or several) are needed.
   *)


Require Export euclidean__axioms.
Require Export euclidean__tactics.
Require Export lemma__collinearorder.
Require Export logic.
Definition lemma__NCorder : forall A B C, (euclidean__axioms.nCol A B C) -> ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (* Cut *) (~(euclidean__axioms.Col B A C)) as H0.
- intro H0.
assert (* Cut *) (euclidean__axioms.Col A B C) as H1.
-- assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H1.
--- apply (@lemma__collinearorder.lemma__collinearorder B A C H0).
--- destruct H1 as [H2 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
exact H2.
-- apply (@euclidean__tactics.Col__nCol__False A B C H H1).
- assert (* Cut *) (~(euclidean__axioms.Col B C A)) as H1.
-- intro H1.
assert (* Cut *) (euclidean__axioms.Col A B C) as H2.
--- assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H2.
---- apply (@lemma__collinearorder.lemma__collinearorder B C A H1).
---- destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
exact H7.
--- apply (@H0).
----apply (@euclidean__tactics.not__nCol__Col B A C).
-----intro H3.
apply (@euclidean__tactics.Col__nCol__False A B C H H2).

-- assert (* Cut *) (~(euclidean__axioms.Col C A B)) as H2.
--- intro H2.
assert (* Cut *) (euclidean__axioms.Col A B C) as H3.
---- assert (* Cut *) ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C B A) /\ (euclidean__axioms.Col B A C))))) as H3.
----- apply (@lemma__collinearorder.lemma__collinearorder C A B H2).
----- destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H6.
---- apply (@H0).
-----apply (@euclidean__tactics.not__nCol__Col B A C).
------intro H4.
apply (@euclidean__tactics.Col__nCol__False A B C H H3).

--- assert (* Cut *) (~(euclidean__axioms.Col A C B)) as H3.
---- intro H3.
assert (* Cut *) (euclidean__axioms.Col A B C) as H4.
----- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H4.
------ apply (@lemma__collinearorder.lemma__collinearorder A C B H3).
------ destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
exact H11.
----- apply (@H0).
------apply (@euclidean__tactics.not__nCol__Col B A C).
-------intro H5.
apply (@euclidean__tactics.Col__nCol__False A B C H H4).

---- assert (* Cut *) (~(euclidean__axioms.Col C B A)) as H4.
----- intro H4.
assert (* Cut *) (euclidean__axioms.Col A B C) as H5.
------ assert (* Cut *) ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C A B) /\ (euclidean__axioms.Col A B C))))) as H5.
------- apply (@lemma__collinearorder.lemma__collinearorder C B A H4).
------- destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
exact H13.
------ apply (@H0).
-------apply (@euclidean__tactics.not__nCol__Col B A C).
--------intro H6.
apply (@euclidean__tactics.Col__nCol__False A B C H H5).

----- split.
------ apply (@euclidean__tactics.nCol__notCol B A C H0).
------ split.
------- apply (@euclidean__tactics.nCol__notCol B C A H1).
------- split.
-------- apply (@euclidean__tactics.nCol__notCol C A B H2).
-------- split.
--------- apply (@euclidean__tactics.nCol__notCol A C B H3).
--------- apply (@euclidean__tactics.nCol__notCol C B A H4).
Qed.


Require Import POCS.
Require Export TwoDiskBaseAPI.

(**
TwoDiskAPI supports reading and writing to two disks, with the possibility for a
disk to fail at any time. This layer provides easier-to-use specifications
written in terms of [maybe_holds] (the ?|= notation). The fact that at least one
disk is always functioning is encoded in the inductive type [TwoDiskBaseAPI.State]
itself; it has only three cases, for both disks, only disk 0, and only disk 1.
*)

Definition two_disks_are (s : State) (p0 : disk -> Prop) (p1 : disk -> Prop) :=
  get_disk d0 s ?|= p0 /\
  get_disk d1 s ?|= p1.

Definition read0_spec (a : addr) : Specification _ _ unit _ :=
  fun '(d, F) state => {|
    pre := two_disks_are state (eq d) F;
    post := fun r state' =>
      match r with
      | Working v => two_disks_are state' (eq d) F /\
                     diskGet d a ?|= eq v
      | Failed    => two_disks_are state' missing F
      end;
    recovered := fun _ state' => two_disks_are state' (eq d) F;
  |}.

Definition read1_spec (a : addr) : Specification _ _ unit _ :=
  fun '(d, F) state => {|
    pre := two_disks_are state F (eq d);
    post := fun r state' =>
      match r with
      | Working v => two_disks_are state' F (eq d) /\
                     diskGet d a ?|= eq v
      | Failed    => two_disks_are state' F missing
      end;
    recovered := fun _ state' => two_disks_are state' F (eq d);
  |}.

Definition write0_spec (a : addr) (b : block) : Specification _ (DiskResult unit) unit _ :=
  fun '(d, F) state => {|
    pre := two_disks_are state (eq d) F;
    post := fun r state' =>
      match r with
      | Working _ => two_disks_are state' (eq (diskUpd d a b)) F
      | Failed    => two_disks_are state' missing F
      end;
    recovered := fun _ state' =>
      (two_disks_are state' (eq (diskUpd d a b)) F /\ a < diskSize d) \/
      two_disks_are state' (eq d) F;
  |}.

Definition write1_spec (a : addr) (b : block) : Specification _ (DiskResult unit) unit _ :=
  fun '(d, F) state => {|
    pre := two_disks_are state F (eq d);
    post := fun r state' =>
      match r with
      | Working _ => two_disks_are state' F (eq (diskUpd d a b))
      | Failed    => two_disks_are state' F missing
      end;
    recovered := fun _ state' =>
      (two_disks_are state' F (eq (diskUpd d a b)) /\ a < diskSize d) \/
      two_disks_are state' F (eq d);
  |}.

Definition size0_spec : Specification _ _ unit _ :=
  fun '(d, F) state => {|
    pre := two_disks_are state (eq d) F;
    post := fun r state' =>
      match r with
      | Working n => two_disks_are state' (eq d) F /\ n = diskSize d
      | Failed    => two_disks_are state' missing F
      end;
    recovered := fun _ state' => two_disks_are state' (eq d) F;
  |}.

Definition size1_spec : Specification _ _ unit _ :=
  fun '(d, F) state => {|
    pre := two_disks_are state F (eq d);
    post := fun r state' =>
      match r with
      | Working n => two_disks_are state' F (eq d) /\ n = diskSize d
      | Failed    => two_disks_are state' F missing
      end;
    recovered := fun _ state' => two_disks_are state' F (eq d);
  |}.

Module Type TwoDiskAPI.

  Axiom init : proc InitResult.
  Axiom read : diskId -> addr -> proc (DiskResult block).
  Axiom write : diskId -> addr -> block -> proc (DiskResult unit).
  Axiom size : diskId -> proc (DiskResult nat).
  Axiom recover : proc unit.

  Axiom abstr : Abstraction State.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom read0_ok : forall a, proc_spec (read0_spec a) (read d0 a) recover abstr.
  Axiom read1_ok : forall a, proc_spec (read1_spec a) (read d1 a) recover abstr.
  Axiom write0_ok : forall a v, proc_spec (write0_spec a v) (write d0 a v) recover abstr.
  Axiom write1_ok : forall a v, proc_spec (write1_spec a v) (write d1 a v) recover abstr.
  Axiom size0_ok : proc_spec size0_spec (size d0) recover abstr.
  Axiom size1_ok : proc_spec size1_spec (size d1) recover abstr.
  Axiom recover_wipe : rec_wipe recover abstr no_wipe.

  Hint Resolve init_ok : core.
  Hint Resolve read0_ok : core.
  Hint Resolve read1_ok : core.
  Hint Resolve write0_ok : core.
  Hint Resolve write1_ok : core.
  Hint Resolve size0_ok : core.
  Hint Resolve size1_ok : core.
  Hint Resolve recover_wipe : core.

End TwoDiskAPI.


Require Import SKI.expr.
Require Coq.Setoids.Setoid.

Definition I : expr := S [+] K [+] K.

Theorem steps_star_I : forall c, (I [+] c) ~>* c.
Proof.
  intro.
  unfold I.

  eapply steps_many.
  apply steps_S.

  eapply steps_once.
  apply steps_K.
Qed.

Theorem is_normal_I : is_normal I.
Proof.
  unfold is_normal.
  unfold not.
  intros.

  apply steps_Sxy_cases in H.
  destruct H.
  destruct H.
  destruct H.
  inversion H.
  destruct H.
  destruct H.
  inversion H.
Qed.

Theorem is_const_I : is_const I.
Proof.
  unfold I.
  generalize (is_const_S).
  generalize (is_const_K).
  intros.
  apply is_const_app_iff. split.
  apply is_const_app_iff. split.
  auto.
  auto.
  auto.
Qed.

(* Deriving B M T basis from S K I *)
Definition T : expr := S [+] (K [+] (S [+] I)) [+] K.

Theorem is_const_T : is_const T.
Proof.
  unfold T.
  unfold I.
  generalize is_const_S. intros.
  generalize is_const_K. intros.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  split; auto. split; auto.
Qed.

Theorem steps_star_T : forall x y, (T [+] x [+] y) ~>* (y [+] x).
Proof.
  intros.
  unfold T.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_once.
  apply steps_S.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_once.
  apply steps_K.

  eapply steps_star_trans.
  apply steps_once.
  apply steps_S.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_I.

  apply steps_star_app_r.
  apply steps_once.
  apply steps_K.
Qed.

Definition B : expr := S [+] (K [+] S) [+] K.

Theorem is_const_B : is_const B.
Proof.
  unfold B.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.

  generalize is_const_S. intros.
  generalize is_const_K. intros.

  auto.
Qed.

Theorem steps_star_B : forall x y z, B [+] x [+] y [+] z ~>* x [+] (y [+] z).
Proof.
  intros.
  unfold B.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_once.
  apply steps_S.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_once.
  apply steps_K.

  eapply steps_star_trans.
  apply steps_once.
  apply steps_S.

  apply steps_star_app_l.
  apply steps_once.
  apply steps_K.
Qed.

Definition M : expr := S [+] I [+] I.

Theorem is_const_M : is_const M.
Proof.
  unfold M.
  apply is_const_app_iff. split.
  apply is_const_app_iff. split.
  apply is_const_S.
  apply is_const_I.
  apply is_const_I.
Qed.

Theorem steps_star_M : forall x, M [+] x ~>* x [+] x.
Proof.
  intros.
  unfold M.

  eapply steps_star_trans.
  apply steps_once.
  apply steps_S.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_I.

  apply steps_star_app_r.
  apply steps_star_I.
Qed.

(* Some more useful combinators *)
Definition C : expr := B [+] (T [+] (B [+] B [+] T)) [+] (B [+] B [+] T).

Theorem is_const_C : is_const C.
Proof.
  unfold C.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  generalize is_const_B. intros.
  generalize is_const_T. intros.
  split; auto.
Qed.

Theorem steps_star_C : forall x y z, C [+] x [+] y [+] z ~>* x [+] z [+] y.
Proof.
  intros.
  unfold C.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_B.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_T.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_B.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_B.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_T.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_B.

  eapply steps_star_trans.
  apply steps_star_B.

  apply steps_star_T.
Qed.

(* L combinator is useful for recursion *)
Definition L : expr := C [+] B [+] M.

Theorem is_const_L : is_const L.
Proof.
  unfold L.
  apply is_const_app_iff. split.
  apply is_const_app_iff. split.
  apply is_const_C.
  apply is_const_B.
  apply is_const_M.
Qed.

Theorem steps_star_L : forall x y, L [+] x [+] y ~>* x [+] (y [+] y).
Proof.
  intros.
  unfold L.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_C.

  eapply steps_star_trans.
  apply steps_star_B.

  apply steps_star_app_r.
  apply steps_star_M.
Qed.

Definition V : expr := B [+] C [+] T.

Theorem is_const_V : is_const V.
Proof.
  unfold V.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.
  split.
  split.
  apply is_const_B.
  apply is_const_C.
  apply is_const_T.
Qed.

Theorem steps_star_V : forall x y z, V [+] x [+] y [+] z ~>* z [+] x [+] y.
Proof.
  intros.
  unfold V.

  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_star_app_l.
  apply steps_star_B.

  eapply steps_star_trans.
  apply steps_star_C.

  apply steps_star_app_l.
  apply steps_star_T.
Qed.

(* TRUE and FALSE combinators *)
Definition t : expr := K.

Theorem is_normal_t : is_normal t.
Proof.
  unfold is_normal.
  unfold not.
  intros.
  inversion H.
Qed.

Theorem steps_star_t : forall p q, t [+] p [+] q ~>* p.
Proof.
  intros.
  unfold t.
  apply steps_once.
  apply steps_K.
Qed.

Theorem is_const_t : is_const t.
Proof.
  unfold t.
  apply is_const_K.
Qed.

Definition f : expr := K [+] I.

Theorem is_normal_f : is_normal f.
Proof.
  unfold is_normal.
  unfold not.
  intros.
  inversion H; subst.
  inversion H3.
  apply is_normal_I in H3. auto.
Qed.

Theorem is_const_f : is_const f.
Proof.
  unfold f.
  apply is_const_app_iff.
  split.
  apply is_const_K.
  apply is_const_I.
Qed.

Theorem steps_star_f : forall p q, f [+] p [+] q ~>* q.
Proof.
  intros.
  unfold f.
  eapply steps_star_trans.
  apply steps_star_app_l.
  apply steps_once.
  apply steps_K.
  apply steps_star_I.
Qed.

Definition neg := (V [+] f [+] t).

Theorem is_const_neg : is_const neg.
Proof.
  unfold neg.
  rewrite is_const_app_iff.
  rewrite is_const_app_iff.

  split. split.
  apply is_const_V.
  apply is_const_f.
  apply is_const_t.
Qed.

Theorem steps_star_neg_t : neg [+] t ~>* f.
Proof.
  unfold neg.
  eapply steps_star_trans.
  apply steps_star_V.
  apply steps_star_t.
Qed.

Theorem steps_star_neg_f : neg [+] f ~>* t.
Proof.
  unfold neg.
  eapply steps_star_trans.
  apply steps_star_V.
  apply steps_star_f.
Qed.

Definition sage c := L [+] c [+] (L [+] c).

Theorem sage_intros_no_vars : forall c n, ~ n IN c -> ~ n IN (sage c).
Proof.
  intros.
  unfold sage.
  generalize (is_const_C). intros.
  generalize (is_const_L). intros.
  apply not_contains_var_app_iff. split.
  apply not_contains_var_app_iff. split.
  auto. auto.
  apply not_contains_var_app_iff. split.
  auto. auto.
Qed.

Theorem steps_star_sage : forall c, sage c ~>* c [+] (sage c).
Proof.
  intros.
  unfold sage.
  apply steps_star_L.
Qed.


(*|
#######################################
A simple case of universe inconsistency
#######################################

:Link: https://stackoverflow.com/q/51029234
|*)

(*|
Question
********

I can define the following inductive type:
|*)

Inductive T : Type -> Type :=
| c1 : forall (A : Type), A -> T A
| c2 : T unit.

(*|
But then the command ``Check (c1 (T nat))`` fails with the message:
|*)

Fail Check (c1 (T nat)). (* .fails .unfold *)

(*|
How can I tweak the above inductive definition so that ``c1 (T nat)``
does not cause a universe inconsistency, and without setting universe
polymorphism on?

The following works, but I would prefer a solution without adding
equality:
|*)

Reset Initial. (* .none *)
Inductive T (A : Type) : Type :=
| c1 : A -> T A
| c2' : A = unit -> T A.

Definition c2 : T unit := c2' unit eq_refl.

Check (c1 (T nat)). (* .unfold *)

(*|
Answer
******

Let me first answer the question of why we get the universe
inconsistency in the first place.

Universe inconsistencies are the errors that Coq reports to avoid
proofs of ``False`` via Russell's paradox, which results from
considering the set of all sets which do not contain themselves.

There's a variant which is more convenient to formalize in type theory
called Hurken's Paradox; see `Coq.Logic.Hurkens
<https://coq.inria.fr/library/Coq.Logic.Hurkens.html>`__ for more
details. There is a specialization of Hurken's paradox which proves
that no type can retract to a smaller type. That is, given

.. code-block:: coq

    U := Type@{u}
    A : U
    down : U -> A
    up : A -> U
    up_down : forall (X:U), up (down X) = X

we can prove ``False``.

----

This is almost exactly the setup of your ``Inductive`` type.
Annotating your type with universes, you start with
|*)

Reset Initial. (* .none *)
Universes i j. (* .none *)
Inductive T : Type@{i} -> Type@{j} :=
| c1 : forall (A : Type@{i}), A -> T A
| c2 : T unit.

(*| Note that we can invert this inductive; we may write |*)

Definition c1' (A : Type@{i}) (v : T A) : A :=
  match v with
  | c1 A x => x
  | c2 => tt
  end.

Lemma c1'_c1 (A : Type@{i}) : forall v, c1' A (c1 A v) = v.
Proof. reflexivity. Qed.

(*|
Suppose, for a moment, that ``c1 (T nat)`` typechecked. Since ``T nat
: Type@{j}``, this would require ``j <= i``. If it gave us that ``j <
i``, then we would be set. We could write ``c1 Type@{j}``. And this is
exactly the setup for the variant of Hurken's that I mentioned above!
We could define

.. code-block:: coq

    u = j
    U := Type@{j}
    A := T Type@{j}
    down : U -> A := c1 Type@{j}
    up : A -> U := c1' Type@{j}
    up_down := c1'_c1 Type@{j}

and hence prove ``False``.

Coq needs to implement a rule for avoiding this paradox. As described
`here
<https://github.com/coq/coq/issues/7929#issuecomment-400376700>`__,
the rule is that for each (non-parameter) argument to a constructor of
an inductive, if the type of the argument has a sort in universe
``u``, then the universe of the inductive is constrained to be ``>=
u``. In this case, this is stricter than Coq needs to be. As mentioned
by SkySkimmer `here
<https://github.com/coq/coq/issues/7929#issuecomment-400384621>`__,
Coq could recognize arguments which appear directly in locations which
are indices of the inductive, and disregard those in the same way that
it disregards parameters.

----

So, to finally answer your question, I believe the following are your
only options:

1. You can ``Set Universe Polymorphism`` so that in ``T (T nat)``,
   your two ``T``\ s take different universe arguments. (Equivalently,
   you can write ``Polymorphic Inductive``.)
2. You can take advantage of how Coq treats parameters of inductive
   types specially, which mandates using equality in your case. (The
   requirement of using equality is a general property of going from
   indexed inductive types to parameterized inductives types---from
   moving arguments from after the ``:`` to before it.)
3. You can pass Coq the flag ``-type-in-type`` to entirely disable
   universe checking.
4. You can `fix bug #7929 <https://github.com/coq/coq/issues/7929>`__,
   which I reported as part of digging into this question, to make Coq
   handle arguments of constructors which appear in index-position in
   the inductive in the same way it handles parameters of inductive
   types.
5. (You can find another edge case of the system, and manage to trick
   Coq into ignoring the universes you want to slip past it, and
   probably find a proof of ``False`` in the process. (Possibly
   involving module subtyping, see, e.g., `this recent bug in modules
   with universes <https://github.com/coq/coq/issues/7695>`__.))
|*)


(**************************************************************************)
(*                                                                        *)
(*     Sniper                                                             *)
(*     Copyright (C) 2021                                                 *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(* If you have Sniper installed, change these two lines into:
   From Sniper Require Import Sniper.
   From Sniper Require Import tree.
*)
Require Import Sniper.
Require Import tree.
Require Import String.
Require Import ZArith.
Require Import Bool.
Require Import Coq.Lists.List.
Import ListNotations.

Local Open Scope Z_scope.

(** Examples on lists *)

(* A simple example *)
Goal forall (l : list Z) (x : Z), hd_error l = Some x -> (l <> nil).
Proof. snipe. Qed.

(* The `snipe` tactics requires instances of equality to be decidable.
   It is in particular visible with type variables. *)
Section Generic.

  Variable A : Type.
  Goal forall (l : list A) (x : A),  hd_error l = Some x -> (l <> nil).
  Proof.
    snipe.
    (* New goals are open that require instances of equality to be
       decidable. On usual types such as `Z` in the previous example,
       these goals are automatically discharged. On other concrete
       types, it is up to the user to prove it or admit it. *)
  Abort.

  (* On abstract type, it has to be assumed. *)
  Hypothesis HA : CompDec A.
  Goal forall (l : list A) (x : A),  hd_error l = Some x -> (l <> nil).
  Proof. snipe. Qed.

End Generic.

(* When the goal is automatically provable by the `snipe` tactic, it is
   often done in a few seconds. To avoid too long runs when the goal is
   not provable, the tactic can be called with a timeout, in seconds. *)
Section Timeout.

  Variable A : Type.
  Hypothesis HA : CompDec A.
  Goal forall (l : list A) (x : A),  hd_error l = Some x -> (l <> nil).
  Proof. (* snipe_timeout 10. *) snipe. Qed.

End Timeout.

(* A more involved example *)
Section destruct_auto.

  Variable A : Type.
  Variable HA : CompDec A.

(* This theorem needs a case analysis on x and y *)
 Theorem app_eq_unit (x y:list A) (a:A) :
      x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
  Proof.
    destruct x as [|a' l]; [ destruct y as [|a' l] | destruct y as [| a0 l0] ];
      simpl.
    intros H; discriminate H.
    left; split; auto.
    intro H; right; split; auto.
    generalize H.
    generalize (app_nil_r l); intros E.
    rewrite -> E; auto.
    intros H.
    injection H as [= H H0].
    assert ([] = l ++ a0 :: l0) as H1 by auto.
    apply app_cons_not_nil in H1 as [].
  Qed.

Theorem app_eq_unit_auto :
    forall (x y: list A) (a:A),
      x ++ y = a :: nil -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
  Proof. snipe. Qed.

End destruct_auto.

(* Example of searching an element in a list *)
Fixpoint search {A : Type} {H: CompDec A} (x : A) l :=
  match l with
  | [] => false
  | x0 :: l0 => eqb_of_compdec H x x0 || search x l0
  end.

Lemma search_app : forall {A: Type} {H : CompDec A} (x: A) (l1 l2: list A),
    search x (l1 ++ l2) = ((search x l1) || (search x l2))%bool.
Proof.
  intros A H x l1 l2. induction l1 as [ | x0 l0 IH].
  - reflexivity.
  - simpl. destruct (eqb_of_compdec H x x0).
    + reflexivity.
    + rewrite IH. reflexivity.
Qed.

(* The proof of this lemma, except induction, can be automatized *)
Lemma search_app_snipe : forall {A: Type} {H : CompDec A} (x: A) (l1 l2: list A),
    search x (l1 ++ l2) = ((search x l1) || (search x l2))%bool.
Proof. intros A H x l1 l2. induction l1 as [ | x0 l0 IH]; simpl; snipe. Qed.

(* Manually using this lemma *)
Lemma search_lemma : forall (A : Type) (H : CompDec A) (x: A) (l1 l2 l3: list A),
    search x (l1 ++ l2 ++ l3) = search x (l3 ++ l2 ++ l1).
Proof.
  intros A H x l1 l2 l3. rewrite !search_app.
  rewrite orb_comm with (b1 := search x l3).
  rewrite orb_comm  with (b1 := search x l2) (b2 := search x l1 ).
  rewrite orb_assoc.
  reflexivity.
Qed.

(* It can be fully automatized *)
Lemma snipe_search_lemma : forall (A : Type) (H : CompDec A) (x: A) (l1 l2 l3: list A),
search x (l1 ++ l2 ++ l3) = search x (l3 ++ l2 ++ l1).
Proof. intros A H. snipe @search_app. Qed.

(* Another example with search *)
Lemma in_inv : forall (A: Type) (HA : CompDec A) (a b:A) (l:list A),
    search b (a :: l) -> eqb_of_compdec HA a b \/ search b l.
Proof. intros A HA. snipe. Qed.

(* Another example with an induction *)
Lemma app_nil_r : forall (A: Type) (H: CompDec A) (l:list A), (l ++ [])%list = l.
Proof. intros A H; induction l; snipe. Qed.

Section higher_order.

Variable A B C: Type.
Variable HA : CompDec A.
Variable HB : CompDec B.
Variable HC : CompDec C.

Fixpoint zip {A B : Type} (l : list A) (l' : list B) :=
  match l, l' with
  | [], _ => []
  | x :: xs, [] => []
  | x :: xs, y :: ys => (x, y) :: zip xs ys
  end.

(* A nice example but a bit slow ~70s: we should investigate to improve the performance *)

Lemma zip_map : forall (f : A -> B) (g : A -> C) (l : list A),
map (fun (x : A) => (f x, g x)) l = zip (map f l) (map g l).
Proof. Time intros f g l ; induction l; snipe2. Qed.

(* An example with higher order and anonymous functions
Note that as map should be instantiated by f and g,
it does not work by using an induction principle which generalizes
on f and g, so f and g have to be introduced before l
It also work only with snipe2 because the arrow type instances will
make SMTCoq complain *)
Lemma map_compound : forall (f : A -> B) (g : B -> C) (l : list A),
map g (map f l) = map (fun x => g (f x)) l.
Proof.
induction l; snipe2. Qed.

End higher_order.

(** Examples on trees *)

Lemma empty_tree_Z2 : forall (t : @tree Z) a t' b,
is_empty t = true -> t <> Node a t' b.
Proof. intros t a t' b; snipe. Qed.

Lemma rev_elements_app :
 forall A (H:CompDec A) s acc, tree.rev_elements_aux A acc s = ((tree.rev_elements A s) ++ acc)%list.
Proof. intros A H s ; induction s.
- snipe app_nil_r.
- snipe (app_ass, app_nil_r).
Qed.

Lemma rev_elements_node c (H: CompDec c) l x r :
 rev_elements c (Node l x r) = (rev_elements c r ++ x :: rev_elements c l)%list.
Proof. snipe (rev_elements_app, app_nil_r). Qed.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export geometry_tools_lemmas.
Require Export my_field_tac.

(***********************************************)
(* Unification tactic for signed areas         *)
(***********************************************)
(* Simplification is necessary for termination *)
(***********************************************)

Ltac uniformize_signed_areas_goal :=
  repeat
   match goal with
   |  |- context [(- - ?X1)] =>
       replace (- - X1) with X1 by apply simplring1
   |  |- context [(S ?X1 ?X1 ?X2)] =>
       replace (S X1 X1 X2) with 0 by apply trivial_col1
   |  |- context [(S ?X2 ?X1 ?X1)] =>
       replace (S X2 X1 X1) with 0 by apply trivial_col2
   |  |- context [(S ?X1 ?X2 ?X1)] =>
       replace (S X1 X2 X1) with 0 by apply trivial_col3
   |  |- context [(S ?X1 ?X2 ?X3)] =>
    ( let Truc := fresh in
    match goal with
       |  |- context [(S ?X4 ?X5 ?X6)] =>
            (assert (Truc : S X4 X5 X6 = - S X1 X2 X3);
             [ apply S_3 || apply S_2 || apply S_4
             | rewrite Truc; clear Truc ]) ||
             (assert (Truc : S X4 X5 X6 = S X1 X2 X3);
               [ apply S_0 || apply S_1 | rewrite Truc; clear Truc ])
       end)
   end.

Ltac generalize_all_areas :=
   repeat match goal with
          H: context [(S ?X1 ?X2 ?X3)] |- _=> revert H
 end.

Ltac uniformize_signed_areas :=
  generalize_all_areas;uniformize_signed_areas_goal;intros.

Lemma S4Simpl_1 : forall A B C : Point, S4 A B B C = S A B C.
intros.
unfold S4 in |- *.
uniformize_signed_areas.
ring.
Qed.

Lemma S4Simpl_2 : forall A B C : Point, S4 A B C C = S A B C.
intros.
unfold S4 in |- *.
uniformize_signed_areas.
ring.
Qed.

Lemma S4Simpl_3 : forall A B C : Point, S4 A A B C = S A B C.
intros.
unfold S4 in |- *.
uniformize_signed_areas.
ring.
Qed.

Lemma S4Simpl_4 : forall A B C : Point, S4 A B C A = S A B C.
intros.
unfold S4 in |- *.
uniformize_signed_areas.
ring.
Qed.

Lemma S4Simpl_5 : forall A C D : Point, S4 C A D A = 0.
Proof.
intros.
unfold S4 in |- *.
uniformize_signed_areas.
ring.
Qed.

Lemma S4Simpl_6 : forall A C D : Point, S4 A C A D = 0.
Proof.
intros.
unfold S4 in |- *.
uniformize_signed_areas.
ring.
Qed.

Lemma half : 1- 1/2 = 1/2.
Proof.
field.
auto with Geom.
Qed.

Ltac uniformize_signed_areas4_goal :=
  repeat
   match goal with
   |  |- context [(- - ?X1)] =>
       replace (- - X1) with X1; [ idtac | apply simplring1 ]
   |  |- context [(S4 ?X1 ?X2 ?X1 ?X3)] =>
	rewrite (S4Simpl_6 X1 X2 X3)
   |  |- context [(S4 ?X2 ?X1 ?X3 ?X1)] =>
        rewrite (S4Simpl_5 X1 X2 X3)
   |  |- context [(S4 ?X1 ?X2 ?X2 ?X3)] =>
        rewrite (S4Simpl_1 X1 X2 X3)
   |  |- context [(S4 ?X1 ?X2 ?X3 ?X3)] =>
        rewrite (S4Simpl_2 X1 X2 X3)
   |  |- context [(S4 ?X1 ?X1 ?X2 ?X3)] =>
        rewrite (S4Simpl_3 X1 X2 X3)
   |  |- context [(S4 ?X1 ?X2 ?X3 ?X1)] =>
        rewrite (S4Simpl_4 X1 X2 X3)
   |  |- context [(S4 ?X1 ?X2 ?X3 ?X4)] =>
       match goal with
       |  |- context [(S4 ?X5 ?X6 ?X7 ?X8)] =>
           (assert (Truc : S4 X5 X6 X7 X8 = - S4 X1 X2 X3 X4);
             [ apply S4_5 || apply S4_6 || apply S4_7 || apply S4_8
             | rewrite Truc; clear Truc ]) ||
             (assert (Truc : S4 X5 X6 X7 X8 = S4 X1 X2 X3 X4);
               [ apply S4_2 || apply S4_3 || apply S4_4
               | rewrite Truc; clear Truc ])
       end
   end.

Ltac generalize_all_areas4 :=
   repeat match goal with
          H: context [(S4 ?X1 ?X2 ?X3 ?X4)] |- _=> revert H
 end.

Ltac uniformize_signed_areas4 :=
  generalize_all_areas4;uniformize_signed_areas4_goal;intros.

(****************************************)
(* Signed distance unification tactic   *)
(****************************************)

Ltac uniformize_dir_seg_goal :=
  repeat
   match goal with
   |  |- context [(- - ?X1)] =>
       replace (- - X1) with X1; [ idtac | apply simplring1 ]
   |  |- context [(?X1 ** ?X1)] =>
       rewrite <- (nuldirseg X1)
   |  |- context [(?X1 ** ?X2)] =>
       match goal with
       |  |- context [(?X3 ** ?X4)] =>
           match constr:((X3, X4)) with
           | (?X2, ?X1) => rewrite (A1a X1 X2)
           end
       end
   end.

Ltac generalize_all_seg :=
   repeat match goal with
          H: context [(?X1 ** ?X2)] |- _=> revert H
 end.

Ltac uniformize_dir_seg_general :=
  generalize_all_seg;uniformize_dir_seg_goal;intros.

Ltac try_rw A B := try rewrite <- (A1a B A) in *;
                   try rewrite    (A1a A B) in *.

Ltac uniformize_dir_seg_spec := match reverse goal with

 | [A : Point, B : Point, C : Point,
    D : Point, E : Point, F : Point,
    G : Point |- _ ] => fail 1

 | [A : Point, B : Point, C : Point, D: Point, E: Point, F: Point |- _ ] =>
     try_rw A B; try_rw A C; try_rw A D; try_rw A E; try_rw A F;
     try_rw B C; try_rw B D; try_rw B E; try_rw B F;
     try_rw C D; try_rw C E; try_rw C F;
     try_rw D E; try_rw D F;
     try_rw E F

 | [A : Point, B : Point, C : Point, D: Point, E: Point |- _ ] =>
     try_rw A B; try_rw A C; try_rw A D; try_rw A E;
     try_rw B C; try_rw B D; try_rw B E;
     try_rw C D; try_rw C E;
     try_rw D E

 | [A : Point, B : Point, C : Point, D: Point |- _ ] =>
     try_rw A B; try_rw A C; try_rw A D; try_rw B C; try_rw B D; try_rw C D

 | [A : Point, B : Point, C : Point |- _ ] =>
     try_rw A B; try_rw A C;try_rw B C

 | [A : Point, B : Point |- _ ] =>
     try_rw A B
end.

Ltac uniformize_dir_seg := uniformize_dir_seg_spec || uniformize_dir_seg_general.

Lemma test_uniformize_dir_seg_1 : forall A B,
A ** B = - B**A.
Proof.
intros.
uniformize_dir_seg.
ring.
Qed.

Lemma test_uniformize_dir_seg_2 : forall A B,
A ** B = - B**A ->
A ** B = - B**A.
Proof.
intros.
uniformize_dir_seg.
ring.
Qed.

Lemma test_uniformize_dir_seg_3 : forall A B C,
A ** B = - B**A + A**C + C**A + B**C + C**A ->
A ** B = - B**A.
Proof.
intros.
uniformize_dir_seg.
ring.
Qed.

Lemma test_uniformize_dir_seg_4 : forall A B C D,
A ** B = - B**A + A**C + C**A + B**C + C**A + D**A + A**D->
A ** B = - B**A.
Proof.
intros.
uniformize_dir_seg.
ring.
Qed.

Lemma test_uniformize_dir_seg_5 : forall A B C D, forall  E F G H I : Point,
A ** B = - B**A + A**C + C**A + B**C + C**A + D**A + A**D->
A ** B = - B**A.
Proof.
intros.
uniformize_dir_seg.
ring.
Qed.

(*************************)
(* Simplification tactic *)
(*************************)

Hint Rewrite S4Simpl_1  S4Simpl_2 S4Simpl_3 S4Simpl_4 S4Simpl_5 S4Simpl_6 : S4_simplifications.
Hint Rewrite <- trivial_col1: S_simplifications.
Hint Rewrite <- trivial_col2: S_simplifications.
Hint Rewrite <- trivial_col3: S_simplifications.
Hint Rewrite <- nuldirseg : seg_simplifications.
Hint Rewrite half  : seg_simplifications.

Ltac basic_non_field_simpl:= autorewrite with ring_simplification
                               S4_simplifications
                             S_simplifications
          seg_simplifications in *.

Ltac basic_simpl := repeat (progress (basic_non_field_simpl;basic_field_simpl)).


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

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

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

*)

Require Export universe.

Definition decidable (P: Type):= (P + (notT P))%type.
Definition d2b {x} (d : decidable x) : bool := if d then true else false.
Definition dassert {x} (d : decidable x) : Prop := d2b d = true.

Inductive void : Type := .

(* ========= Here is a constuctive iff ======== *)

(*Definition t_iff A B := (A -> B) # (B -> A).*)

Inductive t_iff (A B : Type) : Type :=
 | t_iff_cons : (A -> B) -> (B -> A) -> t_iff A B.

Notation "x <o> y" := (t_iff x y) (at level 95, no associativity).

Lemma tiff_trans :
  forall a b c, (a <o> b) -> (b <o> c) -> (a <o> c).
Proof.
  intros a b c i1 i2.
  destruct i1 as [i11 i12].
  destruct i2 as [i21 i22].
  split; intro k.
  apply i11 in k; apply i21 in k; auto.
  apply i22 in k; apply i12 in k; auto.
Qed.

Ltac dtiff :=
  match goal with
      [ H : ?x <o> ?y |- _ ] => destruct H
  end.

Ltac dtiffs := repeat dtiff.

Ltac dprod :=
  match goal with
      [ H : ?x ## ?y |- _ ] => destruct H
  end.

Ltac dprods := repeat dprod.

Ltac dsum :=
  match goal with
      [ H : ?x [+] ?y |- _ ] => destruct H
  end.

Ltac dsums := repeat dsums.

Ltac dall :=
  repeat match goal with
           | [ H : ?x <o> ?y |- _ ] => destruct H
           | [ H : ?x ## ?y   |- _ ] => destruct H
           | [ H : ?x [+] ?y |- _ ] => destruct H
         end.

Definition tiff_fst :=
  fun {A B : Type} (p : A <o> B) => let (x, _) := p in x.

Definition tiff_snd :=
  fun {A B : Type} (p : A <o> B) => let (_, y) := p in y.

Lemma tiff_is_prod_implies1 :
  forall A B,
    (A <o> B) <o> ((A -> B) ## (B -> A)).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma tiff_is_prod_implies2 :
  forall A B : Type,
    ((A -> B) ## (B -> A)) <o> (A <o> B).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma combine_t_iff_proofs_imp :
  forall {A B A' B' : Type},
    (A <o> A') -> (B <o> B') -> ((A -> B) <o> (A' -> B')).
Proof.
  intros; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_t_iff :
  forall {A B A' B'},
    (A <o> A')
    -> (B <o> B')
    -> ((A <o> B) <o> (A' <o> B')).
Proof.
  intros.
  dall; constructor; intro; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_prod :
  forall {A B A' B'},
    (A <o> A')
    -> (B <o> B')
    -> ((A ## B) <o> (A' ## B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_sum :
  forall {A B A' B'},
    (A <o> A')
    -> (B <o> B')
    -> ((A [+] B) <o> (A' [+] B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_not :
  forall {A A'},
    (A <o> A')
    -> (notT A <o> notT A').
Proof.
  intros.
  dall; constructor; repeat intro; auto.
Qed.

Lemma t_iff_refl :
  forall A, A <o> A.
Proof.
  intros; constructor; auto.
Qed.

Lemma t_iff_sym :
  forall {A B}, (A <o> B) -> (B <o> A).
Proof.
  intros.
  dall; constructor; auto.
Qed.

(* this build a proof object of T <o> T[b/a] where p is the proof of a<o>b.
*)
Ltac build_tiff_term T a b p :=
  match T with
    | a => p
    | ?x -> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_imp l r)
    | ?x <o> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_t_iff l r)
    | ?x ## ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_prod l r)
    | ?x [+] ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_sum l r)
    | notT ?x =>
      let l := build_tiff_term x a b p in
      constr:(combine_t_iff_proofs_not l)
    | _ => constr:(t_iff_refl T)
  end.

Tactic Notation "thin_last" :=
  match goal with H: ?T |- _ => clear H end.

Ltac apply' H1 H2 :=
  let H3 := fresh in (
    (pose proof (H1 H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Ltac build_and_rewrite H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <o> ?B =>
          let d := build_tiff_term C A B H in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply  name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <o> ?B =>
      let d := build_tiff_term C A B H in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name) H2;
        clear name
  end.

Ltac build_and_rewrite_rev H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <o> ?B =>
          let d := build_tiff_term C B A (t_iff_sym H) in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp_rev H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <o> ?B =>
      let d := build_tiff_term C B A (t_iff_sym H) in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name)  H2;
        clear name
  end.

Tactic Notation "trewrite" ident(H) :=
       build_and_rewrite H.

Tactic Notation "trewrite" ident(H) "in" ident (H') :=
       build_and_rewrite_hyp H H'.

Tactic Notation "trewrite" "<-" ident(H) :=
       build_and_rewrite_rev H.

Tactic Notation "trewrite" "<-" ident(H) "in" ident(H') :=
       build_and_rewrite_hyp_rev H H'.

Ltac get_instance_of  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_fst T) h) as name)||
        (pose proof (fun h:H => (tiff_fst (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H; *)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H <o> H2) as Hn by (apply T)
         (*; idtac "really succeded" H *)
         end

    | ?Hl <o> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl ## ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl [+] ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | notT ?Hl => get_instance_of T Hl Hn
    | ?Hl -> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
  end.

Ltac get_instance_of_rev  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_snd T) h) as name)||
        (pose proof (fun h:H => (tiff_snd (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H;*)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H2 <o> H) as Hn by (apply T)
         (** H2 in LHS; apply does not automatically take care
                    of symmetry *)
         (*; idtac "really succeded" H*)
         end

    | ?Hl <o> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl ## ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl [+] ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | notT ?Hl => get_instance_of_rev T Hl Hn
    | ?Hl -> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
  end.

(** rewrite using a universally quantified t_iff relation T  in the conclusion *)
Ltac trw T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of T C name;
        build_and_rewrite name; clear name
  end.

Ltac trw_rev  T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of_rev T C name;
        build_and_rewrite_rev name ; clear name
  end.

Ltac trw_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of T C name;
    build_and_rewrite_hyp name h; clear name.

Ltac trw_rev_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of_rev T C name;
    build_and_rewrite_hyp_rev name h; clear name.

(* Some general notation to use the above tactics *)

Tactic Notation "rw" constr(T) :=
  trw T || rewrite T.
Tactic Notation "rw" "<-" constr(T) :=
  trw_rev T || rewrite <- T.
Tactic Notation "rw" constr(T) "in" ident(H) :=
  trw_h T H || rewrite T in H.
Tactic Notation "rw" "<-" constr(T) "in" ident(H) :=
  trw_rev_h T H || rewrite <- T in H.

Tactic Notation "onerw" :=
       match goal with
         | [ H : _ |- _ ] => progress (trw H || rewrite H)
       end.

Tactic Notation "allrw" := repeat onerw.

Tactic Notation "allrw" "<-" :=
  repeat match goal with
           | [ H : _ |- _ ] => progress (trw_rev H || rewrite <- H)
          end.

(*
Tactic Notation "onerw" constr(T) :=
       match goal with
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).
*)

Tactic Notation "onerw" constr(T) :=
       let t := type of T in
       match goal with
         | [ H : _, H' : t |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         | [ H : t |- _ ] => fail 1
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).

Tactic Notation "rww" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         end.

Tactic Notation "allrw" "<-" constr(T) :=
  repeat match goal with
           | [ H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

Tactic Notation "rww" "<-" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

(* ------------------------ *)

(*
Theorem trw_demo: forall (P Q: nat -> Type),
 (forall n, P n <o> Q n )
  -> ((P 1 * void -> void ) <o> (Q 1 * void -> void )).
Proof.
  intros ? ?  Hiff.
  assert (P 1) by aXdmit.
  trw_h Hiff  X.
  trw Hiff .  apply t_iff_refl.
Qed.

(*
Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <o> forall m, Q m )
    -> ((P 1 * void -> void ) <o> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  constructor; intros.
  destruct X; auto.
  destruct X; auto.
Qed.
*)

Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <o> forall m, Q m )
    -> ((P 1 * void -> void ) <o> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  trw Hiff.
  apply t_iff_refl.
Qed.
*)

(**  --- setoid stuff -- delete? *)

Require Export Coq.Setoids.Setoid.

Inductive Cast (t : Type) : Prop :=
| cast : t -> Cast t.
Hint Constructors Cast.

Inductive Cast2 (p : Prop) : Type :=
| cast2 : p -> Cast2 p.
Hint Constructors Cast2.

Definition c_t_iff : relation Type :=
  fun A B : Type => Cast (A <o> B).

Notation "x <==> y" := (c_t_iff x y) (at level 95, no associativity).

Definition t_c_iff : relation Type :=
  fun A B : Type => Cast (A -> B) /\ Cast (B -> A).

Notation "x <~> y" := (t_c_iff x y) (at level 95, no associativity).

Lemma CType_S : Setoid_Theory Type c_t_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  inversion H; subst.
  dall.
  repeat constructor; auto.

  unfold Transitive; intros.
  inversion H; inversion H0; subst.
  dall.
  repeat constructor; auto.
Qed.

Lemma TypeC_S : Setoid_Theory Type t_c_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  destruct H.
  inversion H; subst.
  inversion H0; subst.
  repeat constructor; auto.

  unfold Transitive; intros.
  destruct H; destruct H0.
  inversion H; inversion H0; inversion H1; inversion H2; subst.
  repeat constructor; auto.
Qed.

Add Setoid Type c_t_iff CType_S as Type_iff_reg.
Add Setoid Type t_c_iff TypeC_S as Type_iff_reg2.

Hint Resolve (Seq_refl  Type c_t_iff CType_S): setoid.
Hint Resolve (Seq_sym   Type c_t_iff CType_S): setoid.
Hint Resolve (Seq_trans Type c_t_iff CType_S): setoid.

Hint Resolve (Seq_refl  Type t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_sym   Type t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_trans Type t_c_iff TypeC_S): setoid.

(* ============================================== *)

(*
Lemma test :
  forall a b (*c f*), (a <o> b) -> Cast a. (*.  ## { x : c | f x }.*)
Proof.
  intros.
  rewrite X.
Qed.
*)

(** should not be required anymore? *)

Tactic Notation "trewrite" "<-" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_rev name;
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_rev name;
    clear name.
Tactic Notation "trewrite" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.
Tactic Notation "trewrite" "<-" ident(H) ident(p1) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Theorem dont_touch_forall :
  forall (P Q : (nat : Set) -> Type),
    (forall (n : (nat : Set)), P n <o> (forall (m : (nat : Set)), Q (m+n)))
    -> P (1 : (nat : Set))
    -> forall (m : (nat : Set)), Q (m+1).
Proof.
  intros ? ? Hif Hp1.

  rw Hif in Hp1; trivial.
Qed.

Theorem dont_touch_forall2 :
  forall (P Q : nat -> Type),
    (forall n, P n <o> (forall m, Q (m+n)))
    -> P 1
    -> forall m, Q (m+1).
Proof.
  intros ? ?  Hif Hp1.
  trw_rev Hif. trivial.
Qed.

Theorem dont_touch_forall3 :
  forall (P Q: nat -> Type),
    (forall n, P n <o> (forall m, Q (m+n)))
    -> (forall m, Q (m+1))
    -> P 1.
Proof.
  intros ? ? Hif Hq .
  trw_rev_h Hif Hq. trivial.
Qed.


Require Import ssreflect Arith.
Require Import Arith.EqNat.
Require Import Arith.Compare_dec.
Require Import List.
Require Import Omega.
Require Import untypedLambda.

Set Printing Universes.

(*Krivine Abstract Machine*)

(*Syntax*)

Inductive inst :=
| Access: nat -> inst
| Grab: inst
| Push: code -> inst
with code: Type :=
| cnil:   code
| cCons:  inst -> code -> code.

Inductive environment : Type :=
| nul: environment
| cons: code -> environment -> environment -> environment.

Check environment_ind.

Definition state := prod (prod code environment) environment.

Check inst->code.
Check Set.
Check code.
Check Set -> Type.
Check environment.
Check environment_ind.

Check cons  cnil nul nul.

(*Semantics*)

Definition exec_inst (s: state): state:=
  match s with
    | (cCons (Access 0) c, cons c0 e0 e, stack) => (c0, e0, stack)
    | (cCons (Access n) c, cons c0 e0 e, stack) => (cCons (Access (n-1)) c, e, stack)
    | (cCons (Push c) c0, e, stack) => (c0, e, cons c e stack)
    | (cCons Grab c, e, cons  c0 e0 stack) => (c, cons c0 e0 e, stack)
    | s => s
  end.

(*Compiling*)

Fixpoint compile (t: term): code :=
  match t with
      | Var n => cCons (Access n) cnil
      | Lambda t1 => cCons Grab (compile t1)
      | App t1 t2 => cCons (Push (compile t2)) (compile t1)
  end.

Fixpoint tau_code (c: code): term :=
  match c with
    | cnil => Var 0
    | (cCons (Access n) _ ) => Var n
    | (cCons (Push c1) c0) => App (tau_code c0) (tau_code c1)
    | (cCons Grab c0) => Lambda (tau_code c0)
  end.

Check multiple_substitution.

Fixpoint tau_env (e: environment): list term :=
  match e with
    | nul => nil
    | cons c0 e0 e1 =>
      (multiple_substitution 0 (tau_code c0) (tau_env e0)) :: tau_env e1
  end.

Check state.

Fixpoint transform_stk (stk: environment): list term :=
  match stk with
      | cons c0 e0 nul => multiple_substitution 0 (tau_code c0) (tau_env e0) :: nil
      | cons c0 e0 e1 => (multiple_substitution 0 (tau_code c0) (tau_env e0)) :: (transform_stk e1)
      | nul => nil
  end.

Check fold_left.

Fixpoint tau (s: state): term :=
  match s with
    | (c, e, stk) =>
      match stk with
        | nul => multiple_substitution 0 (tau_code c) (tau_env e)
        | stk => fold_left (fun t1 t2 => App t1 t2) (transform_stk stk) (multiple_substitution 0 (tau_code c) (tau_env e))
      end
  end.

(*Compiling results*)

Lemma tau_nil_env: forall t: term, tau (compile t, nul, nul) = tau_code (compile t).
Proof.
  induction t.
  simpl.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  reflexivity.
  intro h0.
  rewrite h0.
  rewrite -minus_n_O.
  have: leb v 0 = false \/ leb v 0 = true.
  apply dic.
  intro h1.
  case:h1.
  intro h1.
  rewrite h1.
  trivial.
  intro h1.
  rewrite h1.
  move:h1.
  case v.
  done.
  done.
  simpl.
  rewrite -lambda_equivalence.
  apply id_substitution.
  simpl.
  rewrite app_equivalence.
  split.
  apply id_substitution.
  apply id_substitution.
Qed.

Theorem invert_comp: forall (t: term), tau (compile t, nul, nul) = t.
Proof.
  induction t.
  simpl.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  reflexivity.
  intro h0.
  rewrite h0.
  rewrite -minus_n_O.
  have: leb v 0 = false \/ leb v 0 = true.
  apply dic.
  intro h1.
  case:h1.
  intro h1.
  rewrite h1.
  trivial.
  intro h1.
  rewrite h1.
  move:h1.
  case v.
  done.
  done.
  simpl.
  rewrite -lambda_equivalence.
  rewrite tau_nil_env in IHt.
  rewrite IHt.
  apply id_substitution.
  simpl.
  rewrite app_equivalence.
  rewrite tau_nil_env in IHt1.
  rewrite tau_nil_env in IHt2.
  split.
  rewrite IHt1.
  apply id_substitution.
  rewrite IHt2.
  apply id_substitution.
Qed.

(*Correct state*)

Fixpoint lenEnv (e: environment): nat :=
  match e with
    | nul => 0
    | cons c0 e0 e1 => 1 + (lenEnv e1)
  end.

Lemma length_inv: forall e:environment, lenEnv e = length (tau_env e).
Proof.
  intros.
  induction e.
  done.
  Search "ective_pair".
  simpl.
  omega.
Qed.

Inductive correct_stk : environment -> Prop :=
| Correct_stk_nil : correct_stk nul
| Correct_stk : forall (c0: code) (e0 e: environment),
                  C (lenEnv e0) (tau_code c0) -> correct_stk e0 -> correct_stk e ->
                  correct_stk (cons c0 e0 e).

Fixpoint corr_stk (stk: environment): Prop:=
  match stk with
    | nul => True
    | cons c0 e0 e => ((correct_stk e0) /\ (correct_stk e) /\ (C (lenEnv e0) (tau_code c0)))
  end.

Theorem ind_fix_corr: forall e:environment, correct_stk e <-> corr_stk e.
Proof.
  induction e.
  simpl.
  split.
  trivial.
  intro.
  apply Correct_stk_nil.
  simpl.
  split.
  intro.
  inversion H.
  tauto.
  intros.
  destruct H as [H0 [H1 H2]].
  apply Correct_stk.
  trivial.
  trivial.
  trivial.
Qed.

Definition correct_state (s: state): Prop:=
  match s with
   | (c, e, stk) => (correct_stk e) /\ (correct_stk stk) /\ (C (lenEnv e) (tau_code c))
  end.

Theorem transition_inv_1: forall (c c0: code) (e e0 stack: environment), correct_state ((cCons (Access 0) c, cons c0 e0 e, stack)) -> correct_state  (c0, e0, stack).
Proof.
  simpl.
  intros.
  split.
  destruct H.
  inversion H; trivial.
  split.
  apply H.
  destruct H.
  inversion H; trivial.
Qed.

Theorem transition_inv_2: forall (c c0: code) (e e0 stack: environment) (n: nat), (n > 0) -> correct_state (cCons (Access n) c, cons c0 e0 e, stack) -> correct_state (cCons (Access (n-1)) c, e, stack).
Proof.
  simpl.
  intros.
  split.
  destruct H0.
  inversion H0; trivial.
  split.
  apply H0.
  destruct H0 as [h0 [h1 h2]].
  omega.
Qed.

Theorem transition_inv_3: forall (c c0: code) (e stack: environment), correct_state (cCons (Push c) c0, e, stack) -> correct_state (c0, e, cons c e stack).
Proof.
  simpl.
  intros.
  destruct H as [h1 [h2 [h3 h4]]].
  split; trivial.
  split.
  apply Correct_stk.
  done.
  done.
  done.
  done.
Qed.

Theorem transition_inv_4: forall (c c0: code) (e e0 stack: environment), correct_state (cCons Grab c, e, cons c0 e0 stack) -> correct_state (c, cons c0 e0 e, stack).
Proof.
  simpl.
  intros.
  destruct H as [h1 [h2 h3]].
  split.
  apply Correct_stk.
  inversion h2.
  done.
  by (inversion h2).
  trivial.
  split.
  by (inversion h2).
  by rewrite plus_comm in h3.
Qed.

Theorem correct_invariance: forall s: state, correct_state s -> correct_state (exec_inst s).
Proof.
  intro.
  destruct s.
  destruct p.
  move: e e0.
  induction c.
  move => e e0.
  case e0.
  case e.
  simpl.
  done.
  simpl.
  done.
  simpl.
  done.
  case i.
  intros n e e0.
  case e0.
  case n.
  simpl.
  done.
  simpl.
  done.
  intros c0 e1 e2.
  unfold exec_inst.
  case n.
  apply transition_inv_1.
  intro.
  apply transition_inv_2.
  omega.
  unfold exec_inst.
  intros e e0.
  case e.
  done.
  intros c0 e1 e2.
  apply transition_inv_4.
  intros c0 e e0.
  apply transition_inv_3.
Qed.

Lemma correct_reduction_1: forall (c c0: code) (e s: environment), correct_state (cCons (Push c0) c,e,s) -> reduces (tau (cCons (Push c0) c,e,s)) (tau (c, e, cons c0 e s)).
Proof.
  intros.
  simpl.
  case s.
  simpl.
  apply sym.
  intros.
  simpl in H.
  simpl.
  apply sym.
Qed.

Lemma correct_reduction_2: forall (c c0: code) (e e0 s: environment),correct_state ((cCons (Access 0) c, cons c0 e0 e, s)) -> reduces (tau (cCons (Access 0) c, cons c0 e0 e, s)) (tau (c0, e0, s)).
Proof.
  simpl.
  intros.
  case s.
  apply sym.
  intros.
  apply sym.
Qed.

Lemma correct_reduction_3: forall (c c0: code) (e e0 s: environment) (n: nat), (n > 0) -> correct_state (cCons (Access n) c, cons c0 e0 e, s) -> reduces (tau (cCons (Access n) c, cons c0 e0 e, s)) (tau (exec_inst (cCons (Access n) c, cons c0 e0 e, s))).
Proof.
  have:forall n:nat, beq_nat n n = true.
  intro.
  rewrite beq_nat_true_iff.
  reflexivity.
  intro h0.
  unfold correct_state.
  intros c c0 e e0 s n.
  induction n.
  omega.
  intros.
  unfold exec_inst.
  destruct H0 as [h1 [h2 h3]].
  move:h1 h2 h3.
  case s.
  intros h1 h2 h3.
  simpl.
  rewrite ?h0.
  rewrite -?(length_inv).
  simpl in h3.
  rewrite -?minus_n_O.
  have:(leb n (lenEnv e - 1) = true).
  apply leb_iff.
  omega.
  intro h4.
  rewrite h4.
  have:(lenEnv e > 0).
  omega.
  intro.
  have:(exists n0:nat, lenEnv e = S n0).
  exists (lenEnv e - 1).
  omega.
  intro.
  case:x0.
  intros.
  rewrite p.
  have:(leb n x0 = true).
  apply leb_iff.
  omega.
  intro.
  rewrite x1.
  apply sym.
  intros.
  unfold tau.
  rewrite NPeano.Nat.sub_succ.
  rewrite -minus_n_O.
  rewrite -?length_inv.
  unfold tau_code.
  unfold multiple_substitution.
  rewrite -?minus_n_O.
  have:forall n: nat, 0 + n = n.
  intro.
  omega.
  intro.
  rewrite ?x.
  simpl in h3.
  have: S n <= lenEnv (cons c0 e0 e) - 1.
  simpl.
  simpl in h3.
  rewrite -minus_n_O.
  omega.
  intro.
  apply leb_iff in x0.
  rewrite length_inv in x0.
  rewrite x0.
  have: leb 0 (S n) = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x1.
  have: leb 0 n = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x2.
  have:(leb n (lenEnv e - 1) = true).
  apply leb_iff.
  omega.
  intro.
  rewrite length_inv in x3.
  rewrite x3.
  simpl.
  rewrite ?h0.
  apply sym.
Qed.

Definition c_list_i (i:nat) (lu: list term) : Prop :=
  forall k: nat, k < Datatypes.length lu -> C i (nth k lu (Var 0)).

Fixpoint closed_list (i:nat) (lu: list term): Prop :=
  match lu with
    | nil => True
    | x :: xs => C i x /\ closed_list i xs
  end.

Lemma closed_list_eq: forall (lu: list term) (i: nat), closed_list i lu <-> c_list_i i lu.
Proof.
  induction lu.
  simpl.
  unfold c_list_i.
  split.
  simpl.
  intros.
  omega.
  done.
  simpl.
  split.
  intros.
  unfold c_list_i.
  intro.
  case k.
  simpl.
  intros.
  tauto.
  simpl.
  intros.
  apply IHlu.
  tauto.
  omega.
  intro.
  split.
  unfold c_list_i in H.
  apply (H 0).
  simpl.
  omega.
  apply IHlu.
  unfold c_list_i.
  intro.
  case k.
  intro.
  apply (H 1).
  simpl.
  omega.
  intros.
  apply (H (S (S n))).
  simpl.
  omega.
Qed.

Lemma lift_len_inv: forall (lu: list term) (i k: nat), length lu = length (lift_all i k lu).
Proof.
  induction lu; simpl.
  by simpl.
  intros.
  by rewrite -IHlu.
Qed.

Lemma remove_lift: forall (t: term) (i k: nat), C k t -> lifting i k t = t.
Proof.
  induction t; simpl.
  intros.
  have: leb k v = false.
  by apply leb_iff_conv.
  intros.
  by rewrite x.
  intros.
  rewrite -lambda_equivalence.
  by apply IHt.
  intros.
  rewrite app_equivalence.
  split.
  apply IHt1.
  tauto.
  apply IHt2.
  tauto.
Qed.

Lemma list_lift_free: forall (lu : list term) (i k : nat), c_list_i i lu -> c_list_i (i + 1) (lift_all 1 k lu).
Proof.
  induction lu; simpl.
  unfold c_list_i.
  simpl.
  intros.
  omega.
  unfold c_list_i.
  intros i k h1 k0.
  case k0.
  simpl.
  intro.
  apply lift_free.
  apply (h1 0).
  simpl.
  omega.
  simpl.
  intros.
  apply IHlu.
  unfold c_list_i.
  intros.
  apply (h1 (S k1)).
  simpl.
  omega.
  omega.
Qed.

Lemma mult_sub_clos: forall (t: term) (u: list term) (i: nat), closed_list i u -> C (i+Datatypes.length u) t -> C i (multiple_substitution i t u).
Proof.
  induction t.
  simpl.
  intros.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  done.
  intro.
  rewrite x.
  have:leb v (i + Datatypes.length u - 1) = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x0.
  rewrite Bool.andb_true_r.
  have:leb i v = false \/ leb i v = true.
  apply dic.
  intro.
  case x1.
  intro.
  rewrite H1.
  simpl.
  apply leb_iff_conv in H1.
  trivial.
  intro.
  rewrite H1.
  apply leb_iff in x0.
  apply leb_iff in H1.
  apply closed_list_eq in H.
  unfold c_list_i in H.
  apply H.
  omega.
  simpl.
  intros.
  apply (IHt (lift_all 1 0 u) (i+1)).
  apply closed_list_eq.
  apply closed_list_eq in H.
  apply list_lift_free.
  done.
  rewrite -(lift_len_inv _ 1 0).
  have: i + Datatypes.length u + 1 = i + 1 + Datatypes.length u.
  omega.
  intro.
  rewrite -x.
  trivial.
  simpl.
  intros.
  split.
  apply IHt1.
  done.
  tauto.
  apply IHt2.
  done.
  tauto.
Qed.

Lemma closed_env: forall e:environment, correct_stk e -> closed_list 0 (tau_env e).
Proof.
  induction e.
  simpl.
  intros.
  trivial.
  intros.
  simpl.
  inversion H.
  split.
  apply mult_sub_clos.
  by apply IHe1.
  simpl.
  by rewrite -length_inv.
  by apply IHe2.
Qed.

Lemma remove_list_lift: forall lu: list term, closed_list 0 lu -> lift_all 1 0 lu = lu.
Proof.
  induction lu.
  by simpl.
  simpl.
  intros.
  have: lifting 1 0 a = a.
  apply remove_lift.
  tauto.
  intro.
  rewrite x.
  have: lift_all 1 0 lu = lu.
  apply IHlu.
  tauto.
  intro.
  by rewrite x0.
Qed.

Lemma fold_reduce: forall (s: environment) (t u: term), reducesInOneTo t u -> reduces (fold_left (fun t1 t2 : term => App t1 t2) (transform_stk s) t) (fold_left (fun t1 t2 : term => App t1 t2) (transform_stk s) u).
Proof.
  induction s.
  intros t u.
  simpl.
  intro.
  apply (ind t u u).
  trivial.
  apply sym.
  intros.
  unfold transform_stk.
  fold transform_stk.
  have: match s2 with
        | nul => multiple_substitution 0 (tau_code c) (tau_env s1) :: nil
        | cons _ _ _ =>
            multiple_substitution 0 (tau_code c) (tau_env s1)
            :: transform_stk s2
        end = multiple_substitution 0 (tau_code c) (tau_env s1) :: match s2 with
        | nul => nil
        | cons _ _ _ => transform_stk s2
        end.
  by case s2.
  intro.
  rewrite x.
  clear x.
  have:forall t:term, (fold_left (fun t1 t2 : term => App t1 t2)
        (multiple_substitution 0 (tau_code c) (tau_env s1)
         :: match s2 with
            | nul => nil
            | cons _ _ _ => transform_stk s2
            end) t)
            =
            (fold_left (fun t1 t2 : term => App t1 t2)
                       match s2 with
                         | nul => nil
                         | cons _ _ _ => transform_stk s2
                       end) (App t (multiple_substitution 0 (tau_code c) (tau_env s1))).
  by case s2.
  intros.
  rewrite ?x.
  clear x.
  move:IHs2.
  case s2.
  simpl.
  intros.
  apply (ind _ (App u (multiple_substitution 0 (tau_code c) (tau_env s1))) _).
  by apply appLeft.
  apply sym.
  intros.
  apply IHs2.
  by apply appLeft.
Qed.

Lemma correct_reduction_4: forall (c: code) (e s: environment), correct_state (cCons Grab c, e, s) -> reduces (tau (cCons Grab c, e, s)) (tau (exec_inst (cCons Grab c, e, s))).
Proof.
  intros c e s.
  move: c e.
  induction s.
  simpl.
  intros.
  apply sym.
  intros.
  inversion H.
  unfold exec_inst.
  unfold tau.
  unfold tau_code.
  fold tau_code.
  unfold transform_stk.
  fold transform_stk.
  have: match s2 with
        | nul => multiple_substitution 0 (tau_code c) (tau_env s1) :: nil
        | cons _ _ _ =>
            multiple_substitution 0 (tau_code c) (tau_env s1)
            :: transform_stk s2
        end = multiple_substitution 0 (tau_code c) (tau_env s1) :: match s2 with
        | nul => nil
        | cons _ _ _ => transform_stk s2
        end.
  by case s2.
  intro.
  rewrite x.
  unfold multiple_substitution.
  fold multiple_substitution.
  simpl.
  rewrite mult_sub_inv.
  case s2.
  simpl.
  have:lift_all 1 0 (tau_env e) = tau_env e.
  apply remove_list_lift.
  by apply closed_env.
  clear x.
  intro.
  rewrite x.
  apply (ind _ (substitution 0 (multiple_substitution 1 (tau_code c0) (tau_env e))
        (multiple_substitution 0 (tau_code c) (tau_env s1))) _).
  apply removeLamb.
  apply sym.
  intros.
  apply fold_reduce.
  simpl.
  have:lift_all 1 0 (tau_env e) = tau_env e.
  apply remove_list_lift.
  by apply closed_env.
  clear x.
  intro.
  rewrite x.
  apply removeLamb.
  intro j.
  apply closed_list_eq.
  simpl in H.
  destruct H as [h1 [h2 h3]].
  by apply closed_env.
Qed.

Theorem correct_confluence: forall s: state, correct_state s -> reduces (tau s) (tau (exec_inst s)).
Proof.
  intro s.
  destruct s as ((c, e), s).
  move: e s.
  induction c.
  intros.
  apply sym.
  case i.
  intros n e s.
  case n.
  intros.
  unfold exec_inst.
  move:H.
  case e.
  intro.
  apply sym.
  intros.
  apply correct_reduction_2.
  done.
  case e.
  intros.
  unfold exec_inst.
  apply sym.
  intros c0 e0 e1 n0.
  intro.
  apply correct_reduction_3.
  omega.
  done.
  unfold exec_inst.
  intros.
  move:H.
  case s.
  intro.
  apply sym.
  intros.
  apply correct_reduction_4.
  done.
  unfold exec_inst.
  intros.
  apply correct_reduction_1.
  done.
Qed.


(** * FOL's deduction Lemma *)

From Coq Require Import Ensembles.
From Coq Require Import List.

Require Import folProof.
Require Import folProp.

Section Deduction_Theorem.

Variable L : Language.
Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let Prf := Prf L.
Let SysPrf := SysPrf L.

Theorem DeductionTheorem :
  forall (T : System) (f g : Formula)
         (prf : SysPrf (Ensembles.Add _ T g) f),
    SysPrf T (g -> f)%fol.
Proof.
  intros T; assert
    (EasyCase :
       forall (g z : Formula),
         Prf nil z ->
         SysPrf (fun x : fol.Formula L => In x nil /\
                                            mem (fol.Formula L) T x)
                (g -> z)%fol).
  { intros g z H.
    set (A1 := IMP1 L z g) in *.
    set (A2 := MP L _ _ _ _ A1 H) in *.
    exists (nil:list Formula).
    exists A2.
    intros g0 H0; elim H0.
  }
  intros f g [F [H HF]].
  assert (H0: SysPrf (fun x => In x F /\ mem _ T x) (g -> f)%fol).
  { induction  H
      as
        [A
        | Axm1 Axm2 A  B  H1  HrecH1  H0  HrecH0
        | Axm A v  n  H  HrecH
        | A  B
        |  A  B  C
        |  A B
        |  A  v t
        |  A v  n
        | A  B v
        | |  |
        |  R
        |  f].
    - pose (HF _ (or_introl _ (refl_equal A))).
      clearbody m.
      destruct m.
      + set (A1 := AXM L x) in *.
        set (A2 := IMP1 L x g) in *.
        set (A3 := MP L _ _ _ _ A2 A1) in *.
        exists (x :: nil).
        exists A3.
        intros g0 H0; split.
        * apply H0.
        * destruct H0 as [H0 | H0].
          -- now subst.
          -- contradiction.
      + destruct H.
        set (A1 := IMP2 L g (impH g g) g) in *.
        set (A2 := IMP1 L g (impH g g)) in *.
        set (A3 := MP L _ _ _ _ A1 A2) in *.
        set (A4 := IMP1 L g g) in *.
        set (A5 := MP L _ _ _ _ A3 A4) in *.
        exists (nil:list Formula); exists A5; contradiction.
    - induction  HrecH0 as (x, H).
      + induction  H as (x0, H).
        induction  HrecH1 as (x1, H2).
        * induction  H2 as (x2, H2).
          set (A1 := IMP2 L g A B) in *.
          set (A2 := MP L _ _ _ _ A1 x2) in *.
          set (A3 := MP L _ _ _ _ A2 x0) in *.
          exists (x1 ++ x).
          exists A3.
          simpl in |- *.
          clear - H H2.
          intros g H0; split.
          -- change (In g (Axm1 ++ Axm2)); apply in_or_app.
             destruct (in_app_or _ _ _ H0); firstorder.
          -- destruct (in_app_or _ _ _ H0); firstorder.
        * firstorder auto with datatypes.
      + firstorder auto with datatypes.
    - induction  HrecH as (x, H0).
      + induction  H0 as (x0, H0).
        assert (H1: In g Axm \/ (forall x, In x Axm -> mem _ T x)).
        { clear - HF.
          induction Axm.
          - firstorder.
          - elim (HF a (or_introl _ (refl_equal a))).
            assert (H :forall g0 : fol.Formula L,
                       In g0 Axm ->
                       mem (fol.Formula L)
                         (Ensembles.Add (fol.Formula L) T g) g0)
              by firstorder.
            + destruct (IHAxm H).
              * firstorder.
              * intros; right.
                intros x0 [H2|H2].
                -- elim H2; assumption.
                -- apply H0; assumption.
            + intros x H;  elim H.
              firstorder.
        }
        destruct H1 as [a|b].
        * assert (~ In v (freeVarListFormula L x)).
        { clear x0 H.
          induction  x as [| a0 x Hrecx].
          - auto.
          - unfold not in |- *; intro H;  simpl in H.
            induction (in_app_or _ _ _ H).
            + elim n.
              eapply In_freeVarListFormula.
              * apply H1.
              * firstorder.
            + elim Hrecx.
              * intros.
                apply H0.
                firstorder.
              * assumption.
        } assert (H2: ~ In v (freeVarFormula L g)).
        { unfold not in |- *; intros; elim n.
          eapply In_freeVarListFormula.
          apply H2.
          assumption.
        }
        set (A1 := GEN L _ _ _ H1 x0) in *.
        set (A2 := FA3 L g A v) in *.
        set (A3 := MP L _ _ _ _ A2 A1) in *.
        set (A4 := FA2 L g v H2) in *.
        set (A5 := IMP2 L g (forallH v g) (forallH v A)) in *.
        set (A6 := IMP1 L (impH (forallH v g) (forallH v A)) g) in *.
        set (A7 := MP L _ _ _ _ A6 A3) in *.
        set (A8 := MP L _ _ _ _ A5 A7) in *.
        set (A9 := MP L _ _ _ _ A8 A4) in *.
        exists (x ++ nil).
        exists A9.
        clear A9 A8 A7 A6 A5 A4 A3 A2 A1.
        simpl in |- *.
        intros g0 H3; apply H0.
        induction (in_app_or _ _ _ H3).
        -- auto.
        -- elim H4.
        *
          set (A1 := GEN L _ _ _ n H) in *.
          set (A2 := IMP1 L (forallH v A) g) in *.
          set (A3 := MP L _ _ _ _ A2 A1) in *.
          exists (Axm).
          exists A3.
          firstorder.
      + firstorder.
    - apply EasyCase, (IMP1 L).
    - apply EasyCase, (IMP2 L).
    - apply EasyCase, (CP L).
    - apply EasyCase, (FA1 L).
    - apply EasyCase, (FA2 L); assumption.
    - apply EasyCase, (FA3 L).
    - apply EasyCase, (EQ1 L).
    - apply EasyCase, (EQ2 L).
    - apply EasyCase, (EQ3 L).
    - apply EasyCase, (EQ4 L).
    - apply EasyCase, (EQ5 L).
  }
  destruct  H0 as [x [x0 H0]]; exists x, x0; firstorder.
Qed.

End Deduction_Theorem.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Structure.Terminal.

Generalizable All Variables.

Reserved Infix "×" (at level 41, right associativity).

Section Cartesian.

Context `{C : Category}.

Class Cartesian := {
  product_obj : obj → obj → obj
    where "x × y" := (product_obj x y);

  fork {x y z} (f : x ~> y) (g : x ~> z) : x ~> y × z;

  exl {x y} : x × y ~> x;
  exr {x y} : x × y ~> y;

  fork_respects : ∀ x y z,
    Proper (equiv ==> equiv ==> equiv) (@fork x y z);

  ump_products {x y z} (f : x ~> y) (g : x ~> z) (h : x ~> y × z) :
    h ≈ fork f g ↔ (exl ∘ h ≈ f) * (exr ∘ h ≈ g)
}.
#[export] Existing Instance fork_respects.

Infix "×" := product_obj (at level 41, right associativity) : object_scope.
Infix "△" := fork (at level 28) : morphism_scope.

Context `{@Cartesian}.

Definition first  {x y z : C} (f : x ~> y) : x × z ~> y × z :=
  (f ∘ exl) △ exr.

Definition second  {x y z : C} (f : x ~> y) : z × x ~> z × y :=
  exl △ (f ∘ exr).

Definition split  {x y z w : C} (f : x ~> y) (g : z ~> w) :
  x × z ~> y × w :=
  (f ∘ exl) △ (g ∘ exr).

#[export] Program Instance first_respects {a b c : C} :
  Proper (equiv ==> equiv) (@first a b c).
Next Obligation.
  proper.
  unfold first.
  rewrites.
  reflexivity.
Qed.

#[export] Program Instance second_respects {a b c : C} :
  Proper (equiv ==> equiv) (@second a b c).
Next Obligation.
  proper.
  unfold second.
  rewrites.
  reflexivity.
Qed.

#[export] Program Instance split_respects {a b c d : C} :
  Proper (equiv ==> equiv ==> equiv) (@split a b c d).
Next Obligation.
  proper.
  unfold split.
  rewrites.
  reflexivity.
Qed.

Definition swap {x y : C} : x × y ~> y × x := exr △ exl.

Corollary exl_fork {x z w : C} (f : x ~> z) (g : x ~> w) :
  exl ∘ f △ g ≈ f.
Proof.
  intros.
  now apply (ump_products f g (f △ g)).
Qed.

#[local] Hint Rewrite @exl_fork : categories.

Corollary exr_fork {x z w : C} (f : x ~> z) (g : x ~> w) :
  exr ∘ f △ g ≈ g.
Proof.
  intros.
  now apply (ump_products f g (f △ g)).
Qed.

#[local] Hint Rewrite @exr_fork : categories.

Corollary exl_fork_assoc {x y z w} (f : x ~> z) (g : z ~> w) (h : x ~> y) :
  g ∘ exl ∘ (f △ h) ≈ g ∘ f.
Proof.
  rewrite <- comp_assoc.
  apply compose_respects; try reflexivity.
  apply exl_fork.
Qed.

Corollary exr_fork_assoc {x y z w} (f : x ~> z) (g : y ~> w) (h : x ~> y) :
  g ∘ exr ∘ (f △ h) ≈ g ∘ h.
Proof.
  rewrite <- comp_assoc.
  apply compose_respects; try reflexivity.
  apply exr_fork.
Qed.

Corollary exl_fork_comp {x y z w} (f : x ~> y) (g : x ~> z) (h : w ~> x) :
  exl ∘ ((f △ g) ∘ h) ≈ f ∘ h.
Proof.
  rewrite comp_assoc.
  rewrite exl_fork.
  reflexivity.
Qed.

Corollary exr_fork_comp {x y z w} (f : x ~> y) (g : x ~> z) (h : w ~> x) :
  exr ∘ ((f △ g) ∘ h) ≈ g ∘ h.
Proof.
  rewrite comp_assoc.
  rewrite exr_fork.
  reflexivity.
Qed.

Corollary fork_exl_exr {x y : C} :
  exl △ exr ≈ @id C (x × y).
Proof.
  intros.
  symmetry.
  apply ump_products; split; cat.
Qed.

#[local] Hint Rewrite @fork_exl_exr : categories.

Corollary fork_inv {x y z : C} (f h : x ~> y) (g i : x ~> z) :
  f △ g ≈ h △ i ↔ f ≈ h ∧ g ≈ i.
Proof.
  pose proof (ump_products h i (f △ g)) as HA;
  simplify; intuition.
  - now rewrite exl_fork in a.
  - now rewrite exr_fork in b.
  - apply X0; cat.
Qed.

Corollary fork_comp {x y z w : C}
          (f : y ~> z) (h : y ~> w) (g : x ~> y) :
  (f ∘ g) △ (h ∘ g) ≈ f △ h ∘ g.
Proof.
  intros.
  symmetry.
  apply ump_products; split;
  rewrite !comp_assoc; cat.
Qed.

Ltac unfork :=
  unfold swap, split, first, second; simpl;
  repeat (rewrite <- !fork_comp; cat;
          rewrite <- !comp_assoc; cat).

#[local] Obligation Tactic := cat_simpl; unfork.

Definition swap_invol {x y : C} :
  swap ∘ swap ≈ @id C (x × y).
Proof. unfork. Qed.

#[local] Hint Rewrite @swap_invol : categories.

Definition swap_inj_l {x y z : C} (f g : x ~> y × z) :
  swap ∘ f ≈ swap ∘ g → f ≈ g.
Proof.
  intro HA.
  rewrite <- id_left.
  rewrite <- (id_left g).
  rewrite <- swap_invol.
  rewrite <- !comp_assoc.
  now apply compose_respects.
Qed.

Definition swap_inj_r {x y z : C} (f g : x × y ~> z) :
  f ∘ swap ≈ g ∘ swap → f ≈ g.
Proof.
  intro HA.
  rewrite <- id_right.
  rewrite <- (id_right g).
  rewrite <- swap_invol.
  rewrite !comp_assoc.
  now apply compose_respects.
Qed.

Theorem first_id {x y : C} :
  first (id[x]) ≈ id[x × y].
Proof. unfold first; cat. Qed.

#[local] Hint Rewrite @first_id : categories.

Theorem first_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
  first (z:=w) (f ∘ g) ≈ first f ∘ first g.
Proof. unfork. Qed.

Theorem first_fork {x y z w : C} (f : x ~> y) (g : x ~> z) (h : y ~> w) :
  first h ∘ f △ g ≈ (h ∘ f) △ g.
Proof. unfork. Qed.

Theorem second_id {x y : C} :
  second (id[y]) ≈ id[x × y].
Proof. unfold second; cat. Qed.

#[local] Hint Rewrite @second_id : categories.

Theorem second_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
  second (z:=w) (f ∘ g) ≈ second f ∘ second g.
Proof. unfork. Qed.

Theorem second_fork {x y z w : C} (f : x ~> y) (g : x ~> z) (h : z ~> w) :
  second h ∘ f △ g ≈ f △ (h ∘ g).
Proof. unfork. Qed.

Corollary exl_first {x y z : C} (f : x ~> y) :
  @exl _ y z ∘ first f ≈ f ∘ exl.
Proof. unfold first; cat. Qed.

#[local] Hint Rewrite @exl_first : categories.

Corollary exr_first {x y z : C} (f : x ~> y) :
  @exr _ y z ∘ first f ≈ exr.
Proof. unfold first; cat. Qed.

#[local] Hint Rewrite @exr_first : categories.

Corollary exl_second {x y z : C} (f : x ~> y) :
  @exl _ z y ∘ second f ≈ exl.
Proof. unfold second; cat. Qed.

#[local] Hint Rewrite @exl_second : categories.

Corollary exr_second {x y z : C} (f : x ~> y) :
  @exr _ z y ∘ second f ≈ f ∘ exr.
Proof. unfold second; cat. Qed.

#[local] Hint Rewrite @exr_second : categories.

Theorem swap_first {x y z : C} (f : x ~> y) :
  swap ∘ first (z:=z) f ≈ second f ∘ swap.
Proof. unfork. Qed.

Theorem swap_second {x y z : C} (f : x ~> y) :
  swap ∘ second f ≈ first (z:=z) f ∘ swap.
Proof. unfork. Qed.

Theorem first_second {x y z w : C} (f : x ~> y) (g : z ~> w) :
  first f ∘ second g ≈ second g ∘ first f.
Proof. unfork. Qed.

Theorem swap_fork {x y z : C} (f : x ~> y) (g : x ~> z) :
  swap ∘ f △ g ≈ g △ f.
Proof. unfork. Qed.

Theorem split_id {x y : C} :
  split (id[x]) (id[y]) ≈ id[x × y].
Proof. unfork; cat. Qed.

#[local] Hint Rewrite @split_id : categories.

Theorem split_comp {x y z w v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) (i : w ~> v) :
  split f g ∘ split h i ≈ split (f ∘ h) (g ∘ i).
Proof. unfork. Qed.

Theorem split_first {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  split f g ∘ first h ≈ split (f ∘ h) g.
Proof. unfork. Qed.

Theorem first_split {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  first f ∘ split h g ≈ split (f ∘ h) g.
Proof. unfork. Qed.

Theorem split_second {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  split g f ∘ second h ≈ split g (f ∘ h).
Proof. unfork. Qed.

Theorem second_split {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  second f ∘ split g h ≈ split g (f ∘ h).
Proof. unfork. Qed.

Theorem exl_split {x y z w : C} (f : x ~> y) (g : z ~> w):
  exl ∘ split f g ≈ f ∘ exl.
Proof. unfork; cat. Qed.

Theorem exr_split {x y z w : C} (f : x ~> y) (g : z ~> w):
  exr ∘ split f g ≈ g ∘ exr.
Proof. unfork; cat. Qed.

Theorem split_fork {x y z w v : C}
          (f : y ~> w) (h : z ~> v) (g : x ~> y) (i : x ~> z):
  split f h ∘ g △ i ≈ (f ∘ g) △ (h ∘ i).
Proof. unfork. Qed.

#[export] Program Instance prod_respects_iso :
  Proper (Isomorphism ==> Isomorphism ==> Isomorphism) product_obj.
Next Obligation.
  proper.
  construct.
  - exact (split (to X) (to X0)).
  - exact (split (from X) (from X0)).
  - now rewrite split_comp, !iso_to_from, split_id.
  - now rewrite split_comp, !iso_from_to, split_id.
Defined.

Context `{@Terminal C}.

#[export] Program Instance prod_one_l  {x : C} :
  1 × x ≅ x := {
  to   := exr;
  from := one △ id
}.
Next Obligation.
  rewrite <- fork_comp.
  rewrite <- fork_exl_exr.
  apply fork_respects; cat.
  apply one_unique.
Qed.

#[local] Hint Rewrite @prod_one_l : isos.

#[export] Program Instance prod_one_r  {x : C} :
  x × 1 ≅ x := {
  to   := exl;
  from := id △ one
}.
Next Obligation.
  rewrite <- fork_comp; cat.
  rewrite <- fork_exl_exr.
  apply fork_respects; cat.
  apply one_unique.
Qed.

#[local] Hint Rewrite @prod_one_r : isos.

#[export] Program Instance prod_comm  {x y : C} :
  x × y ≅ y × x := {
  to   := swap;
  from := swap
}.

#[export] Program Instance prod_assoc  {x y z : C} :
  (x × y) × z ≅ x × (y × z) := {
  to   := (exl ∘ exl) △ ((exr ∘ exl) △ exr);
  from := (exl △ (exl ∘ exr)) △ (exr ∘ exr)
}.
Next Obligation. rewrite fork_comp; cat. Qed.
Next Obligation. rewrite fork_comp; cat. Qed.

Definition toggle {x y : C} : (x × y) × (x × y) ~> (x × x) × (y × y) :=
  split exl exl △ split exr exr.

(* Theorem toggle_fork_fork : *)
(*   toggle ∘ (f △ g) △ (h △ i) ≈  *)

End Cartesian.

Infix "×" := (@product_obj _ _) (at level 41, right associativity) : object_scope.
Notation "x ×[ C ] y" := (@product_obj C _ x y)
  (at level 41, right associativity, only parsing) : object_scope.
Infix "△" := (@fork _ _ _ _ _) (at level 28) : morphism_scope.

#[export] Hint Rewrite @exl_fork : categories.
#[export] Hint Rewrite @exr_fork : categories.
#[export] Hint Rewrite @fork_exl_exr : categories.
#[export] Hint Rewrite @swap_invol : categories.
#[export] Hint Rewrite @prod_one_l : isos.
#[export] Hint Rewrite @prod_one_r : isos.

Ltac unfork :=
  unfold swap, split, first, second; simpl;
  repeat (rewrite <- !fork_comp; cat;
          rewrite <- !comp_assoc; cat).