(** * A10 *)

(* Do not modify these imports. *)
Require Import List Arith Bool.
Require String.
Import ListNotations.

Module Author.
Open Scope string_scope.
Definition author := "Andrew Wang".
Definition netid := "ayw24".
Definition hours_worked := 0.
Definition collaborators := "Jack Ding".
(* The latter should be the names of other students with whom
     you discussed ideas on this assignment, following the collaboration
     policy stated in the handout. *)
End Author.

(********************************************************************

               AAA                 1111111        000000000
              A:::A               1::::::1      00:::::::::00
             A:::::A             1:::::::1    00:::::::::::::00
            A:::::::A            111:::::1   0:::::::000:::::::0
           A:::::::::A              1::::1   0::::::0   0::::::0
          A:::::A:::::A             1::::1   0:::::0     0:::::0
         A:::::A A:::::A            1::::1   0:::::0     0:::::0
        A:::::A   A:::::A           1::::l   0:::::0 000 0:::::0
       A:::::A     A:::::A          1::::l   0:::::0 000 0:::::0
      A:::::AAAAAAAAA:::::A         1::::l   0:::::0     0:::::0
     A:::::::::::::::::::::A        1::::l   0:::::0     0:::::0
    A:::::AAAAAAAAAAAAA:::::A       1::::l   0::::::0   0::::::0
   A:::::A             A:::::A   111::::::1110:::::::000:::::::0
  A:::::A               A:::::A  1::::::::::1 00:::::::::::::00
 A:::::A                 A:::::A 1::::::::::1   00:::::::::00
AAAAAAA                   AAAAAAA111111111111     000000000

*********************************************************************)

(**

Here is an OCaml interface for queues:
<<
(* ['a t] is a queue containing values of type ['a]. *)
type 'a t

(* [empty] is the empty queue *)
val empty : 'a t

(* [is_empty q] is whether [q] is empty *)
val is_empty : 'a t -> bool

(* [front q] is [Some x], where [x] the front element of [q],
 * or [None] if [q] is empty. *)
val front : 'a t -> 'a option

(* [enq x q] is the queue that is the same as [q], but with [x]
 * enqueued (i.e., inserted) at the end. *)
val enq : 'a -> 'a t -> 'a t

(* [deq x q] is the queue that is the same as [q], but with its
 * front element dequeued (i.e., removed).  If [q] is empty,
 * [deq q] is also empty. *)
val deq : 'a t -> 'a t
>>

Note that the specification for [deq] differs from what we have given
before:  the [deq] of an empty list is the empty list; there are no
options or exceptions involved.

Here is an equational specification for that interface:
<<
(1) is_empty empty      = true
(2) is_empty (enq _ _ ) = false
(3) front empty         = None
(4) front (enq x q)     = Some x         if is_empty q = true
(5) front (enq _ q)     = front q        if is_empty q = false
(6) deq empty           = empty
(7) deq (enq _ q)       = empty          if is_empty q = true
(8) deq (enq x q)       = enq x (deq q)  if is_empty q = false
>>

Your task in the next two parts of this file is to implement the Coq equivalent
of that interface and prove that your implementation satisfies the equational
specification.  Actually, you will do this twice, with two different
representation types:

- _simple queues_, which represent a queue as a singly-linked list
  and have worst-case linear time performance.

- _two-list queues_, which represent a queue with two singly-linked
  lists, and have amortized constant time performance.

You will find both of those implementations in section 5.9 of the textbook.

*)

(********************************************************************)
(** ** Part 1: Simple Queues *)
(********************************************************************)

Module SimpleQueue.

(** Your first task is to implement and verify simple queues.
    To get you started, we provide the following definitions for
    the representation type of a simple queue, and for the empty
    simple queue. *)

(** [queue A] is the type that represents a queue as a
    singly-linked list.  The list [[x1; x2; ...; xn]] represents
    the queue with [x1] at its front, then [x2], ..., and finally
    [xn] at its end.  The list [[]] represents the empty queue. *)
Definition queue (A : Type) := list A.

Definition empty {A : Type} : queue A := [].

(**
*** Implementation of simple queues.
Define [is_empty], [front], [enq], and [deq]. We have provided some starter code
below that type checks, but it defines those operations in trivial and incorrect
ways. _Hint:_ this isn't meant to be tricky; you just need to translate the code
you would naturally write in OCaml into Coq syntax.
*)

Definition is_empty {A : Type} (q : queue A) : bool :=
  match q with
  | nil => true
  | cons _ _ => false
  end.

Definition front {A : Type} (q : queue A) : option A :=
  match q with
  | nil => None
  | x :: _ => Some x
  end.

Fixpoint enq {A : Type} (x : A) (q : queue A) : queue A :=
  match q with
  | nil => x::q
  | cons h t => h::enq x t
  end.

Definition deq {A : Type} (q : queue A) : queue A :=
  match q with
  | nil => nil
  | cons h t => t
  end.

(**
*** Verification of simple queues.
Prove that the equations in the queue specification hold. We have written
them for you, below, but instead of a proof we have written [Admitted].  That
tells Coq to accept the theorem as true (hence it will compile) even though
there is no proof.  You need to replace [Admitted] with [Proof. ...  Qed.]
_Hint:_ the only tactics you need are [intros], [trivial], [discriminate],
and [destruct].  You might also find [simpl] to be useful in making a goal
easier to read.  If [simpl] won't simplify a computation involving a queue,
instead try [destruct] on that queue.  Always pay attention to the hypotheses
to see whether one might be false, in which case you should concentrate on it
rather than the goal.
*)

Theorem eqn1 : forall (A : Type),
  is_empty (@empty A) = true.
Proof.
  trivial.
Qed.

Theorem eqn2 : forall (A : Type) (x : A) (q : queue A),
  is_empty (enq x q) = false.
Proof.
  intros A x q.
  destruct q.
    all: trivial.
Qed.

Theorem eqn3 : forall (A : Type),
  front (@empty A) = None.
Proof.
  trivial.
Qed.

Theorem eqn4 : forall (A : Type) (x : A) (q : queue A),
  is_empty q = true -> front (enq x q) = Some x.
Proof.
  intros A x q empty_is_true.
  destruct q.
    trivial.
    discriminate.
Qed.

Theorem eqn5 : forall (A : Type) (x : A) (q : queue A),
  is_empty q = false -> front (enq x q) = front q.
Proof.
  intros A x q empty_is_false.
  destruct q.
    discriminate.
    trivial.
Qed.

Theorem eqn6 : forall (A : Type),
  deq (@empty A) = (@empty A).
Proof.
  trivial.
Qed.

Theorem eqn7 : forall (A : Type) (x : A) (q : queue A),
  is_empty q = true -> deq (enq x q) = empty.
Proof.
  intros A x q empty_is_true.
  destruct q.
    simpl. trivial.
    simpl. discriminate.
Qed.

Theorem eqn8 : forall (A : Type) (x : A) (q : queue A),
  is_empty q = false -> deq (enq x q) = enq x (deq q).
Proof.
  intros A x q empty_is_false.
  destruct q.
    simpl. discriminate.
    simpl. trivial.
Qed.

End SimpleQueue.

(********************************************************************)
(** ** Part 2: Two-list Queues *)
(********************************************************************)

Module TwoListQueue.

(** Your second task is to implement and verify two-list queues.
    To get you started, we provide the following definitions for
    the representation type of a two-list queue, and for the empty
    two-list queue. *)

(** [queue A] is the type that represents a queue as a pair of two
    singly-linked lists.  The pair [(f,b)] represents the same
    queue as does the simple queue [f ++ rev b].  The list [f] is
    the front of the queue, and the list [b] is the back of the
    queue stored in reversed order.

    _Representation invariant:_  if [f] is [nil] then [b] is [nil].

    The syntax [% type] in this definition tells Coq to treat the
    [*] symbol as the pair constructor rather than multiplication.
    You shouldn't need to use that syntax anywhere in your solution. *)
Definition queue (A : Type) := (list A * list A) % type.

(** [rep_ok q] holds iff [q] satisfies its RI as stated above *)
Definition rep_ok {A : Type} (q : queue A) : Prop :=
  match q with
  | (f,b) => f = [] -> b = []
  end.

Definition empty {A : Type} : queue A := ([],[]).

(**
*** Implementation of two-list queues.
Define [is_empty], [front], [enq], and [deq]. We have provided some starter code
below that type checks, but it defines those operations in trivial and incorrect
ways. You must use the efficient implementation described in the textbook.
You may not store the entire queue in the first component of the
pair and use the inefficient implementation on that component.
_Hint:_ this isn't meant to be tricky; you just need to translate the code
you would naturally write in OCaml into Coq syntax.  You will need to define
one new function as part of that.
*)

Definition is_empty {A : Type} (q : queue A) : bool :=
  match q with
  | (nil, _) => true
  | _ => false
  end.

Definition front {A : Type} (q : queue A) : option A :=
  match q with
  | (nil, _) => None
  | (cons x _, _) => Some x
  end.

Definition norm {A : Type} (q: queue A) : queue A :=
  match q with
  | (nil, b) => (rev b, nil)
  | q => q
  end.

Definition enq {A : Type} (x : A) (q : queue A) : queue A :=
  match q with
  | (nil, _) => norm (nil, x::[])
  | (f, t) => norm (f, x::t)
  end.

Definition deq {A : Type} (q : queue A) : queue A :=
  match q with
  | (nil, _) => (nil, [])
  | (cons h t, b) => norm (t, b)
  end.

(** This "unit test" checks to make sure your implementation correctly
    uses both the front and back list on a simple example.  You should
    be able to prove it just by changing [Admitted.] to [trivial. Qed.]
    If not, you probably have coded up the [enq] function or a helper
    incorrectly.  In that case, fix it before moving on to the theorems
    below. *)
Example test_two_lists : enq 1 (enq 0 empty) = ([0], [1]).
Proof. trivial. Qed.

(**
*** Verification of two-list queues.
Next you need to prove that the equations in the queue specification hold.
The statements of those equations below now include as a precondition
that the RI holds of any input queues.
_Hint:_ in addition to the tactics you used for simple queues, you will
also find [apply...in], [rewrite], and [assumption] to be helpful.
We suggest factoring out helper lemmas whenever you discover that
a hypothesis is difficult to work with in its current form.
*)

Theorem eqn1 : forall (A : Type),
  is_empty (@empty A) = true.
Proof.
  trivial.
Qed.

Theorem eqn2 : forall (A : Type) (x : A) (q : queue A),
  rep_ok q -> is_empty (enq x q) = false.
Proof.
  intros A x q evRep.
  destruct q as [front back].
  destruct front.
    trivial.
    destruct back.
      all: trivial.
Qed.

Theorem eqn3 : forall (A : Type),
  front (@empty A) = None.
Proof.
  trivial.
Qed.

Theorem eqn4 : forall (A : Type) (x : A) (q : queue A),
  rep_ok q -> is_empty q = true -> front (enq x q) = Some x.
Proof.
  intros A x q evRep empty_eq_true.
  destruct q as [f b].
    destruct f.
    trivial.
    discriminate.
Qed.

Theorem eqn5 : forall (A : Type) (x : A) (q : queue A),
  rep_ok q -> is_empty q = false -> front (enq x q) = front q.
Proof.
  intros A x q evRep empty_eq_true.
  destruct q as [f b].
    simpl.
    destruct f.
      discriminate.
      trivial.
Qed.

Theorem eqn6 : forall (A : Type),
  deq (@empty A) = @empty A.
Proof.
  trivial.
Qed.

Theorem eqn7_helper : forall (A : Type) (x : A) (q: queue A),
rep_ok q -> is_empty q = true -> q = ([], []).
Proof.
  intros.
  destruct q as [f back].
    simpl.
    destruct f.
    simpl.
      rewrite H.
      trivial.
      trivial.
      discriminate.
Qed.

(** Look into how to break this one up *)
Theorem eqn7 : forall (A : Type) (x : A) (q : queue A),
  rep_ok q -> is_empty q = true -> deq (enq x q) = empty.
Proof.
  intros A x q evRep empty_eq_true.
  destruct q as [f b].
    destruct f.
      destruct b.
        simpl.
        trivial.
        trivial.
        discriminate.
Qed.

(**
It turns out that two-list queues actually do not satisfy [eqn8]! To show that,
find a counterexample:  values for [x] and [q] that cause [eqn8] to be invalid.
Plug in your values for [x] and [q] below, then prove the three theorems
[counter1], [counter2], and [counter3].  _Hint_: if you choose your values well,
the proofs should be short and easy, requiring only [discriminate] or [trivial].
*)

Module CounterEx.

Definition x : nat := 0.
(* change [0] to a value of your choice *)
Definition q : (list nat * list nat) := ([x], [x]).
(* change [empty] to a value of your choice *)

Theorem counter1 : rep_ok q.
Proof.
  discriminate.
Qed.

Theorem counter2 : is_empty q = false.
Proof.
  trivial.
Qed.

Theorem counter3 : deq (enq x q) <> enq x (deq q).
Proof.
  discriminate.
Qed.

End CounterEx.

(**
Two-list queues do satisfy a relaxed version of [eqn8], though,
where instead of requiring [deq (enq x q)] and [enq x (deq q)]
to be _equal_, we only require them to be _equivalent_ after being
converted to simple queues.  The following definition implements
that idea of equivalence:
*)

Definition equiv {A:Type} (q1 q2 : queue A) : Prop :=
  match (q1, q2) with
  | ((f1,b1),(f2,b2)) => f1 ++ rev b1 = f2 ++ rev b2
  end.

(**
Now prove that the following relaxed form of [eqn8] holds.  _Hint:_
this is probably the hardest proof in the assignment.  Don't hesitate
to manage the complexity of the proof by stating and proving helper lemmas.
We found uses for some additional tactics in this proof:
[contradiction], [destruct (e)], and [unfold].  We also found
a theorem involving [++] from the [List] library to be helpful.
*)

(* Lemma eqn8_equiv' : forall (A : Type) (x : A) (q : queue A),
rep_ok q -> is_empty q = false -> (deq (enq x q)) *)

Lemma front_no_back : forall (A : Type) (x : A) (f : list A),
  f <> [] -> equiv (deq (enq x (f, []))) (enq x (deq (f, []))).
Proof.
  intros A x f f_not_empty.
  destruct f.
    contradiction.
    simpl.
    destruct f.
      simpl.
      unfold equiv. trivial. simpl.
      unfold equiv. simpl. trivial.
Qed.

Lemma elt_cons_front : forall (A : Type) (x : A) (f b: list A),
  f <> [] -> is_empty (f, b) = false.
Proof.
  intros.
  destruct f.
  contradiction.
  trivial.
Qed.

Lemma enq_nonempty : forall (A : Type) (x : A) (f b : list A),
  rep_ok (f,b) -> is_empty (f,b) = false -> enq x (f,b) = (f, x::b).
Proof.
  intros A x f b rep_ok is_not_empty.
  destruct f.
    destruct b.
    discriminate.
    simpl.
      discriminate.
      simpl.
      trivial.
Qed.

Lemma deq_nonempty : forall (A : Type) (x : A) (f b : list A),
  rep_ok (f,b) -> is_empty (f,b) = false -> deq (x::f,b) = (f, b).
Proof.
  intros.
  destruct f.
    discriminate.
    trivial.
Qed.

Lemma one_front_back : forall (A : Type) (x a a0 : A) (b : list A),
  deq (enq x ([a], a0 :: b)) = (rev (x :: a0 :: b), []).
Proof.
  trivial.
Qed.

Lemma some_deq : forall (A : Type) (x a a0 : A) (b : list A),
  deq ([a], a0 :: b) = (rev (a0 :: b), []).
Proof.
  trivial.
Qed.

Theorem eqn8_equiv : forall (A : Type) (x : A) (q : queue A),
  rep_ok q -> is_empty q = false ->
  equiv (deq (enq x q)) (enq x (deq q)).
Proof.
  intros A x q rep_good is_not_empty.
  destruct q as [front back].
    destruct front.
      destruct back.
        discriminate. discriminate.
        destruct back.
          destruct front0.
            unfold equiv.
            simpl. trivial.
            unfold equiv.
            simpl. trivial.
            destruct front0.
              rewrite one_front_back.
              rewrite some_deq.
              unfold equiv.
              simpl.
              destruct (rev back).
                simpl. trivial.
                simpl.
                rewrite app_nil_r.
                trivial.
                assumption.
                simpl.
                unfold equiv.
                trivial.
Qed.

(**
Finally, verify that [empty] satisfies the RI, and that [enq] and [deq] both
preserve the RI.
*)

Theorem rep_ok_empty : forall (A : Type),
  rep_ok (@empty A).
Proof.
  intros A.
  intros evRep.
  trivial.
Qed.

Theorem rep_ok_enq : forall (A : Type) (q : queue A),
  rep_ok q -> forall (x : A), rep_ok (enq x q).
Proof.
  intros A q rep_good.
  intros x.
  destruct q as [front back].
    destruct front.
    all: discriminate.
Qed.

Theorem rep_ok_deq: forall (A : Type) (q : queue A),
  rep_ok q -> rep_ok (deq q).
Proof.
  intros.
  destruct q.
    destruct l.
      simpl. trivial.
      destruct l.
        trivial.
        simpl.
        destruct (rev l0).
        trivial.
        discriminate.
        discriminate.
  Qed.

End TwoListQueue.

(********************************************************************)
(** ** Part 3: Logic, and Programs as Proofs *)
(********************************************************************)

Module Logic.

(**
Change each of the following conjectures into a definition.  Your
definition should provide a Coq program that is the proof of the
conjecture.  For example, given
<<
Conjecture logic0 : forall P : Prop,
  P -> P.
>>
You would transform it into
<<
Definition logic0 : forall P : Prop,
  P -> P
:=
  fun (P : Prop) (p : P) => p.
>>
Please note that if you use tactics to find the programs
you will negatively impact your ability to solve similar problems
on the final exam.
*)

Definition logic1 : forall P Q R S T: Prop,
  ((P /\ Q) /\ R) -> (S /\ T) -> (Q /\ S)
:= fun (P Q R S T: Prop) (pq_and_r: ((P /\ Q) /\ R)) (s_and_t: (S /\ T)) =>
  match (pq_and_r, s_and_t) with
  | (conj (conj p q) r, conj s t) => conj q s
  end.

Definition logic2 : forall P Q R S : Prop,
  (P -> Q) -> (R -> S) -> (P \/ R) -> (Q \/ S)
:= fun (P Q R S: Prop) (p_imp_q: P -> Q) (r_imp_s: R -> S) (p_or_r: P \/ R) =>
  match p_or_r with
  | or_introl p => or_introl (p_imp_q p)
  | or_intror r => or_intror (r_imp_s r)
  end.

Definition logic3 : forall P Q : Prop,
  (P -> Q) -> (((P /\ Q) -> P) /\ (P -> (P /\ Q)))
:= fun (P Q: Prop) (p_imp_q: P -> Q) =>
  conj (fun (p_and_q: P /\ Q) =>  (match p_and_q with
                                    | conj p q => p
                                  end ))
       (fun (p: P) => conj p (p_imp_q p)).

Definition logic4 : forall P Q : Prop,
  (P -> Q) -> (~~P -> ~~Q)
:= fun (P Q : Prop) (p_imp_q: P -> Q)
      (double_neg_p: (P -> False) -> False) (neg_q: Q -> False) =>
    double_neg_p (fun (p: P) => neg_q (p_imp_q p)).

End Logic.

(********************************************************************)
(** ** Part 4: Induction *)
(********************************************************************)

Module Induction.

(** For the proofs in this part of the assignment, in addition
    to the tactics already used, we found these to be useful:
    [induction] and [ring]. *)

(**
Here is an OCaml function:
<<
let rec sumsq_to n =
  if n = 0 then 0
  else n*n + sumsq_to (n-1)
>>

Prove that
<<
  sumsq_to n  =  n * (n+1) * (2*n + 1) / 6
>>
by completing the following code.
*)

(** [sumsq_to n] is [0*0 + 1*1 + ... + n*n]. *)
Fixpoint sumsq_to (n:nat) : nat :=
  match n with
  | 0 => n
  | S k => n * n + (sumsq_to k)
  end.

Lemma sumsq_helper : forall n : nat,
  6 * sumsq_to (S n) = 6 * (S n) * (S n) + 6 * sumsq_to n.
Proof.
  intros n. simpl. ring.
Qed.

Theorem sumsq : forall n,
  6 * sumsq_to n = n * (n+1) * (2*n+1).
Proof.
  intros n.
  induction n as [ | k IH].
    - trivial.
    - rewrite -> sumsq_helper.
      rewrite -> IH.
      ring.
Qed.

(**
Here is a "backwards" definition of lists, which is why we spell
all the names backwards.  Unlike OCaml lists, in which as you
pattern match you encounter the first element of the list,
then the second, etc., with these lists, you encounter
the last element of the list, then the next-to-last, etc.
You may not change this definition.
*)

Inductive tsil (A : Type) : Type :=
  | lin : tsil A
  | snoc : tsil A -> A -> tsil A.

(** Don't worry about understanding these commands.  For those who
    are curious:  they make it possible to omit the [A] argument
    when writing constructors.  E.g., to write [lin] instead
    of [lin A]. *)
Arguments lin {A}.
Arguments snoc {A} xs x.

(**
For example, the list whose first element is [1], second is [2],
and third is [3] would be written
<<
snoc (snoc (snoc lin 1) 2) 3.
>>
*)

(** [length lst] is the number of elements in [lst].
    You may not change this definition. *)
Fixpoint length {A : Type} (lst : tsil A) : nat :=
  match lst with
  | lin => 0
  | snoc xs _ => 1 + length xs
  end.

(** [app lst1 lst2] contains all the elements of [lst1]
    followed by all the elements of [lst2].  "app" is
    short for "append". You may not change this definition. *)
Fixpoint app {A : Type} (lst1 lst2: tsil A) : tsil A :=
  match lst2 with
  | lin => lst1
  | snoc xs x => snoc (app lst1 xs) x
  end.

(** Prove the next two theorems.  You will need to use induction.
    Think carefully about which list to induct on, based on how
    [tsil] is defined. *)

Theorem app_assoc : forall (A : Type) (lst1 lst2 lst3 : tsil A),
  app lst1 (app lst2 lst3) = app (app lst1 lst2) lst3.
Proof.
  intros A lst1 lst2 lst3.
  induction lst3 as [ | h IH t].
    - simpl. trivial.
    - simpl. rewrite <- IH. trivial.
Qed.

Theorem app_length : forall (A : Type) (lst1 lst2 : tsil A),
  length (app lst1 lst2) = length lst1 + length lst2.
Proof.
  intros A lst1 lst2.
  induction lst2 as [ | h IH t].
    - simpl. trivial.
    - simpl. rewrite -> IH. trivial.
Qed.

End Induction.

(********************************************************************)
(** THE END *)
(********************************************************************)


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.Canonical_Kripke.
Require Import Logic.GeneralLogic.Complete.Complete_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimumLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.
Require Logic.PropositionalLogic.DeepEmbedded.ProofTheories.
Require Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

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

Section Complete.

Context {Sigma: PropositionalLanguage.PropositionalVariables}
        {CV: Countable PropositionalLanguage.Var}.

Existing Instances PropositionalLanguage.L
                   PropositionalLanguage.minL
                   PropositionalLanguage.andpL
                   PropositionalLanguage.orpL
                   PropositionalLanguage.falsepL
                   PropositionalLanguage.negpL
                   PropositionalLanguage.negpDef
                   PropositionalLanguage.iffpL
                   PropositionalLanguage.iffpDef
                   PropositionalLanguage.truepL
                   PropositionalLanguage.truepDef
.

Existing Instances KripkeSemantics.MD
                   KripkeSemantics.kMD
                   KripkeSemantics.R
                   KripkeSemantics.SM
                   KripkeSemantics.kminSM
                   KripkeSemantics.andpSM
                   KripkeSemantics.orpSM
                   KripkeSemantics.falsepSM
                   KripkeSemantics.negpSM.

Section General_Completeness.

  Context {GammaP: Provable PropositionalLanguage.L}
          {GammaD: Derivable PropositionalLanguage.L}.

Definition cP : context -> Prop := Intersection _ (Intersection _ derivable_closed orp_witnessed) consistent.

Lemma AL_DC: at_least derivable_closed cP.
Proof. solve_at_least. Qed.

Lemma AL_OW: at_least orp_witnessed cP.
Proof. solve_at_least. Qed.

Lemma AL_CONSI: at_least consistent cP.
Proof. solve_at_least. Qed.

Context {GammaPD: ProvableDerivable _ GammaP GammaD}
        {bSC: BasicSequentCalculus _ GammaD}
        {fwSC: FiniteWitnessedSequentCalculus _ GammaD}
        {minSC: MinimumSequentCalculus _ GammaD}
        {andpSC: AndSequentCalculus _ GammaD}
        {orpSC: OrSequentCalculus _ GammaD}
        {falsepSC: FalseSequentCalculus _ GammaD}
        {GammaDP: DerivableProvable _ GammaP GammaD}
        {minAX: MinimumAxiomatization _ GammaP}
        {andpAX: AndAxiomatization _ GammaP}
        {orpAX: OrAxiomatization _ GammaP}
        {falsepAX: FalseAxiomatization _ GammaP}.

Lemma LIN_CD: forall x: expr, Lindenbaum_constructable (cannot_derive x) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply PropositionalLanguage.formula_countable; auto.
  + apply Lindenbaum_preserves_cannot_derive.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    - apply Lindenbaum_cannot_derive_ensures_derivable_closed.
    - apply Lindenbaum_cannot_derive_ensures_orp_witnessed.
    - apply Lindenbaum_cannot_derive_ensures_consistent.
Qed.

Definition canonical_frame: KripkeSemantics.frame :=
  KripkeSemantics.Build_frame (sig cP) (fun a b => Included _ (proj1_sig a) (proj1_sig b)).

Definition canonical_eval: PropositionalLanguage.Var -> KripkeSemantics.sem canonical_frame :=
  fun p a => proj1_sig a (PropositionalLanguage.varp p).

Definition canonical_Kmodel: @Kmodel KripkeSemantics.MD KripkeSemantics.kMD :=
  KripkeSemantics.Build_Kmodel canonical_frame canonical_eval.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Definition H_R:
  forall m n Phi Psi, rel m Phi -> rel n Psi ->
    (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).
Proof.
  intros.
  change (m = Phi) in H.
  change (n = Psi) in H0.
  subst; reflexivity.
Qed.

Lemma TRUTH:
  forall x:  expr, forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_andp cP rel AL_DC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_orp cP rel AL_DC AL_OW x1 x2 IHx1 IHx2).
  + exact (truth_lemma_impp cP rel H_R AL_DC LIN_CD x1 x2 IHx1 IHx2).
  + exact (truth_lemma_falsep cP rel AL_CONSI).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

End General_Completeness.

Section Intuitionistic_Completeness.

Existing Instances ProofTheories.IntuitionisticPropositionalLogic.GP
                   ProofTheories.IntuitionisticPropositionalLogic.GD
                   ProofTheories.IntuitionisticPropositionalLogic.GammaDP
                   ProofTheories.IntuitionisticPropositionalLogic.minAX
                   ProofTheories.IntuitionisticPropositionalLogic.andpAX
                   ProofTheories.IntuitionisticPropositionalLogic.orpAX
                   ProofTheories.IntuitionisticPropositionalLogic.falsepAX.

Existing Instances Axiomatization2SequentCalculus_GammaPD Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_andpSC Axiomatization2SequentCalculus_orpSC Axiomatization2SequentCalculus_falsepSC.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Theorem complete_intuitionistic_Kripke_all:
  strongly_complete ProofTheories.IntuitionisticPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
Qed.

End Intuitionistic_Completeness.

Section DeMorgan_Completeness.

Existing Instances ProofTheories.DeMorganPropositionalLogic.GP
                   ProofTheories.DeMorganPropositionalLogic.GD
                   ProofTheories.DeMorganPropositionalLogic.GammaDP
                   ProofTheories.DeMorganPropositionalLogic.minAX
                   ProofTheories.DeMorganPropositionalLogic.andpAX
                   ProofTheories.DeMorganPropositionalLogic.orpAX
                   ProofTheories.DeMorganPropositionalLogic.falsepAX
                   ProofTheories.DeMorganPropositionalLogic.inegpAX
                   ProofTheories.DeMorganPropositionalLogic.dmpAX.

Existing Instances IffFromDefToAX_And_Imp TrueFromDefToAX_False_Imp Axiomatization2SequentCalculus_GammaPD Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_andpSC Axiomatization2SequentCalculus_orpSC Axiomatization2SequentCalculus_falsepSC Axiomatization2SequentCalculus_inegpSC Axiomatization2SequentCalculus_iffpSC Axiomatization2SequentCalculus_truepSC.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Theorem complete_DeMorgan_Kripke_branch_join:
  strongly_complete ProofTheories.DeMorganPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder + Kmodel_BranchJoin)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; [split |]; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (DeMorgan_canonical_branch_join cP rel H_R AL_DC AL_OW AL_CONSI LIN_CD).
Qed.

End DeMorgan_Completeness.

Section GodelDummett_Completeness.

Existing Instances ProofTheories.GodelDummettPropositionalLogic.GP
                   ProofTheories.GodelDummettPropositionalLogic.GD
                   ProofTheories.GodelDummettPropositionalLogic.GammaDP
                   ProofTheories.GodelDummettPropositionalLogic.minAX
                   ProofTheories.GodelDummettPropositionalLogic.andpAX
                   ProofTheories.GodelDummettPropositionalLogic.orpAX
                   ProofTheories.GodelDummettPropositionalLogic.falsepAX
                   ProofTheories.GodelDummettPropositionalLogic.inegpAX
                   ProofTheories.GodelDummettPropositionalLogic.gdpAX
                   ProofTheories.GodelDummettPropositionalLogic.dmpAX.

Existing Instances IffFromDefToAX_And_Imp TrueFromDefToAX_False_Imp Axiomatization2SequentCalculus_GammaPD Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_andpSC Axiomatization2SequentCalculus_orpSC Axiomatization2SequentCalculus_falsepSC Axiomatization2SequentCalculus_inegpSC Axiomatization2SequentCalculus_iffpSC Axiomatization2SequentCalculus_truepSC.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Theorem complete_GodelDummett_Kripke_no_branch:
  strongly_complete ProofTheories.GodelDummettPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder + Kmodel_NoBranch)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; [split |]; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (GodelDummett_canonical_no_branch cP rel H_R AL_DC AL_OW).
Qed.

End GodelDummett_Completeness.

Section Classical_Completeness.

Import Logic.PropositionalLogic.DeepEmbedded.KripkeSemantics.

Existing Instances ProofTheories.ClassicalPropositionalLogic.GP
                   ProofTheories.ClassicalPropositionalLogic.GD
                   ProofTheories.ClassicalPropositionalLogic.GammaDP
                   ProofTheories.ClassicalPropositionalLogic.minAX
                   ProofTheories.ClassicalPropositionalLogic.andpAX
                   ProofTheories.ClassicalPropositionalLogic.orpAX
                   ProofTheories.ClassicalPropositionalLogic.falsepAX
                   ProofTheories.ClassicalPropositionalLogic.inegpAX
                   ProofTheories.ClassicalPropositionalLogic.gdpAX
                   ProofTheories.ClassicalPropositionalLogic.dmpAX
                   ProofTheories.ClassicalPropositionalLogic.cpAX.

Existing Instances IffFromDefToAX_And_Imp TrueFromDefToAX_False_Imp Axiomatization2SequentCalculus_GammaPD Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_andpSC Axiomatization2SequentCalculus_orpSC Axiomatization2SequentCalculus_falsepSC Axiomatization2SequentCalculus_inegpSC Axiomatization2SequentCalculus_iffpSC Axiomatization2SequentCalculus_truepSC Axiomatization2SequentCalculus_cpSC.

Theorem complete_Classical_Kripke_identity:
  strongly_complete ProofTheories.ClassicalPropositionalLogic.GD KripkeSemantics.SM
    (KripkeModelClass _ (Kmodel_Monotonic + Kmodel_PreOrder + Kmodel_Identity)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  constructor; [split |]; hnf.
  + intros.
    exact (denote_monotonic cP rel H_R
             (PropositionalLanguage.varp v)
             (TRUTH (PropositionalLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (classical_canonical_ident cP rel H_R AL_DC AL_OW AL_CONSI).
Qed.

End Classical_Completeness.

End Complete.


Require Export CatSem.CAT.CatFunct.
Require Export CatSem.CAT.functor_leibniz_eq.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Class SmallCat := {
  sobj: Set;
  smor: sobj -> sobj -> Set;
  sstruct:> Cat_struct smor
}.

Definition Cat_from_SmallCat (C: SmallCat) : Cat := Build_Cat
  (obj := sobj) (mor := smor) sstruct.

Coercion Cat_from_SmallCat: SmallCat >-> Cat.

Obligation Tactic := simpl; intros;
       try apply Equal_hom_refl;
       try apply CompF_oid.

Program Instance SMALLCAT_struct :
      @Cat_struct SmallCat (fun a b => FunctCat a b) := {
  mor_oid a b := EXT_Functor_oid a b;
  id a := Id a;
  comp a b c f g := CompF f g
}.

Definition SMALLCAT := Build_Cat SMALLCAT_struct.


Require Import VST.floyd.proofauto.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Export CertiGraph.graph.SpaceAdjMatGraph1.
Require Import CertiGraph.lib.List_ext.

Local Open Scope logic.

Section Spatial_UAdjMat_Model_1.
  (* Model 1 is for a heap-allocated graph,
     where the graph is malloc-ed
     by first malloc-ing a "spine" column of some size,
     and then malloc-ing a "row" into each cell
     of the spine.
   *)

Context {size : Z}.
Context {inf : Z}.

Definition graph_to_symm_mat g :=
  @graph_to_mat size g eformat.

Lemma graph_to_mat_eq:
  forall (g: AdjMatLG) i j, 0 <= i < size -> 0 <= j < size ->
    (Znth i (Znth j (graph_to_symm_mat g))) = elabel g (eformat (i,j)).
Proof.
  intros.
  symmetry. rewrite eformat_symm.
  apply elabel_Znth_graph_to_mat; lia.
Qed.

Lemma graph_to_mat_symmetric:
  forall (g: AdjMatLG) i j,
    0 <= i < size -> 0 <= j < size ->
    (Znth i (Znth j (graph_to_symm_mat g))) =
    (Znth j (Znth i (graph_to_symm_mat g))).
Proof.
  intros. repeat rewrite graph_to_mat_eq; trivial.
  f_equal. apply eformat_symm.
Qed.

Lemma graph_to_mat_inf:
  forall (g: @AdjMatGG size inf) u v,
    0 <= u < v ->
    v < size ->
    ~ evalid g (u,v) ->
    Znth v (Znth u (graph_to_symm_mat g)) =
    inf.
Proof.
  intros. unfold graph_to_symm_mat.
  rewrite <- elabel_Znth_graph_to_mat; try lia.
  rewrite eformat1.
  apply (MathAdjMatGraph.invalid_edge_weight); auto.
  simpl; lia.
Qed.

Context {size_rep': 0 < size <= Int.max_signed}.
Context {inf_rep: 0 < inf <= Int.max_signed}.

Definition edgeless_graph' := @edgeless_graph size inf inf_rep size_rep'.
Definition adde := @UAdjMatGG_adde size inf.
Definition eremove := @UAdjMatGG_eremove size inf.

Lemma edgeless_vert_rep:
  forall v,
    0 <= v < size ->
    (@vert_to_list size edgeless_graph' eformat v) =
    repeat inf (Z.to_nat size).
Proof.
  unfold vert_to_list; intros. rewrite map_map. apply list_eq_Znth.
+rewrite Zlength_map, nat_inc_list_Zlength, Zlength_repeat'; auto.
+intros. rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id in H0. 2: lia.
rewrite Znth_repeat_inrange by auto.
rewrite Znth_map, nat_inc_list_i. simpl; auto.
rewrite Z2Nat.id; lia.
rewrite nat_inc_list_Zlength.
rewrite Z2Nat.id; lia.
Qed.

Lemma edgeless_to_symm_mat:
  graph_to_symm_mat edgeless_graph' =
  repeat (repeat inf (Z.to_nat size)) (Z.to_nat size).
Proof.
  unfold graph_to_symm_mat, graph_to_mat. apply list_eq_Znth.
+rewrite Zlength_map, nat_inc_list_Zlength, Zlength_repeat'; auto.
+intros. rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id in H by lia.
rewrite Znth_repeat_inrange by lia.
rewrite Znth_map. rewrite nat_inc_list_i. apply edgeless_vert_rep; lia.
rewrite Z2Nat.id by lia; lia.
rewrite nat_inc_list_Zlength, Z2Nat.id; lia.
Qed.

End Spatial_UAdjMat_Model_1.


Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export DeclarationEvaluation.

(******************************************************************************)
(* Reflexivity, transitivity and narrowing                                    *)
(******************************************************************************)

Lemma sub_refl {Γ T} (wfT: wfTy (domainEnv Γ) T) : Sub Γ T T.
Proof. depind wfT; simpl; econstructor; eauto with wf. Qed.

Lemma narrow_lookup_etvar_ne {Γ T1 T2 Δ} :
  ∀ {X U}, X ≠ (weakenIndexty I0 (domainEnv Δ)) →
    lookup_etvar (appendEnv (etvar Γ T1) Δ) X U →
    lookup_etvar (appendEnv (etvar Γ T2) Δ) X U.
Proof.
  induction Δ; inversion 2; isimpl; try constructor; isimpl; intuition.
  - apply IHΔ; congruence.
Qed.

Definition Trans Q := ∀ Γ S T, Sub Γ S Q → Sub Γ Q T → Sub Γ S T.

Definition Narrow Q :=
  ∀ Γ Δ S T, Sub (appendEnv (etvar Γ Q) Δ) S T →
    ∀ R, Sub Γ R Q → Sub (appendEnv (etvar Γ R) Δ) S T.

Lemma trans_case Q
  (hypT : ∀ R, size_Ty R < size_Ty Q → Trans R)
  (hypN : ∀ R, size_Ty R < size_Ty Q → Narrow R) :
  Trans Q.
Proof with simpl; eauto with infra; try omega.
  intros Γ S T subSQ subQT; revert T subQT.
  induction subSQ; intros; auto.
  - dependent destruction subQT; constructor; auto.
  - eapply SA_Trans_TVar; eauto.
  - dependent destruction subQT; simpl; constructor; eauto with wf...
    + apply (hypT T1)...
    + apply (hypT T2)...
  - dependent destruction subQT; constructor; eauto with wf...
    + apply (hypT T1)...
    + apply (hypT T2)...
      refine (hypN T1 _ _ empty _ _ subSQ2 _ subQT1)...
Qed.

Lemma narrow_case Q (hyp : ∀ (R : Ty), size_Ty R = size_Ty Q → Trans R) :
  Narrow Q.
Proof.
  intros Γ Δ U T subUT; depind subUT; intros R subQ.
  - apply SA_Top; isimpl; auto.
  - apply SA_Refl_TVar; isimpl; auto.
  - pose proof (Sub_wf_1 _ _ _ subQ) as wfQ.
    case (eq_index_dec X (weakenIndexty I0 (domainEnv Δ))); intros; subst.
    + pose proof (lookup_etvar_functional _ lk _ (weaken_lookup_etvar_here Δ wfQ)).
      (* The lookup position X is the one that is being narrowed, so U is in
         fact Q weakened and hence we can use transitivity for U.  U. We can
         derive the goal like this:

                               Γ ⊢ R<:Q
                             ------------- shift_etvar_sub
                             Γ,x<:R ⊢ R<:Q
                            --------------- weaken_sub
         (x<:R) ∈ Γ,x<:R,Δ  Γ,x<:R,Δ ⊢ R<:Q
         ---------------------------------- SA_Trans  -------------- IH
                   Γ,x<:R,Δ ⊢ x<:U                    Γ,x:R,Δ ⊢ U<:T
         ----------------------------------------------------------- hyp U
                                 Γ,x<:R,Δ ⊢ x<:T
      *)
      apply (hyp U); subst; isimpl; auto.
      eapply SA_Trans_TVar; isimpl; eauto using weaken_Sub with wf infra.
    (* Just push the narrowing into the subtyping part. *)
    + eapply SA_Trans_TVar; eauto using narrow_lookup_etvar_ne with infra.
  - constructor; auto.
  - constructor; auto; apply (IHsubUT2 (etvar Δ T1) _ Q); auto.
Qed.

Lemma sub_trans_and_narrow Q : Trans Q ∧ Narrow Q.
Proof.
  induction Q using (sizeind size_Ty); intros; split.
  - apply trans_case; apply H; auto.
  - apply narrow_case; intros R eq.
    apply trans_case; rewrite eq; apply H.
Qed.

Lemma sub_trans {Q Γ S T} : Sub Γ S Q → Sub Γ Q T → Sub Γ S T.
Proof. intros; eapply sub_trans_and_narrow; eauto. Qed.

Lemma sub_narrow {Γ Δ Q R S T} (subQ: Sub Γ R Q) :
  Sub (appendEnv (etvar Γ Q) Δ) S T → Sub (appendEnv (etvar Γ R) Δ) S T.
Proof. intros; eapply sub_trans_and_narrow; eauto. Qed.

Lemma lookup_evar_narrow {Γ Δ Q R} :
  ∀ {x T}, lookup_evar (appendEnv (etvar Γ Q) Δ) x T →
           lookup_evar (appendEnv (etvar Γ R) Δ) x T.
Proof.
  induction Δ; inversion 1; isimpl; constructor; isimpl; eauto with wf.
Qed.

Lemma typing_narrow {Γ} Δ {Q R t T} (subQ: Sub Γ R Q) :
  Typing (appendEnv (etvar Γ Q) Δ) t T → Typing (appendEnv (etvar Γ R) Δ) t T.
Proof.
  intro wt; depind wt; eauto using Typing, sub_narrow.
  - eapply T_Var; eauto using lookup_evar_narrow with infra.
  - eapply T_Abs; isimpl; eauto.
    refine (IHwt Γ (evar Δ T1) _ _ eq_refl); auto.
  - eapply T_Tabs; isimpl; eauto.
    refine (IHwt Γ (etvar _ _) _ _ eq_refl); auto.
Qed.

Lemma typing_narrow0 {Γ Q R t T} (subQ: Sub Γ R Q) :
  Typing (etvar Γ Q) t T → Typing (etvar Γ R) t T.
Proof.
  apply (typing_narrow empty subQ).
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Instance obligation_Env_var_ty : Obligation_Env_var_ty.
Proof.
  constructor; intros; eapply SA_Trans_TVar; eauto using sub_refl with infra.
Qed.

Instance obligation_Env_reg_Sub : Obligation_Env_reg_Sub.
Proof.
  constructor; intros; simpl; eauto using sub_refl, sub_trans.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {t T1 T2} (v: Value t) (wt: Typing empty t (tarr T1 T2)) :
  ∃ T1' t2, t = abs T1' t2.
Proof.
  depind wt; try contradiction.
  - exists T1, t; reflexivity.
  - inversion jm11; eauto; inversion lk.
Qed.

Lemma can_form_tall {t T1 T2} (v: Value t) (wt: Typing empty t (tall T1 T2)) :
  ∃ T1' t2, t = tabs T1' t2.
Proof.
  depind wt; try contradiction.
  - exists T1, t; reflexivity.
  - inversion jm11; eauto; inversion lk.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with destruct_conjs; subst; eauto using red.
  depind wt; simpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma t_abs_inversion {Γ t T0 T1} (wt: Typing Γ (abs T1 t) T0) :
  ∀ {T2 T3}, Sub Γ T0 (tarr T2 T3) → Sub Γ T2 T1 ∧ Typing (evar Γ T1) t T3.
Proof.
  depind wt.
  - inversion 1; eauto using T_Sub, shift_evar_Sub with shift.
  - eauto using sub_trans.
Qed.

Lemma t_tabs_inversion {Γ t T0 T1} (wt: Typing Γ (tabs T1 t) T0) :
  ∀ {T2 T3}, Sub Γ T0 (tall T2 T3) → Sub Γ T2 T1 ∧ Typing (etvar Γ T2) t T3.
Proof.
  depind wt.
  - inversion 1; subst; split; eauto using T_Sub, typing_narrow0.
  - eauto using sub_trans.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - destruct (t_abs_inversion wt1 (sub_refl (Typing_wf_1 _ _ _ wt1))).
    eauto using subst_evar_Typing, T_Sub with subst.
  - destruct (t_tabs_inversion wt (sub_refl (Typing_wf_1 _ _ _ wt))).
    eauto using subst_etvar_Typing, T_Sub with wf infra.
Qed.


Require Import Basics.
Require Import SetoidClass.
Require Import MySetoids.
Require Import Tactics.
Require Import Bool.

Definition Locs := nat.
Definition Vars := nat.
Definition RVars := nat.
Definition ERVars := nat.

Lemma eq_dec : forall x y:RVars, {x = y} + {x <> y}.
decide equality.
Qed.

(* Types for the system *)
Inductive Types :=
  | Int : Types
  | Null : Types
  | Ref :  Types  -> Types -> Types
  | RVar_b : forall n (p: n > 0), Types
  | Rec : Types -> Types
  | Nullable : Types -> Types
.

(* Only works on closed terms, but we only use it on closed terms. *)
Fixpoint subst (X : nat) ts (t : Types) :=
  match t with
  | Null
  | Int
     => t
  | Nullable t => Nullable (subst X ts t)
  | RVar_b Y _ => if eq_dec X Y then ts else t
  | Ref t1 t2 => Ref (subst X ts t1) (subst X ts t2)
  | Rec t1 => Rec (subst (S X) ts t1)
  end.

Lemma subst_id : forall t X p, (subst X t (RVar_b X p)) = t.
intros. simpl. autodestruct; congruence.
Qed.

Definition unfold tb := subst 1 (Rec tb) tb .

(* Subtyping relation *)
Inductive subtype : Types -> Types -> Prop :=
   ts_fold : forall t, subtype (unfold t) (Rec t)
 | ts_unfold : forall t, subtype (Rec t) (unfold t)
(* Nullable Rules *)
 | ts_nullable_drop1 : forall t,
            subtype t (Nullable t)
 | ts_nullable_drop2 : forall t,
            subtype Null (Nullable t)

.

Hint Resolve ts_fold ts_unfold  ts_nullable_drop1 ts_nullable_drop2.

(* Contexts for program variables *)
Instance setoid_types : Setoid (Types)
   := { equiv := eq }.

Instance setoid_opt_types : Setoid (option Types)
   := { equiv := eq }.

Definition VCon := Vars -> option Types.

Program Instance setoid_vars : Setoid Vars.
Instance setoid_m : Setoid VCon :=
  setoid_arrow (option Types) Vars setoid_opt_types setoid_vars .

Definition add {T} X (t : T) G  :=
   fun Y => if eq_dec X Y then Some t else G Y.

Instance add_proper :
  Proper (equiv ==> equiv ==> equiv ==> equiv) (add (T:=Types)).
push.
destruct H.
destruct H0.
unfold add.
autodestruct; triv.
Qed.

Definition delete {T} X G : nat -> option T :=
   fun Y => if eq_dec X Y then None else G Y.

Definition empty {T} {S} :  T-> option S := fun Y => None.

(*
Inductive subtype_con : VCon -> VCon -> Prop :=
  | sc_refl : forall G1 G2, G1 == G2 -> subtype_con G1 G2
  | sc_trans : forall G1 G2 G3, subtype_con G1 G2 -> subtype_con G2 G3 -> subtype_con G1 G3
  | sc_one : forall G G1 G2 t1 t2 x,
      G1 == (add x t1 G) ->
      G2 == (add x t2 G) ->
      subtype t1 t2 -> subtype_con G1 G2
  | sc_drop : forall G G1 t1 x, G x = None -> G1 == (add x t1 G) -> subtype_con G1 G.

Instance subtype_proper : Proper (equiv ==> equiv ==> impl) subtype_con.
intro.
intros y Heq x1 y1 Heq2 Hsub.
generalize Heq2 Heq.
clear Heq Heq2.
generalize y y1.
clear y y1.
induction Hsub; intros.

(* Refl case *)
  eapply sc_refl; repeat ssubst; intuition.
(* trans case *)
 eapply sc_trans.
 eapply IHHsub1; eauto. reflexivity.
 eapply IHHsub2; eauto. reflexivity.
(* add case *)
 eapply sc_one;
 repeat ssubst; triv.
(* drop case *)
 eapply sc_drop.
 2: repeat ssubst; reflexivity.
 compute in Heq2.
 use_foralls.
 optionstac. trivial.
Qed.
*)
Definition subtype_con (G1 G2 :VCon) : Prop :=
  forall x t, G2 x = Some t ->
      exists t', G1 x = Some t' /\ subtype t' t.

Instance subtype_proper : Proper (equiv ==> equiv ==> impl) subtype_con.
do 6 intro.
automatcher.
automatcher.
ssubst. ssubst.
trivial.
Qed.

Require Import Language.

(* Setting up basic commands *)
Module TupleAtoms.

(* Require two stage definition to deal with Coq missing feature. *)
Inductive Atomic_Hack : Set :=
|  is_null : Vars -> Atomic_Hack
|  is_not_null : Vars -> Atomic_Hack
|  read_fst : Vars -> Vars -> Atomic_Hack
|  read_snd : Vars -> Vars -> Atomic_Hack
|  write_fst : Vars -> Vars -> Atomic_Hack
|  write_snd : Vars -> Vars -> Atomic_Hack
|  new : Vars -> Vars -> Vars -> Atomic_Hack
|  new_simp : Vars -> Atomic_Hack.

Definition Atomic := Atomic_Hack.

End TupleAtoms.

Module TupleLang := BasicSyntax TupleAtoms.
Import TupleAtoms.
Import TupleLang.

Module TupleStateTransformers.

Definition Heap := Locs -> option nat.
Definition Stack := (Vars -> nat).
Definition State := option (prod Heap Stack).

Definition upd {T} x (v : T) f y := if eq_dec x y then v else f y.

Instance upd_morph {T} {b : Setoid T}:
  Proper (equiv ==> equiv ==> equiv ==> equiv) (@upd T).
repeat intro.
compute. compute in H. subst.
repeat autodestruct; trivial.
intros. generalize (H1 a). intro HH; rewrite HH. reflexivity.
Qed.

Instance opt_nat_setoid : Setoid (option nat) := { equiv:= eq}.
Program Instance heap_setoid : Setoid Heap.
Program Instance stack_setoid : Setoid Stack.
Instance pre_state_setoid : Setoid (Heap * Stack) :=
  {
     equiv := prod_equiv
  }.

Instance state_setoid : Setoid State :=
 {
    equiv := option_equiv
  }.

Definition interp_pre : Atomic -> State -> State -> Prop
  :=
  fun a s e =>
   match s with
   | None => e = None
   | Some (hp,st) =>
   match a with
   |  is_null x
       => st x = 0 /\ s==e
   |  is_not_null x
       => st x <> 0 /\ s==e
   |  read_fst x y
       =>
       match hp (st y) with
       | None => e = None
       | Some v => e == Some (hp,upd x v st)
       end
   |  read_snd x y
       =>
       match hp (S(st y)) with
       | None => e = None
       | Some v => e == Some (hp, upd x v st)
       end
   |  write_fst x y
       =>
       match hp (st x) with
       | None => e = None
       | Some _ =>
          e == Some (add (st x) (st y) hp, st)
       end
   |  write_snd x y
       =>
       match hp (S (st x)) with
       | None => e = None
       | Some _ =>
          e == Some (add (S (st x)) (st y) hp, st)
       end
   |  new x y z =>
       exists v, hp v = None /\ hp (S v) = None /\
                  e == Some (add v (st y) (add (S v) (st z) hp), (upd x v st))
   |  new_simp x =>
       exists v, hp v = None /\ hp (S v) = None /\
                  e == Some (add v 0 (add (S v) 0 hp), (upd x v st))
   end
   end
   .

Instance interp_morph : Proper (eq ==> equiv ==> equiv ==> equiv) interp_pre.
repeat intro.
subst.
destruct x0; destruct y0.
2: compute in H0; try contradiction.
2: compute in H0; try contradiction.

2: simpl; intros; destruct x1; destruct y1; split; intros; trivial;
try congruence;
compute in *; contradiction.

(* Unpack equalities on pair *)
destruct H0.
repeat destructpair.
compute [fst snd] in *.

destruct x1; destruct y1.
2: compute in H1; try contradiction.
2: compute in H1; try contradiction.

Focus 2.
destruct y; simpl; repeat ssubst; try reflexivity; firstorder.

repeat destructpair.
destruct H1.
compute [fst snd] in *.
destruct y; simpl; unfold prod_equiv; compute [fst snd] in *; unfold upd;
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2;
  try reflexivity.

destruct (h (s v0)).
2: split; try congruence.
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2.
  intuition;
  rewrite H5; compute; intro;
  autodestruct; try reflexivity;
  rewrite H0; try reflexivity.

destruct (h (S (s v0))).
2: split; try congruence.
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2.
  intuition;
  rewrite H5; compute; intro;
  autodestruct; try reflexivity;
  rewrite H0; try reflexivity.

destruct (h (s v)).
2: split; try congruence.
  unfold add.
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2.
  intuition;
  rewrite H4; compute; intro;
  autodestruct; try reflexivity;
  rewrite H; try reflexivity.

destruct (h (S (s v))).
2: split; try congruence.
  unfold add.
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2.
  intuition;
  rewrite H4; compute; intro;
  autodestruct; try reflexivity;
  rewrite H; try reflexivity.

  unfold add.
  split; intros [x Hc]; exists x;
  generalize Hc; clear Hc;
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2.
  intuition; (rewrite H5 || rewrite H7);
  compute; intro; autodestruct; try reflexivity; firstorder;
  compute; autodestruct; try reflexivity;
  firstorder.
  intuition; (rewrite H5 || rewrite H7);
  compute; try intro; autodestruct; try reflexivity; try rewrite H; firstorder.
  rewrite H0. reflexivity.

  split; automatcher;
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2;
  repeat automatcher; trivial;
  compute; autodestruct; trivial;
  try autodestruct; trivial;
  repeat rewrite H;
  repeat rewrite H0;
  repeat rewrite H1;
  repeat rewrite H2;
  trivial.
Qed.

Definition interp a := {| st_trans := interp_pre a |}.

End TupleStateTransformers.

Module TupleOpSem := OperationalSemantics TupleAtoms TupleLang TupleStateTransformers .

Section Axioms.
Inductive type_atomic  : VCon -> TupleAtoms.Atomic -> VCon -> Prop :=
  | t_atom_null :
          forall x t,
		type_atomic (add x t empty)
                            (is_null x)
                            (add x Null empty)
  | t_atom_not_null :
          forall x t,
              type_atomic (add x (Nullable t) empty)
                          (is_not_null x)
	                  (add x t empty)
  | t_atom_read_fst :
          forall x y t t1 t2, x <> y ->
               type_atomic (add x t (add y (Ref t1 t2) empty))
                           (read_fst x y)
			   (add x t1 (add y (Ref t1 t2) empty))
  | t_atom_read_snd :
          forall x y t t1 t2, x <> y ->
               type_atomic (add x t (add y (Ref t1 t2) empty))
                           (read_snd x y)
			   (add x t2 (add y (Ref t1 t2) empty))
  | t_atom_write_fst :
          forall x y t1 t2, x <> y ->
               type_atomic (add x t1 (add y (Ref t1 t2) empty))
                           (write_fst y x)
                           (add x t1 (add y (Ref t1 t2) empty))
  | t_atom_write_snd :
          forall x y t1 t2, x <> y ->
               type_atomic (add x t2 (add y (Ref t1 t2) empty))
                           (write_snd y x)
                           (add x t2 (add y (Ref t1 t2) empty))
  | t_atom_new :
         forall x y z t t1 t2, x <> y -> x<>z -> y<>z ->
               type_atomic (add x t (add y t1 (add z t2 empty)))
			   (new x y z)
			   (add x (Ref t1 t2) (add y t1 (add z t2 empty)))
.
End Axioms.


Require Import VST.floyd.proofauto.
Require Import VST.concurrency.conclib.
Require Import basic_lemmas.
Require Import spec_parsplit.
Require Import dotprod.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Open Scope logic.

Definition delta n T t := t*n/T.

Lemma delta_props n T t :
  0 <= n /\ 0 <= t < T ->
  0 <= delta n T t /\ delta n T t <= delta n T (t+1) <= n.
Proof.
intros * [? ?]; unfold delta.
split3.
-
  apply Z_div_nonneg_nonneg.  nia. lia.
-
  apply Z.div_le_mono; auto; try lia.
-
  rewrite Z.mul_comm.
  apply Z.le_trans with (n * T / T).
apply Z.div_le_mono. lia.
  apply Z.mul_le_mono_nonneg_l; lia.
  rewrite Z.div_mul; lia.
Qed.

Lemma delta_props' n T t :
  0 <= n /\  0 < T /\  0 <= t <= T ->
  0 <= delta n T t <= n.
Proof.
intros * [? [? ?]]; unfold delta.
split.
-
  apply Z_div_nonneg_nonneg.  nia. lia.
-
  rewrite Z.mul_comm.
  apply Z.le_trans with (n * T / T).
  apply Z.div_le_mono; auto; try lia.
  apply Z.mul_le_mono_nonneg_l; lia.
  rewrite Z.div_mul; lia.
Qed.

Lemma delta_0: forall n T, delta n T 0 = 0.
Proof.
intros. reflexivity.
Qed.

Lemma delta_T: forall n T,
  0 <= n -> 0 < T ->
  delta n T T = n.
Proof.
 intros. unfold delta.
 rewrite Z.mul_comm.
 apply Z.div_mul.
 lia.
Qed.

Definition dtask_input_type : Type := (list float * list float) * (val*val).
Definition dtask_output_type : Type := float.

Definition sum (v: list float) := fold_left Float.add v Float.zero.

Definition dotprod (v12: list float * list float) : float :=
  let '(v1,v2) := v12 in
  sum (map (uncurry Float.mul) (combine v1 v2)).

Definition dotprod_f (T: Z) (v12: list float * list float) : dtask_output_type :=
 let '(v1,v2) := v12 in
 let y :=  map (uncurry Float.mul) (combine v1 v2) in
 let n := Zlength y in
  sum (map (fun i => sum (sublist (delta n T i) (delta n T (i+1)) y)) (iota T)).

Lemma dotprod_f_sanity :
 forall T v12,
  0 < T ->
  (forall x y z, (Float.add (Float.add x y) z) = Float.add x (Float.add y z)) ->
  (forall x, Float.add Float.zero x = x) ->
  dotprod_f T v12 = dotprod v12.
Proof.
 intros ? ? H2 ? ?.
 (* Let's pretend we don't know that from assumption H0 one could actually prove False... *)
assert (forall y : float, Float.add Float.zero y = Float.add y Float.zero).
intro; apply Float.add_commut; left; reflexivity.
unfold dotprod_f, dotprod.
destruct v12 as [v1 v2].
simpl.
set (n := Zlength _).
set (d := delta n T).
set (v := map (uncurry _) _) in *.
clearbody v.
transitivity (sum (sublist 0 (d T) v)).
2:{ rewrite sublist_same; auto; try lia. apply delta_T; rep_lia. }
rewrite <- (Z2Nat.id T) by lia.
assert (Z.of_nat (Z.to_nat T) <= T) by lia.
revert H2.
induction (Z.to_nat T); intro.
simpl. unfold d. rewrite delta_0. list_solve.
rewrite inj_S. unfold Z.succ. rewrite iota_S by lia.
pose proof (delta_props n T (Z.of_nat n0)) ltac:(rep_lia).
fold d in H4.
rewrite (sublist_split 0 (d (Z.of_nat n0))) by lia.
rewrite map_app.
simpl.
set (a := map _ _) in *.
clearbody a.
set (b := sublist _ _ _). clearbody b.
set (c := sublist _ _ _) in *. clearbody c.
specialize (IHn0 ltac:(lia) H2).
clear - IHn0 H H0 H1.
assert (forall a b, sum(a++b) = Float.add (sum a) (sum b)). {
 clear - H H0 H1.
 intros.
 unfold sum.
 rewrite !fold_symmetric by auto.
 induction a; simpl. rewrite H0. auto.
 rewrite IHa. rewrite !H. reflexivity.
}
rewrite !H2.
rewrite IHn0.
f_equal.
unfold sum at 1.
simpl.
apply H0.
Qed.

Definition q_share (q: query) : share :=
 match q with
 | REMEMBER => Ers2
 | ASK => Ers
 | ANSWER => Ers
 end.

Definition a_pred (q: query) (m: mpred) : mpred :=
 match q with
 | REMEMBER => emp
 | ASK => m
 | ANSWER => m
 end.

Definition answer_val (q: query) (v: val) :=
 match q with
 | REMEMBER => Vundef
 | ASK => Vundef
 | ANSWER => v
 end.

Definition t_dtask := Tstruct _dotprod_task noattr.

Definition dtask_pred (T: Z) (input: dtask_input_type) (q: query) (p: val) :=
        let '((v1,v2),(p1,p2)) := input in
        let n := Zlength v1 in
        !! (n = Zlength v2 /\ n <= Int.max_unsigned) &&
        field_at (q_share q) t_dtask (DOT _vec1) p1 p *
        field_at (q_share q) t_dtask (DOT _vec2) p2 p *
        field_at (q_share q) t_dtask (DOT _n) (vint n) p *
        a_pred q (field_at Ews t_dtask (DOT _result)
                 (answer_val q (Vfloat (dotprod (v1,v2)))) p) *
        data_at (q_share q) (tarray tdouble n) (map Vfloat v1) p1 *
        data_at (q_share q) (tarray tdouble n) (map Vfloat v2) p2.

Arguments dtask_pred T input q p : simpl never.

Lemma dtask_pred_local_facts:
  forall T input q p,
     dtask_pred T input q p |-- !! isptr p.
Proof.
intros.
unfold dtask_pred.
destruct input as [[? ?] [? ? ]].
entailer!.
Qed.

#[export] Hint Resolve dtask_pred_local_facts : saturate_local.

Lemma dtask_pred_valid_pointer:
  forall T input q p,
   dtask_pred T input q p |-- valid_pointer p.
Proof.
intros.
unfold dtask_pred.
destruct input as [[? ?] [? ? ]].
Intros.
repeat apply sepcon_valid_pointer1.
apply field_at_valid_ptr0.
destruct q; simpl; auto.
simpl. lia.
reflexivity.
Qed.

#[export] Hint Resolve dtask_pred_valid_pointer : valid_pointer.

Lemma isptr_value_defined: forall t p, isptr p -> value_defined (tptr t) p.
Proof.
intros.
destruct p; try contradiction; hnf; simpl.
rewrite andb_false_r. simpl; auto.
Qed.

#[export] Hint Resolve isptr_value_defined : core.

Lemma dtask_pred_input_eq: forall T input1 input2  p,
          dtask_pred T input1 REMEMBER p *
          dtask_pred T input2 ANSWER p
          |-- !! (input1 = input2).
Proof.
intros.
unfold dtask_pred.
destruct input1 as [[v11 v12] [p11 p12]].
destruct input2 as [[v21 v22] [p21 p22]].
Intros.
simpl.
assert_PROP (isptr p11 /\ isptr p12 /\ isptr p21 /\ isptr p22) by entailer!.
destruct H3 as [? [? [? ?]]].
rewrite !field_at_data_at. simpl.
sep_apply (data_at_values_cohere Ers Ers2 (tptr tdouble) p21 p11); auto.
sep_apply (data_at_values_cohere Ers Ers2 (tptr tdouble) p22 p12); auto.
sep_apply  (data_at_values_cohere Ers Ers2 tuint); auto.
Intros. subst.
apply repr_inj_unsigned in H7; try rep_lia.
rewrite H7.
set (n := Zlength v11) in *.
clear - H H1 H7.
sep_apply (data_at_values_cohere Ers Ers2 (tarray tdouble n)
                               (map Vfloat v21)   (map Vfloat v11)); auto;
  try (apply value_defined_tarray; [list_solve | apply Forall_map; apply Forall_forall; intros; hnf; auto]).
sep_apply (data_at_values_cohere Ers Ers2 (tarray tdouble n)
                               (map Vfloat v22)   (map Vfloat v12)); auto;
  try (apply value_defined_tarray; [list_solve | apply Forall_map; apply Forall_forall; intros; hnf; auto]).
Intros.
apply prop_right.
apply map_inj in H0; [ | congruence].
apply map_inj in H2; [ | congruence].
congruence.
Qed.

Lemma make_REMEMBER_ASK:
 forall T v1 v2 p1 p2 dtp n,
 0 <= n <= Int.max_unsigned ->
 0 < T ->
  data_at Ews (tarray tdouble n) (map Vfloat v1) p1
 * data_at Ews  (tarray tdouble n)  (map Vfloat v2) p2
  * data_at Ews t_dtask (p1,(p2, (vint n, Vundef))) dtp
|-- dtask_pred T ((v1,v2),(p1,p2)) REMEMBER dtp
      * dtask_pred T ((v1,v2),(p1,p2)) ASK    dtp.
Proof.
intros.
unfold dtask_pred; simpl.
saturate_local.
rewrite !prop_true_andp by (split; list_solve).
clear H7 H5 H2.
rewrite !Zlength_map in *.
set (n := Zlength v1) in *.
rewrite <-  !(data_at_share_join Ers Ers2 Ews (tarray tdouble n)); auto with shares.
cancel.
unfold_data_at (data_at _ _ _ _ ).
 rewrite <-  (field_at_share_join Ers Ers2 Ews t_dtask (DOT _vec1)); auto with shares.
 rewrite <- (field_at_share_join Ers Ers2 Ews t_dtask (DOT _vec2)); auto with shares.
 rewrite <- (field_at_share_join Ers Ers2 Ews t_dtask (DOT _n)); auto with shares.
cancel.
Qed.

Lemma unmake_REMEMBER_ANSWER:
 forall T n v1 v2 p1 p2 dtp,
  n = Zlength v1 ->
  dtask_pred T (v1, v2, (p1, p2)) REMEMBER dtp
  * dtask_pred T (v1, v2, (p1, p2)) ANSWER dtp
  |-- data_at Ews t_dtask  (p1,(p2, (vint n, Vfloat (dotprod (v1,v2))))) dtp
      * data_at Ews (tarray tdouble n) (map Vfloat v1) p1
      * data_at Ews (tarray tdouble n) (map Vfloat v2) p2.
Proof.
intros.
sep_apply dtask_pred_input_eq.
Intros.
unfold dtask_pred.
Intros.
simpl.
set (s := sum _). clearbody s.
rewrite <- H in *.
rewrite <- !(data_at_share_join Ers Ers2 Ews (tarray tdouble n)) by auto with shares.
cancel.
repeat (unfold_data_at (data_at _ _ _ _)).
rewrite <- !(field_at_share_join Ers Ers2 Ews) by auto with shares.
cancel.
Qed.

#[export] Instance dtask_package : task_package :=
  Build_task_package dtask_input_type _ dtask_output_type
   dtask_pred
   dtask_pred_local_facts
   dtask_pred_valid_pointer
   dtask_pred_input_eq.

Definition dotprod_worker_spec :=
 DECLARE _dotprod_worker
 WITH T: Z, clo : val, input: task_input_type
 PRE [ tptr tvoid ]
    PROP() PARAMS(clo) SEP (dtask_pred T input ASK clo)
 POST [ tvoid ]
    PROP() RETURN() SEP(dtask_pred T input ANSWER clo).

Definition fclo (gv: globals) (T: Z) (dtp: val) : list (val*val) :=
  map (fun i => (gv _dotprod_worker,
                         field_address0 (tarray t_dtask T) (SUB i) dtp))
        (iota T).

Lemma Zlength_fclo: forall gv T dtp,
  0 <= T -> Zlength (fclo gv T dtp) = T.
Proof.
 intros.
 unfold fclo. rewrite Zlength_map. rewrite Zlength_iota; lia.
Qed.

Lemma snd_Znth_fclo:
 forall t gv T dtp,
  0 <= t < T ->
  snd (Znth t (fclo gv T dtp)) = field_address0 (tarray t_dtask T) (SUB t) dtp.
Proof.
intros; unfold fclo; rewrite Znth_map, Znth_iota by list_solve; auto.
Qed.

Definition tasking T (gv: globals) :=
  EX tp:val, EX dtp: val,
   !! (0 < T < 10000) &&
   data_at Ews tuint (vint T) (gv _num_threads) *
   data_at Ews (tptr t_task) tp (gv _tasks) *
   task_array dtask_package (fclo gv T dtp) tp *
   data_at Ews (tptr t_dtask) dtp (gv _dtasks) *
   data_at_ Ews (tarray t_dtask T) dtp.

Definition dotprod_spec :=
  DECLARE _dotprod
  WITH T:Z, p1:val, p2: val, v1: list float, v2: list float, gv: globals
  PRE [ tptr tdouble, tptr tdouble, tuint ]
    PROP ( Zlength v1 = Zlength v2; Zlength v1 <= Int.max_unsigned)
    PARAMS ( p1; p2; Vint (Int.repr (Zlength v1))) GLOBALS(gv)
    SEP (tasking T gv;
           data_at Ews (tarray tdouble (Zlength v1)) (map Vfloat v1) p1;
           data_at Ews (tarray tdouble (Zlength v2)) (map Vfloat v2) p2)
  POST [ tdouble ]
    PROP()
    RETURN (Vfloat (dotprod_f T (v1,v2)))
    SEP (tasking T gv;
           data_at Ews (tarray tdouble (Zlength v1)) (map Vfloat v1) p1;
           data_at Ews (tarray tdouble (Zlength v2)) (map Vfloat v2) p2).

Definition make_dotprod_tasks_spec :=
  DECLARE _make_dotprod_tasks
  WITH T: Z, gv: globals
  PRE [ tuint ]
     PROP (1 <= T < 10000)
     PARAMS (vint T) GLOBALS (gv)
     SEP (library.mem_mgr gv;
           data_at_ Ews tuint (gv _num_threads);
           data_at_ Ews (tptr t_task) (gv _tasks);
           data_at_ Ews (tptr t_dtask) (gv _dtasks))
   POST [ tvoid ]
     PROP() RETURN() SEP(library.mem_mgr gv; tasking T gv; TT).

Definition Gprog : funspecs :=
   dotprod_worker_spec :: dotprod_spec ::
    (DECLARE _malloc (@library.malloc_spec' CompSpecs)) ::
  [ exit_spec;
    make_tasks_spec dtask_package;
    initialize_task_spec dtask_package; do_tasks_spec dtask_package].

Lemma task_array_local_facts:
  forall TP fclo p,
  task_array TP fclo p |-- !! isptr p.
Proof.
intros.
unfold task_array.
entailer!.
destruct H; auto.
Qed.

#[export] Hint Resolve task_array_local_facts: saturate_local.

Definition partial_dotprod_f (t T: Z) (v12: list float * list float) : dtask_output_type :=
 let '(v1,v2) := v12 in
 let y :=  map (uncurry Float.mul) (combine v1 v2) in
 let n := Zlength y in
  sum (map (fun i => sum (sublist (delta n T i) (delta n T (i+1)) y)) (iota t)).

Lemma body_make_dotprod_tasks: semax_body Vprog Gprog f_make_dotprod_tasks make_dotprod_tasks_spec.
Proof.
start_function.
forward_call .
Intros tp.
forward.
forward.
forward_call (tarray t_dtask T, gv).
entailer!.
simpl.
f_equal; f_equal. f_equal; lia.
unfold sizeof; simpl.
rep_lia.
Intros dtp.
forward.
forward.
if_tac.
forward_if False. forward_call. contradiction. contradiction.
forward_if True. contradiction.
forward.
entailer!.
Intros. clear H0.
deadvars!.
forward_for_simple_bound T
 (EX t:Z,
   PROP ( )
   LOCAL (gvars gv; temp _T (vint T))
   SEP (library.mem_mgr gv;
   library.malloc_token Ews (tarray t_dtask T) dtp;
   data_at_ Ews (tarray t_dtask T) dtp;
   task_array dtask_package (
        map (fun i => (gv _dotprod_worker,
                         field_address0 (tarray t_dtask T) (SUB i) dtp))
           (iota t)  ++ Zrepeat (Vundef, Vundef) (T-t))
      tp;
   TT;
   data_at Ews tuint (vint T) (gv _num_threads);
   data_at Ews (tptr t_task) tp (gv _tasks);
   data_at Ews (tptr t_dtask) dtp (gv _dtasks)))%assert.
-
entailer!.
simpl; auto.
-
rename i into t.
forward.
forward.
set (fclo' := map _ _ ++ _).
forward_call (tp, t, (gv _dotprod_worker),
                    field_address0 (tarray t_dtask T) (SUB t) dtp,
                    fclo').
 {entailer!.
  simpl.
  rewrite field_address0_offset by auto with field_compatible.
  reflexivity.
 }
  subst fclo'; list_solve.
entailer!.
apply sepcon_derives; auto.
apply derives_refl'.
f_equal.
subst fclo'.
rewrite upd_Znth_app2 by list_simplify.
list_simplify; rewrite !Znth_iota by lia.
reflexivity.
rewrite <- app_nil_end.
assert (i=t) by lia. subst.
reflexivity.
-
forward.
unfold tasking.
Exists tp dtp.
rewrite prop_true_andp by lia.
list_simplify.
change (map _ _) with (fclo gv T dtp).
cancel.
Qed.

Lemma field_at_SUB_t_DOT_result:
 forall t T a dtp,
 0 <= t < T ->
 T < 10000 ->
 field_compatible (tarray t_dtask T) [] dtp ->
 field_at Ews (tarray t_dtask T) [StructField _result; ArraySubsc t]
  (Vfloat a) dtp
 = field_at Ews t_dtask (DOT _result) (Vfloat a)
      (field_address0 (tarray t_dtask T) (SUB t) dtp).
Proof.
intros.
replace (field_address0 (tarray t_dtask T) (SUB t) dtp)
 with (field_address (tarray t_dtask T) (SUB t) dtp)
 by auto 50 with field_compatible.
apply (field_at_app _ (tarray t_dtask T) (DOT _result) (SUB t)); auto.
Qed.

Lemma finish_dotprod:
 forall T p1 p2 v1 v2 dtp gv,
  Zlength v1 = Zlength v2 ->
  0 < T < 10000 ->
  let delt := delta (Zlength v1) T in
let inp :=
  map
    (fun i : Z =>
     ((sublist (delt i) (delt (i + 1)) v1, sublist (delt i) (delt (i + 1)) v2),
      (field_address0 (tarray tdouble (Zlength v1)) (SUB delt i) p1,
       field_address0 (tarray tdouble (Zlength v1)) (SUB delt i) p2)))
 (iota T) in
field_compatible (tarray t_dtask T) [] dtp ->
field_compatible0 (tarray tdouble (Zlength v1)) [] p1 ->
field_compatible0 (tarray tdouble (Zlength v1)) [] p2 ->
pred_sepcon (ith_spectask dtask_package (fclo gv T dtp) inp ANSWER)
  (fun i : Z => 0 <= i < T)
|-- data_at_ Ews (tarray t_dtask T) dtp
      * data_at Ews (tarray tdouble (Zlength v1)) (map Vfloat v1) p1
      * data_at Ews (tarray tdouble (Zlength v1)) (map Vfloat v2) p2.
Proof.
intros.
set (t:=T).
unfold t at 1.
replace (data_at Ews (tarray tdouble (Zlength v1)) (map Vfloat v1) p1)
  with (data_at Ews (tarray tdouble (delt t)) (map Vfloat (sublist 0 (delt t) v1)) p1)
  by (unfold t, delt; rewrite delta_T, sublist_same by rep_lia; auto).
replace (data_at Ews (tarray tdouble (Zlength v1)) (map Vfloat v2) p2)
  with (data_at Ews (tarray tdouble (delt t)) (map Vfloat (sublist 0 (delt t) v2)) p2)
  by (unfold t, delt; rewrite delta_T, sublist_same by rep_lia; auto).
assert (0 <= t <= T) by lia.
clearbody t.
rewrite <- (Z2Nat.id t) in * by lia.
induction (Z.to_nat t).
-
rewrite pred_sepcon_False' by lia.
simpl Z.of_nat.
unfold delt; rewrite delta_0.
apply derives_trans with (emp * emp * emp).
cancel.
repeat apply sepcon_derives; apply data_at_zero_array;
 auto with field_compatible.
-
rewrite inj_S. unfold Z.succ.
rewrite (pred_sepcon_isolate (Z.of_nat n) zeq) by lia.
replace (fun y : Z => 0 <= y < Z.of_nat n + 1 /\ y <> Z.of_nat n)
 with (fun i : Z => 0 <= i < Z.of_nat n)
  by (extensionality j; apply prop_ext; split; intro; lia).
unfold ith_spectask at 2.
sep_apply func_ptr'_emp.
sep_apply IHn; try lia.
clear IHn.
clear t.
rewrite inj_S in H4.
assert (0 <= Z.of_nat n) by lia.
forget (Z.of_nat n) as t. clear n.
set (n := Zlength v1) in *.
change task_pred with dtask_pred.
pose proof (delta_props n T t ltac:(rep_lia)). fold delt in H6.
set (dt := delt t) in *.
set (dt1 := delt (t + 1)) in *.
rewrite (split2_data_at__Tarray_app t (t+1)) by lia.
replace (t + 1 - t) with 1 by lia.
replace  (field_address0 (tarray t_dtask (t+1)) (SUB t) dtp)
 with  (field_address0 (tarray t_dtask t) (SUB t) dtp)
 by (auto with field_compatible).
rewrite snd_Znth_fclo by lia.
rewrite !(sublist_split 0 dt dt1) by lia. rewrite !map_app.
rewrite !(split2_data_at_Tarray_app dt dt1) by list_solve.
cancel.
rewrite data__at_singleton_array_eq.
replace (field_address0 (tarray t_dtask t) (SUB t) dtp)
  with (field_address0 (tarray t_dtask T) (SUB t) dtp)
 by (auto with field_compatible).
subst inp.
rewrite !Znth_map by Zlength_solve.
rewrite Zlength_fclo by lia.
rewrite Znth_iota by lia.
fold dt. fold dt1.
replace  (field_address0 (tarray tdouble dt1) (SUB dt) p1)
  with  (field_address0 (tarray tdouble n) (SUB dt) p1)
 by (auto with field_compatible).
replace  (field_address0 (tarray tdouble dt1) (SUB dt) p2)
  with  (field_address0 (tarray tdouble n) (SUB dt) p2)
 by (auto with field_compatible).
sep_apply unmake_REMEMBER_ANSWER.
rewrite Zlength_sublist by Zlength_solve.
cancel.
Qed.

Lemma body_dotprod: semax_body Vprog Gprog f_dotprod dotprod_spec.
Proof.
start_function.
unfold tasking. Intros tp dtp.
set (n := Zlength v1) in *. rewrite <- H.
assert_PROP (field_compatible0 (tarray t_dtask T) nil dtp /\
                    field_compatible0 (tarray tdouble n) nil p1 /\
                    field_compatible0 (tarray tdouble n) nil p2) as H2 by  entailer!.
destruct H2 as [Hdtp [? ?]].
assert (Hn: 0 <= n) by rep_lia.
forward.
forward.
set (delt := delta n T) in *.
pose (nthtask i :=  ((sublist (delt i) (delt(i+1)) v1,sublist (delt i) (delt(i+1)) v2),
                             (field_address0 (tarray tdouble n) (SUB (delt i)) p1,
                              field_address0 (tarray tdouble n) (SUB (delt i)) p2))).
freeze FR1:= (data_at Ews _ _ (gv _num_threads)) (task_array _ _ _).
forward_for_simple_bound T
   (EX t:Z,
    PROP ()
    LOCAL (temp _delta (vint (delt t)); temp _T (vint T);
                gvars gv; temp _vec1 p1; temp _vec2 p2;
                temp _n (vint n))
   SEP (FRZL FR1; data_at Ews (tptr t_task) tp (gv _tasks);
          data_at Ews (tptr t_dtask) dtp (gv _dtasks);
          pred_sepcon (fun i => dtask_pred T (nthtask i) REMEMBER
                                  (field_address (tarray t_dtask T) (SUB i) dtp)) (fun i => 0 <= i < t);
          pred_sepcon (fun i => dtask_pred T (nthtask i) ASK
                                  (field_address (tarray t_dtask T) (SUB i) dtp)) (fun i => 0 <= i < t);
          data_at_ Ews (tarray t_dtask (T-t)) (field_address0 (tarray t_dtask T) (SUB t) dtp);
          data_at Ews (tarray tdouble (n-delt t)) (map Vfloat (sublist (delt t) n v1))
                       (field_address0 (tarray tdouble n) (SUB delt t) p1);
          data_at Ews (tarray tdouble (n-delt t)) (map Vfloat (sublist (delt t) n v2))
                       (field_address0 (tarray tdouble n) (SUB delt t) p2)))%assert.
-
entailer!.
rewrite !pred_sepcon_False' by lia.
unfold delt. rewrite delta_0.
rewrite !sublist_same by lia.
pose proof (Zlength_nonneg v1).
rewrite !field_address0_offset by auto with field_compatible.
simpl.  normalize.
-
rename i into t.
pose proof delta_props n T t ltac:(lia).
fold delt in H5.
forward.
forward.
replace (force_val _) with (field_address (tarray t_dtask T) (SUB t) dtp).
2:{
simpl.
rewrite field_address_offset by auto with field_compatible.
 unfold sem_add_ptr_int.
 rewrite sem_add_pi_ptr by (auto; rep_lia).
simpl. f_equal; lia.
}
rewrite (split2_data_at__Tarray_app 1 (T-t)) by lia.
rewrite (data_at__eq Ews (tarray t_dtask 1)).
erewrite data_at_singleton_array_eq by reflexivity.
simpl projT2.
Intros.
rewrite field_address0_SUB_SUB by lia.
replace (t + (T - t)) with T by lia.
replace (T - t - 1) with (T - (t+1)) by lia.
replace (1+t) with (t+1) by (clear; lia).
replace  (field_address0 (tarray t_dtask T) (SUB t) dtp)
 with  (field_address (tarray t_dtask T) (SUB t) dtp)
  by auto with field_compatible.
rewrite <- (field_at_data_at Ews (tarray t_dtask T) (SUB t)).
forward.
replace (force_val _) with (field_address0 (tarray tdouble n) (SUB delt t) p1)
 by (rewrite sem_add_pi' by (auto; rep_lia);
      rewrite field_address0_offset by auto with field_compatible;
      simpl; f_equal; lia).
forward.
replace (force_val _) with (field_address0 (tarray tdouble n) (SUB delt t) p2)
 by (rewrite sem_add_pi' by (auto; rep_lia);
      rewrite field_address0_offset by auto with field_compatible;
      simpl; f_equal; lia).
forward.
  { entailer!.
    apply repr_inj_unsigned64 in H20; try rep_lia.
    rewrite Int.unsigned_repr in H20 by rep_lia.
    lia. }
forward.
forward.
rewrite add_repr, !Int.unsigned_repr, mul64_repr  by rep_lia.
rewrite divu_repr64; [ | | rep_lia].
2:{ clear - H4 H0 Hn H1.
  assert (T * Int.max_unsigned <= Int64.max_unsigned) by rep_lia.
  split; try lia.
  eapply Z.le_trans; [ | apply H].
  apply Z.mul_le_mono_nonneg; lia.
}
fold (delta n T (t+1)).
rewrite Int64.unsigned_repr
 by (pose proof delta_props n T t ltac:(lia); rep_lia).
rewrite !(pred_sepcon_isolate t zeq _ (fun i:Z => 0 <= i < t+1)) by lia.
replace (fun y : Z => 0 <= y < t + 1 /\ y <> t)
 with (fun i : Z => 0 <= i < t)
  by (extensionality j; apply prop_ext; split; intro; lia).
replace (T - t - 1) with (T - (t+1)) by lia.
entailer!.
rewrite !(sublist_split (delt t) (delt(t+1)) (Zlength v1)) by lia.
rewrite !map_app.
 rewrite !(split2_data_at_Tarray_app (delt (t+1)-delt t)) by list_solve.
rewrite !field_address0_SUB_SUB by lia.
rewrite Z.sub_simpl_r.
replace  (Zlength v1 - delt t - (delt (t + 1) - delt t)) with (Zlength v1 - delt (t+1)) by lia.
replace (delt t + (Zlength v1 - delt t)) with (Zlength v1) by  lia.
cancel.
eapply derives_trans; [ | apply make_REMEMBER_ASK with (n:= delt (t+1) - delt t); lia].
rewrite <- (field_at_data_at Ews (tarray t_dtask T) (SUB t)).
cancel.
-
thaw FR1.
replace (delt T) with n by (unfold delt; rewrite delta_T; lia).
rewrite !Z.sub_diag.
rewrite !sublist_nil. simpl map.
rewrite data_at__eq.
change (default_val (tarray _ 0)) with (@nil (reptype t_dtask)).
rewrite !data_at_zero_array_eq by
 (try apply field_address0_isptr; auto with field_compatible).
forward.
pose (inp := (map (fun i =>
                              ((sublist (delt i) (delt(i+1)) v1,
                                sublist (delt i) (delt(i+1)) v2),
                               (field_address0 (tarray tdouble n) (SUB delt i) p1,
                                field_address0 (tarray tdouble n) (SUB delt i) p2)))
                          (iota T))).
make_func_ptr _dotprod_worker.
change (func_ptr' _) with (func_ptr' (snd dotprod_worker_spec)).
forward_call (fclo gv T dtp ,inp,tp).
  apply prop_right; rewrite Zlength_fclo by lia; reflexivity.
 2: rewrite Zlength_fclo; lia.
{
 subst Frame.
 instantiate (1 := [data_at Ews tuint (vint T) (gv _num_threads);
                   data_at Ews (tptr t_task) tp (gv _tasks);
                   data_at Ews (tptr t_dtask) dtp (gv _dtasks)]).
 simpl fold_right_sepcon.
 cancel.
 sep_apply (@sepcon_pred_sepcon mpred Z _ _ _ ).
 unfold spectasks_list.
rewrite sepcon_comm.
eapply derives_trans; [ apply distribute_pred_sepcon | ].
apply func_ptr'_emp. rewrite <- split_func_ptr'; auto.
rewrite Zlength_fclo by lia.
apply pred_sepcon_derives; intros t ?.
unfold ith_spectask.
simpl task_pred.
rewrite Zlength_fclo by lia.
unfold fclo. subst inp.
rewrite !Znth_map by list_solve. simpl.
rewrite Znth_iota by rep_lia.
fold (nthtask t).
replace  (field_address0 (tarray t_dtask T) (SUB t) dtp)
 with  (field_address (tarray t_dtask T) (SUB t) dtp)
  by auto with field_compatible.
change (func_ptr' _) with (func_ptr' (snd dotprod_worker_spec)).
cancel.
}

forward.
freeze FR2 := - (spectasks_list dtask_package (fclo gv T dtp) inp ANSWER)
   (data_at Ews (tptr t_dtask) dtp (gv _dtasks)).
unfold spectasks_list.
rewrite Zlength_fclo by lia.
forward_for_simple_bound T
  (EX t:Z,
     PROP ()
     LOCAL (temp _result (Vfloat (partial_dotprod_f t T (v1, v2)));
     temp _T (vint T); gvars gv)
     SEP (FRZL FR2;
     data_at Ews (tptr t_dtask) dtp (gv _dtasks);
     pred_sepcon
      (ith_spectask dtask_package (fclo gv T dtp) inp ANSWER)
      (fun i : Z => 0 <= i < T)))%assert.
+
entailer!.
+
rename i into t.
rewrite (pred_sepcon_isolate t zeq) by lia.
unfold ith_spectask at 2.
change task_pred with dtask_pred.
unfold dtask_pred.
subst inp.
unfold fclo.
rewrite !Znth_map, !Znth_iota by (rewrite ?Zlength_iota; lia).
simpl.
Intros.
forward.

rewrite <- field_at_SUB_t_DOT_result by (auto; lia).
forward.
deadvars!.
forward.
 pose proof delta_props (Zlength v1) T t ltac:(lia).
 fold n in H7.
 fold delt in H7.
entailer!.
*
 clear H23 H22 H21 H20 H19 H18
         H17 H16 H15 H14 H13 H12 H11 H10 H9 H8.
 f_equal.
 unfold partial_dotprod_f, dotprod_f.
 rewrite !Zlength_map, !Zlength_combine, <- H, !Z.min_id.
 rewrite iota_S by lia.
 rewrite map_app.
 change (map ?f [t]) with ([f t]).
 set (a := map _ (iota t)).
 clearbody a.
 unfold sum at 1.
 rewrite fold_left_app.
 unfold fold_left at 1.
 unfold sum at 2.
 f_equal.
 unfold dotprod.
 rewrite combine_sublist by lia.
 rewrite map_sublist.
 reflexivity.
*
rewrite (pred_sepcon_isolate t zeq _ (fun i : Z => 0 <= i < T)) by lia.
unfold ith_spectask.
rewrite Zlength_map.
rewrite !Znth_map by (rewrite Zlength_iota; lia).
rewrite !sepcon_assoc.
apply sepcon_derives.
apply derives_refl.
replace (fst (Znth t (fclo gv T dtp))) with (gv _dotprod_worker)
  by (unfold fclo; list_solve).
apply sepcon_derives.
apply derives_refl.
change task_pred with dtask_pred.
unfold dtask_pred.
simpl.
rewrite prop_true_andp
 by (rewrite Znth_iota by lia; rewrite !Zlength_sublist; lia).
rewrite !Znth_iota by lia.
rewrite !Zlength_sublist by lia.
rewrite snd_Znth_fclo by lia.
rewrite <- field_at_SUB_t_DOT_result by (auto; lia).
rewrite prop_true_andp by (split; lia).
cancel.
+

forward.
thaw FR2.
unfold tasking.
Exists tp dtp.
rewrite prop_true_andp by auto.
cancel.
rewrite <- H.
apply finish_dotprod; auto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_samesidecollinear.
Require Export GeoCoq.Elements.OriginalProofs.lemma_PGflip.
Require Export GeoCoq.Elements.OriginalProofs.proposition_41.
Require Export GeoCoq.Elements.OriginalProofs.proposition_38.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_42 :
   forall A B C D E J K,
   Triangle A B C -> nCol J D K -> Midpoint B E C ->
   exists X Z, PG X E C Z /\ EF A B E C X E C Z /\ CongA C E X J D K /\ Col X Z A.
Proof.
intros.
assert ((BetS B E C /\ Cong B E E C)) by (conclude_def Midpoint ).
assert (Cong E B E C) by (forward_using lemma_congruenceflip).
assert (nCol A B C) by (conclude_def Triangle ).
assert (Col B E C) by (conclude_def Col ).
assert (nCol B C A) by (forward_using lemma_NCorder).
assert (Col B C E) by (forward_using lemma_collinearorder).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col B C C) by (conclude_def Col ).
assert (neq E C) by (forward_using lemma_betweennotequal).
assert (nCol E C A) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists f c, (Out E C c /\ CongA f E c J D K /\ OS f A E C)) by (conclude proposition_23C);destruct Tf as [f[c]];spliter.
assert (nCol B C A) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists P Q M, (BetS P A Q /\ CongA Q A E A E B /\ CongA Q A E B E A /\ CongA E A Q B E A /\ CongA P A E A E C /\ CongA P A E C E A /\ CongA E A P C E A /\ Par P Q B C /\ Cong P A E C /\ Cong A Q B E /\ Cong A M M E /\ Cong P M M C /\ Cong B M M Q /\ BetS P M C /\ BetS B M Q /\ BetS A M E)) by (conclude proposition_31);destruct Tf as [P[Q[M]]];spliter.
assert (CongA A E C P A E) by (conclude lemma_equalanglessymmetric).
assert (nCol P A E) by (conclude lemma_equalanglesNC).
assert (nCol E A P) by (forward_using lemma_NCorder).
assert (OS A f E C) by (forward_using lemma_samesidesymmetric).
assert (nCol B C A) by (forward_using lemma_NCorder).
assert (Col B C E) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col B C B) by (conclude_def Col ).
assert (neq B E) by (forward_using lemma_betweennotequal).
assert (nCol B E A) by (conclude lemma_NChelper).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col B C C) by (conclude_def Col ).
assert (neq E C) by (forward_using lemma_betweennotequal).
assert (neq C E) by (conclude lemma_inequalitysymmetric).
assert (nCol C E A) by (conclude lemma_NChelper).
assert (neq E A) by (forward_using lemma_NCdistinct).
assert (~ ~ Meet E f P Q).
 {
 intro.
 assert (~ LtA C E f C E A).
  {
  intro.
  assert (Out E C C) by (conclude lemma_ray4).
  assert (Out E A A) by (conclude lemma_ray4).
  let Tf:=fresh in
  assert (Tf:exists m, (BetS A m C /\ Out E f m)) by (conclude lemma_crossbar2);destruct Tf as [m];spliter.
  assert (BetS C m A) by (conclude axiom_betweennesssymmetry).
  assert (BetS C M P) by (conclude axiom_betweennesssymmetry).
  assert (BetS E M A) by (conclude axiom_betweennesssymmetry).
  assert (Cong M E A M) by (conclude lemma_congruencesymmetric).
  assert (Cong E M A M) by (forward_using lemma_congruenceflip).
  assert (Cong M C P M) by (conclude lemma_congruencesymmetric).
  assert (Cong M C M P) by (forward_using lemma_congruenceflip).
  let Tf:=fresh in
  assert (Tf:exists F, (BetS E m F /\ BetS P A F)) by (conclude postulate_Euclid5);destruct Tf as [F];spliter.
  assert (Col E m F) by (conclude_def Col ).
  assert (Col m E F) by (forward_using lemma_collinearorder).
  assert (Col E f m) by (conclude lemma_rayimpliescollinear).
  assert (Col m E f) by (forward_using lemma_collinearorder).
  assert (neq E m) by (forward_using lemma_betweennotequal).
  assert (neq m E) by (conclude lemma_inequalitysymmetric).
  assert (Col E f F) by (conclude lemma_collinear4).
  assert (Col P A F) by (conclude_def Col ).
  assert (Col P A Q) by (conclude_def Col ).
  assert (neq P A) by (forward_using lemma_betweennotequal).
  assert (neq A P) by (conclude lemma_inequalitysymmetric).
  assert (Col A P F) by (forward_using lemma_collinearorder).
  assert (Col A P Q) by (forward_using lemma_collinearorder).
  assert (Col P F Q) by (conclude lemma_collinear4).
  assert (Col P Q F) by (forward_using lemma_collinearorder).
  assert (neq E f) by (conclude lemma_ray2).
  assert (neq P Q) by (forward_using lemma_betweennotequal).
  assert (Meet E f P Q) by (conclude_def Meet ).
  contradict.
  }
 assert (Col E C B) by (forward_using lemma_collinearorder).
 assert (neq B E) by (forward_using lemma_betweennotequal).
 assert (neq E B) by (conclude lemma_inequalitysymmetric).
 assert (OS A f E B) by (conclude lemma_samesidecollinear).
 assert (OS f A E B) by (forward_using lemma_samesidesymmetric).
 assert (BetS C E B) by (conclude axiom_betweennesssymmetry).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (eq f f) by (conclude cn_equalityreflexive).
 assert (nCol E B f) by (conclude_def OS ).
 assert (neq E f) by (forward_using lemma_NCdistinct).
 assert (Col B E C) by (conclude_def Col ).
 assert (Col E B C) by (forward_using lemma_collinearorder).
 assert (eq E E) by (conclude cn_equalityreflexive).
 assert (Col E B E) by (conclude_def Col ).
 assert (nCol E C f) by (conclude lemma_NChelper).
 assert (nCol C E f) by (forward_using lemma_NCorder).
 assert (~ LtA C E A C E f).
  {
  intro.
  assert (Out E A A) by (conclude lemma_ray4).
  assert (Out E f f) by (conclude lemma_ray4).
  assert (Supp C E A A B) by (conclude_def Supp ).
  assert (Supp C E f f B) by (conclude_def Supp ).
  assert (LtA f E B A E B) by (conclude lemma_supplementinequality).
  assert (nCol B E f) by (forward_using lemma_NCorder).
  assert (CongA B E f f E B) by (conclude lemma_ABCequalsCBA).
  assert (LtA B E f A E B) by (conclude lemma_angleorderrespectscongruence2).
  assert (CongA B E A A E B) by (conclude lemma_ABCequalsCBA).
  assert (LtA B E f B E A) by (conclude lemma_angleorderrespectscongruence).
  assert (Out E B B) by (conclude lemma_ray4).
  assert (Out E A A) by (conclude lemma_ray4).
  let Tf:=fresh in
  assert (Tf:exists m, (BetS A m B /\ Out E f m)) by (conclude lemma_crossbar2);destruct Tf as [m];spliter.
  assert (BetS B m A) by (conclude axiom_betweennesssymmetry).
  assert (BetS E M A) by (conclude axiom_betweennesssymmetry).
  assert (Cong M E A M) by (conclude lemma_congruencesymmetric).
  assert (Cong E M A M) by (forward_using lemma_congruenceflip).
  assert (Cong M B M Q) by (forward_using lemma_congruenceflip).
  assert (nCol P A E) by (forward_using lemma_NCorder).
  assert (Col P A Q) by (conclude_def Col ).
  assert (eq A A) by (conclude cn_equalityreflexive).
  assert (Col P A A) by (conclude_def Col ).
  assert (neq A Q) by (forward_using lemma_betweennotequal).
  assert (neq Q A) by (conclude lemma_inequalitysymmetric).
  assert (nCol Q A E) by (conclude lemma_NChelper).
  assert (nCol E A Q) by (forward_using lemma_NCorder).
  let Tf:=fresh in
  assert (Tf:exists F, (BetS E m F /\ BetS Q A F)) by (conclude postulate_Euclid5);destruct Tf as [F];spliter.
  assert (Col E m F) by (conclude_def Col ).
  assert (Col m E F) by (forward_using lemma_collinearorder).
  assert (Col E f m) by (conclude lemma_rayimpliescollinear).
  assert (Col m E f) by (forward_using lemma_collinearorder).
  assert (neq E m) by (forward_using lemma_betweennotequal).
  assert (neq m E) by (conclude lemma_inequalitysymmetric).
  assert (Col E f F) by (conclude lemma_collinear4).
  assert (Col Q A F) by (conclude_def Col ).
  assert (BetS Q A P) by (conclude axiom_betweennesssymmetry).
  assert (Col Q A P) by (conclude_def Col ).
  assert (neq Q A) by (forward_using lemma_betweennotequal).
  assert (neq A Q) by (conclude lemma_inequalitysymmetric).
  assert (Col A Q F) by (forward_using lemma_collinearorder).
  assert (Col A Q P) by (forward_using lemma_collinearorder).
  assert (Col Q F P) by (conclude lemma_collinear4).
  assert (Col P Q F) by (forward_using lemma_collinearorder).
  assert (neq E f) by (conclude lemma_ray2).
  assert (neq Q P) by (forward_using lemma_betweennotequal).
  assert (neq P Q) by (conclude lemma_inequalitysymmetric).
  assert (Meet E f P Q) by (conclude_def Meet ).
  contradict.
  }
 assert (~ ~ CongA C E A C E f).
  {
  intro.
  assert (LtA C E A C E f) by (conclude lemma_angletrichotomy2).
  contradict.
  }
 let Tf:=fresh in
 assert (Tf:exists d a p q, (Out E C d /\ Out E A a /\ Out E C p /\ Out E f q /\ Cong E d E p /\ Cong E a E q /\ Cong d a p q /\ nCol C E A))
  by (remove_double_neg;unfold CongA in *; assumption);destruct Tf as [d[a[p[q]]]];spliter.
 assert (Col P Q A) by (conclude_def Col ).
 assert (eq d p) by (conclude lemma_layoffunique).
 assert (Cong d a d q) by (conclude cn_equalitysub).
 assert (Cong a d q d) by (forward_using lemma_congruenceflip).
 assert (Cong a E q E) by (forward_using lemma_congruenceflip).
 assert (neq E d) by (conclude lemma_raystrict).
 assert (Col E C d) by (conclude lemma_rayimpliescollinear).
 assert (OS A f E d) by (conclude lemma_samesidecollinear).
 assert (Col E d E) by (conclude_def Col ).
 assert (Col E E d) by (forward_using lemma_collinearorder).
 assert (OS A q E d) by (conclude lemma_sameside2).
 assert (OS q A E d) by (forward_using lemma_samesidesymmetric).
 assert (OS q a E d) by (conclude lemma_sameside2).
 assert (OS a q E d) by (forward_using lemma_samesidesymmetric).
 assert (eq a q) by (conclude proposition_07).
 assert (Col E A a) by (conclude lemma_rayimpliescollinear).
 assert (Col E f q) by (conclude lemma_rayimpliescollinear).
 assert (Col E A q) by (conclude cn_equalitysub).
 assert (Col q E A) by (forward_using lemma_collinearorder).
 assert (Col q E f) by (forward_using lemma_collinearorder).
 assert (neq E q) by (conclude lemma_raystrict).
 assert (neq q E) by (conclude lemma_inequalitysymmetric).
 assert (Col E A f) by (conclude lemma_collinear4).
 assert (Col E f A) by (forward_using lemma_collinearorder).
 assert (neq P Q) by (forward_using lemma_betweennotequal).
 assert (Meet E f P Q) by (conclude_def Meet ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists F, (neq E f /\ neq P Q /\ Col E f F /\ Col P Q F)) by (conclude_def Meet );destruct Tf as [F];spliter.
assert (neq C E) by (conclude lemma_inequalitysymmetric).
assert (Par P Q E C) by (conclude lemma_collinearparallel).
assert (Par E C P Q) by (conclude lemma_parallelsymmetric).
let Tf:=fresh in
assert (Tf:exists G, (PG F G C E /\ Col P Q G)) by (conclude lemma_triangletoparallelogram);destruct Tf as [G];spliter.
assert (PG G F E C) by (conclude lemma_PGflip).
assert (PG F E C G) by (conclude lemma_PGrotate).
assert (Col P A Q) by (conclude_def Col ).
assert (Col P Q A) by (forward_using lemma_collinearorder).
assert (Par F E C G) by (conclude_def PG ).
assert (nCol F E G) by (forward_using lemma_parallelNC).
assert (neq F G) by (forward_using lemma_NCdistinct).
assert (Col F G A) by (conclude lemma_collinear5).
assert (ET F E C A E C) by (conclude proposition_41).
assert (Par P Q C B) by (forward_using lemma_parallelflip).
assert (Col C B E) by (forward_using lemma_collinearorder).
assert (neq E B) by (conclude lemma_inequalitysymmetric).
assert (Par P Q E B) by (conclude lemma_collinearparallel).
assert (Par P Q B E) by (forward_using lemma_parallelflip).
assert (Cong B E E C) by (forward_using lemma_congruenceflip).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (Col B E E) by (conclude_def Col ).
assert (ET A B E A E C) by (conclude proposition_38).
assert (ET A E C A B E) by (conclude axiom_ETsymmetric).
assert (ET A E C A E B) by (forward_using axiom_ETpermutation).
assert (ET A E B A E C) by (conclude axiom_ETsymmetric).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (Col A E E) by (conclude_def Col ).
assert (nCol A E B) by (forward_using lemma_NCorder).
assert (TS B A E C) by (conclude_def TS ).
assert (PG E F G C) by (conclude lemma_PGflip).
assert (Cong_3 F E C C G F) by (conclude proposition_34).
assert (ET F E C C G F) by (conclude axiom_congruentequal).
assert (ET F E C F C G) by (forward_using axiom_ETpermutation).
assert (ET F C G F E C) by (conclude axiom_ETsymmetric).
assert (ET F C G F C E) by (forward_using axiom_ETpermutation).
assert (ET F C E F C G) by (conclude axiom_ETsymmetric).
let Tf:=fresh in
assert (Tf:exists m, (BetS E m G /\ BetS F m C)) by (conclude lemma_diagonalsmeet);destruct Tf as [m];spliter.
assert (Col F m C) by (conclude_def Col ).
assert (Col F C m) by (forward_using lemma_collinearorder).
assert (Par F E C G) by (conclude_def PG ).
assert (nCol F E C) by (forward_using lemma_parallelNC).
assert (nCol F C E) by (forward_using lemma_NCorder).
assert (TS E F C G) by (conclude_def TS ).
assert (ET A E C F E C) by (conclude axiom_ETsymmetric).
assert (ET A E B F E C) by (conclude axiom_ETtransitive).
assert (ET A E B F C E) by (forward_using axiom_ETpermutation).
assert (ET A E C F E C) by (conclude axiom_ETsymmetric).
assert (ET F C G F C E) by (conclude axiom_ETsymmetric).
assert (ET F C G F E C) by (forward_using axiom_ETpermutation).
assert (ET F E C F C G) by (conclude axiom_ETsymmetric).
assert (ET A E C F C G) by (conclude axiom_ETtransitive).
assert (EF A B E C F E C G) by (conclude axiom_paste3).
assert (nCol F E C) by (forward_using lemma_parallelNC).
assert (nCol C E F) by (forward_using lemma_NCorder).
assert (CongA C E F C E F) by (conclude lemma_equalanglesreflexive).
assert ((eq E f \/ eq E F \/ eq f F \/ BetS f E F \/ BetS E f F \/ BetS E F f)) by (conclude_def Col ).
assert (neq F E) by (forward_using lemma_NCdistinct).
assert (neq E F) by (conclude lemma_inequalitysymmetric).
assert (Out E F f).
by cases on (eq E f \/ eq E F \/ eq f F \/ BetS f E F \/ BetS E f F \/ BetS E F f).
{
 assert (~ ~ Out E F f).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ Out E F f).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (eq F F) by (conclude cn_equalityreflexive).
 assert (Out E F F) by (conclude lemma_ray4).
 assert (Out E F f) by (conclude cn_equalitysub).
 close.
 }
{
 assert (~ ~ Out E F f).
  {
  intro.
  assert (eq E E) by (conclude cn_equalityreflexive).
  assert (Col E C E) by (conclude_def Col ).
  assert (BetS F E f) by (conclude axiom_betweennesssymmetry).
  assert (nCol E C F) by (forward_using lemma_NCorder).
  assert (TS F E C f) by (conclude_def TS ).
  assert (TS f E C F) by (conclude lemma_oppositesidesymmetric).
  assert (OS A f E C) by (forward_using lemma_samesidesymmetric).
  assert (TS A E C F) by (conclude lemma_planeseparation).
  let Tf:=fresh in
  assert (Tf:exists j, (BetS A j F /\ Col E C j /\ nCol E C A)) by (conclude_def TS );destruct Tf as [j];spliter.
  assert (Col A j F) by (conclude_def Col ).
  assert (neq P Q) by (forward_using lemma_betweennotequal).
  assert (neq Q P) by (conclude lemma_inequalitysymmetric).
  assert (Col Q A F) by (conclude lemma_collinear4).
  assert (Col A F Q) by (forward_using lemma_collinearorder).
  assert (Col Q P A) by (forward_using lemma_collinearorder).
  assert (Col Q P F) by (forward_using lemma_collinearorder).
  assert (Col P A F) by (conclude lemma_collinear4).
  assert (Col A F P) by (forward_using lemma_collinearorder).
  assert (Col A F j) by (forward_using lemma_collinearorder).
  assert (neq P Q) by (forward_using lemma_betweennotequal).
  assert (neq A F) by (forward_using lemma_betweennotequal).
  assert (Col P Q j) by (conclude lemma_collinear5).
  assert (Meet P Q E C) by (conclude_def Meet ).
  assert (~ Meet P Q E C) by (conclude_def Par ).
  contradict.
  }
 close.
 }
{
 assert (Out E F f) by (conclude lemma_ray4).
 close.
 }
{
 assert (Out E F f) by (conclude lemma_ray4).
 close.
 }
(** cases *)
assert (CongA C E F c E f) by (conclude lemma_equalangleshelper).
assert (CongA F E C f E c) by (conclude lemma_equalanglesflip).
assert (CongA F E C J D K) by (conclude lemma_equalanglestransitive).
assert (CongA C E F F E C) by (conclude lemma_ABCequalsCBA).
assert (CongA C E F J D K) by (conclude lemma_equalanglestransitive).
close.
Qed.

End Euclid.