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

(** * Codes as association lists and some of their properties

- Key definitions: [code], [encode], [decode], [find_code], [find_val],
  [in_alphabet], [unique_prefix], [not_null]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Bool.
From Coq Require Import Sorting.Permutation.
From Huffman Require Export AuxLib UniqueKey Frequency.

Set Default Proof Using "Type".

Section Code.
Variable A : Type.
Variable A_eq_dec : forall a b : A, {a = b} + {a <> b}.

#[local] Hint Constructors Permutation : core.
#[local] Hint Resolve Permutation_refl : core.
#[local] Hint Resolve Permutation_app : core.
#[local] Hint Resolve Permutation_app_swap : core.

(** A code is an association list *)
Definition code := list (A * list bool).

(**
  Predicate that tells that a message (a list of message) is in the
  alphabet of the code
*)
Definition in_alphabet (m : list A) (c : code) :=
  forall a : A, In a m -> exists l : list bool, In (a, l) c.

(** Being in an alphabet is compatible with inclusion *)
Theorem in_alphabet_incl :
 forall m1 m2 c, incl m1 m2 -> in_alphabet m2 c -> in_alphabet m1 c.
Proof.
intros m1 m2 c H H0; red in |- *.
intros a H1; case (H0 a); auto.
Qed.

(** Every code is in the alphabet of an empty message *)
Theorem in_alphabet_nil : forall c, in_alphabet [] c.
Proof.
intros c a H; inversion H.
Qed.
#[local] Hint Resolve in_alphabet_nil : core.

(** An element can be added in the message if it is in the code *)
Theorem in_alphabet_cons :
 forall (m : list A) c a ca,
 In (a, ca) c -> in_alphabet m c -> in_alphabet (a :: m) c.
Proof.
intros m c a ca H H0; red in |- *; simpl in |- *.
intros a1 [H1| H1].
exists ca; rewrite <- H1; auto.
case (H0 a1); auto.
Qed.
#[local] Hint Resolve in_alphabet_cons : core.

(** Inversion theorem *)
Theorem in_alphabet_inv :
 forall (c : code) (a : A) (l : list A),
 in_alphabet (a :: l) c -> in_alphabet l c.
Proof.
intros c a l H; red in |- *.
intros a1 H1; apply H; simpl in |- *; auto.
Qed.

Definition code_dec :
  forall (c : code) a,
  {(exists l : list bool, In (a, l) c)} +
  {(forall l : list bool, ~ In (a, l) c)}.
intros c a; elim c; simpl in |- *; auto.
intros (a1, l1) l H; case (A_eq_dec a1 a); intros H1.
left; exists l1; rewrite H1; auto.
case H.
intros e; left; case e; intros l2 H2; exists l2; auto.
intros n; right; intros l0; red in |- *; intros [H0| H0];
 [ case H1 | case (n l0) ]; auto.
injection H0; auto.
Defined.

(** Checking if a code is in an alphabet is decidable *)
Definition in_alphabet_dec :
  forall m c, {in_alphabet m c} + {~ in_alphabet m c}.
intros m; elim m; simpl in |- *; auto.
intros a l H c; case (H c); intros H1.
case (code_dec c a); intros H2.
left; red in |- *; simpl in |- *.
intros a1 [H3| H3];
 [ case H2; intros l1 Hl1; exists l1; rewrite <- H3 | idtac ];
 auto.
right; red in |- *; intros H3; case (H3 a); simpl in |- *; auto.
right; contradict H1; auto; red in |- *.
intros a0 H0; case (H1 a0); simpl in |- *; auto.
intros x H2; exists x; auto.
Defined.

(** The empty list is associated to none of element of A in the code *)
Definition not_null (c : code) := forall a : A, ~ In (a, []) c.

(** Inversion theorem *)
Theorem not_null_inv :
 forall (a : A * list bool) l, not_null (a :: l) -> not_null l.
Proof.
intros a l H; red in |- *.
intros a0; red in |- *; intros H0; case (H a0); simpl in |- *; auto.
Qed.

(** Adding a non-empty element preserves the property of non-emptyness *)
Theorem not_null_cons :
 forall a b (l : list (A * list bool)),
 b <> [] -> not_null l -> not_null ((a, b) :: l).
Proof.
intros a b l H H0; red in |- *.
intros a1; simpl in |- *; red in |- *; intros [H1| H1]; auto.
case H; injection H1; auto.
case (H0 a1); simpl in |- *; auto.
Qed.
#[local] Hint Resolve not_null_cons : core.

(** Non emptyness is compatible with append *)
Theorem not_null_app :
 forall l1 l2 : list (A * list bool),
 not_null l1 -> not_null l2 -> not_null (l1 ++ l2).
Proof.
intros l1; elim l1; simpl in |- *; auto.
intros (a2, l2); case l2; auto.
intros l H l0 H0 H1; case (H0 a2); simpl in |- *; auto.
intros b l l0 H l3 H0 H1; apply not_null_cons; auto.
red in |- *; intros H2; discriminate.
apply H; auto.
apply not_null_inv with (1 := H0).
Qed.
#[local] Hint Resolve not_null_app : core.

(** Adding an element in each component of a code makes it non-empty *)
Theorem not_null_map :
 forall (l : list (A * list bool)) b,
 not_null (map (fun v => match v with
                         | (a1, b1) => (a1, b :: b1)
                         end) l).
Proof.
intros l; elim l; simpl in |- *; auto.
intros b; red in |- *; intros a; red in |- *; intros H; inversion H.
intros (a1, l1) l0 H b; apply not_null_cons; auto.
red in |- *; intros; discriminate.
Qed.
#[local] Hint Resolve not_null_map : core.

(** Define the property of list of booleans to be a prefix of another *)
Inductive is_prefix : list bool -> list bool -> Prop :=
  | prefixNull : forall l, is_prefix [] l
  | prefixCons :
      forall (b : bool) l1 l2,
      is_prefix l1 l2 -> is_prefix (b :: l1) (b :: l2).
#[local] Hint Constructors is_prefix : core.

(** A list is a prefix of itself *)
Theorem is_prefix_refl : forall l, is_prefix l l.
Proof.
intros l; elim l; simpl in |- *; auto.
Qed.
#[local] Hint Resolve is_prefix_refl : core.

(** A code is a unique prefix if there is no encoding that is a prefix of another *)
Definition unique_prefix (l : code) :=
  (forall (a1 a2 : A) (lb1 lb2 : list bool),
   In (a1, lb1) l -> In (a2, lb2) l -> is_prefix lb1 lb2 -> a1 = a2) /\
  unique_key l.

(** The empty code is unique prefix *)
Theorem unique_prefix_nil : unique_prefix [].
Proof.
split; auto.
intros a1 a2 lb1 lb2 H; inversion H; auto.
Qed.
#[local] Hint Resolve unique_prefix_nil : core.

(** A unique prefix code can not have two elements prefix one from another *)
Theorem unique_prefix1 :
 forall (c : code) (a1 a2 : A) (lb1 lb2 : list bool),
 unique_prefix c ->
 In (a1, lb1) c -> In (a2, lb2) c -> is_prefix lb1 lb2 -> a1 = a2.
Proof.
intros c a1 a2 lb1 lb2 (H1, H2); apply (H1 a1 a2 lb1 lb2); auto.
Qed.

(** A unique prefix code has unique keys *)
Theorem unique_prefix2 : forall c : code, unique_prefix c -> unique_key c.
Proof.
intros c (H1, H2); auto.
Qed.

(** Inversion theorem *)
Theorem unique_prefix_inv :
 forall (c : code) (a : A) (l : list bool),
 unique_prefix ((a, l) :: c) -> unique_prefix c.
Proof.
intros c a l (H1, H2); split.
intros a1 a2 lb1 lb2 H H0 H3; apply (H1 a1 a2 lb1 lb2); simpl in |- *; auto.
apply unique_key_inv with (1 := H2); auto.
Qed.

(** A prefix code with a  least two distinct elements is not_null *)
Theorem unique_prefix_not_null :
 forall (c : code) (a b : A),
 a <> b -> in_alphabet (a :: b :: []) c -> unique_prefix c -> not_null c.
Proof.
intros c a b H H0 H1.
unfold not_null in |- *; intros a1; red in |- *; intros Ha1.
case (H0 a); simpl in |- *; auto; intros l1 Hl1.
case (H0 b); simpl in |- *; auto; intros l2 Hl2.
case H; apply trans_equal with a1.
apply sym_equal; apply unique_prefix1 with (3 := Hl1) (2 := Ha1); auto.
apply unique_prefix1 with (3 := Hl2) (2 := Ha1); auto.
Qed.

(** Unique prefix is preserved by permutation *)
Theorem unique_prefix_permutation :
 forall c1 c2 : code,
 Permutation c1 c2 -> unique_prefix c1 -> unique_prefix c2.
Proof.
intros c1 c2 H (H1, H2).
cut (Permutation c2 c1); [ intros HP; split | apply Permutation_sym; auto ].
intros a1 a2 lb1 lb2 H0 H3 H4.
apply (H1 a1 a2 lb1 lb2); auto.
apply Permutation_in with (2 := H0); auto.
apply Permutation_in with (2 := H3); auto.
apply unique_key_perm with (2 := H2); auto.
Qed.

(**
  Find the list of booleans associated with an element,
  return the empty list if the element does not exists
*)
Fixpoint find_code (a : A) (l : code) {struct l} : list bool :=
  match l with
  | [] => []
  | (b, c) :: l1 =>
      match A_eq_dec a b with
      | left _ => c
      | right _ => find_code a l1
      end
  end.

(** The result of find_code is in the code *)
Theorem find_code_correct1 :
 forall (c : code) (a : A) (b : bool) (l : list bool),
 find_code a c = b :: l -> In (a, b :: l) c.
Proof.
intros c a b l; elim c; simpl in |- *; auto.
intros; discriminate.
intros a0; case a0.
intros a1; case (A_eq_dec a a1); simpl in |- *; auto.
intros e l0 l1 H H0; left;
 apply f_equal2 with (f := pair (A:=A) (B:=list bool));
 auto.
Qed.

(** What is in the code can be found by find_code *)
Theorem find_code_correct2 :
 forall (c : code) (a : A) (l : list bool),
 unique_key c -> In (a, l) c -> find_code a c = l.
Proof.
intros c a l; generalize a l; elim c; clear a l c; simpl in |- *; auto.
intros a l H H0; case H0.
intros a; case a.
intros a0 l l0 H a1 l1 H0 H1; case (A_eq_dec a1 a0).
intros H2; case H1; intros H3.
injection H3; auto.
apply unique_key_in_inv with (l := (a0, l) :: l0) (a := a0); simpl in |- *;
 auto.
rewrite <- H2; auto.
intros H2; case H1; auto.
intros H3; case H2; injection H3; auto.
intros; apply H; auto.
apply unique_key_inv with (1 := H0); auto.
Qed.

(** There is not more than what is in the code *)
Theorem not_in_find_code :
 forall a l, (forall p, ~ In (a, p) l) -> find_code a l = [].
Proof.
intros a l; elim l; simpl in |- *; auto.
intros (a1, l1) l0 H H0.
case (A_eq_dec a a1); auto.
intros H1; case (H0 l1); rewrite H1; auto.
intros H1; apply H; intros p; red in |- *; intros Hp; case (H0 p); auto.
Qed.

(** find_code is composed by append *)
Theorem find_code_app :
 forall a l1 l2,
 not_null l1 ->
 find_code a (l1 ++ l2) =
 match find_code a l1 with
 | [] => find_code a l2
 | b1 :: l3 => b1 :: l3
 end.
Proof.
intros a l1; generalize a; elim l1; simpl in |- *; auto; clear a l1.
intros (a1, l1) l H a l2 H1; case (A_eq_dec a a1); auto.
generalize H1; case l1; auto.
intros H0; case (H0 a1); simpl in |- *; auto.
cut (not_null l); simpl in |- *; auto.
apply not_null_inv with (1 := H1); auto.
Qed.

(** find_code is invariant under permutation *)
Theorem find_code_permutation :
 forall (a : A) (c1 c2 : code),
 Permutation c1 c2 -> unique_prefix c1 -> find_code a c1 = find_code a c2.
Proof.
intros a c1 c2 H; elim H; simpl in |- *; auto.
intros a0; case a0.
intros a1; case (A_eq_dec a a1); auto.
intros n l L1 L2 H0 H1 H2; apply H1.
apply unique_prefix_inv with (1 := H2).
intros a0; case a0.
intros a1 l1.
case (A_eq_dec a a1).
intros Ha1 b; case b; auto.
intros a2 l2 L HL; case (A_eq_dec a a2); auto.
intros e.
case unique_key_in with (1 := unique_prefix2 _ HL) (b2 := l1); auto.
rewrite <- Ha1; rewrite e; simpl in |- *; auto.
intros Ha1 b; case b; auto.
intros L1 L2 L3 H0 H1 H2 H3 H4; apply trans_equal with (find_code a L2); auto.
apply H3.
apply (unique_prefix_permutation _ _ H0); auto.
Qed.

(**
  Searching in a list with a common first element is equivalent
  to the search skipping the element
*)
Theorem in_find_map :
 forall p a l b,
 In (a, l) p ->
 find_code a
   (map
      (fun v : A * list bool => match v with
                          | (a1, b1) => (a1, b :: b1)
                          end) p) = b :: find_code a p.
Proof.
intros p; elim p; simpl in |- *; auto.
intros a l b H; case H.
intros (a1, l1) l H a0 l0 b [H0| H0]; auto.
case (A_eq_dec a0 a1); auto.
intros HH; case HH; injection H0; auto.
case (A_eq_dec a0 a1); auto.
intros n; apply (H a0 l0 b); auto.
Qed.

(**
  Searching in a list with a common first element is equivalent
  to the search skipping the element
*)
Theorem not_in_find_map :
 forall p a b,
 (forall l, ~ In (a, l) p) ->
 find_code a
   (map
      (fun v : A * list bool => match v with
                                | (a1, b1) => (a1, b :: b1)
                                end) p) = [].
Proof.
intros p; elim p; simpl in |- *; auto.
intros (a1, l1) l H a0 b H0; case (A_eq_dec a0 a1); auto.
intros e; case (H0 l1); rewrite e; auto.
intros n; apply (H a0 b); auto.
intros l0; red in |- *; intros H1; case (H0 l0); auto.
Qed.

(**
  Find the element associated with a list of booleans,
  return None if it does not exist in the code
*)
Fixpoint find_val (a : list bool) (l : code) {struct l} : option A :=
  match l with
  | [] => None
  | (b, c) :: l1 =>
      match list_eq_dec Bool.bool_dec a c with
      | left _ => Some b
      | right _ => find_val a l1
      end
  end.

(** find_val returns an element of the code *)
Theorem find_val_correct1 :
 forall (c : code) (a : A) (l : list bool),
 find_val l c = Some a -> In (a, l) c.
Proof.
intros c a l; elim c; simpl in |- *; auto.
intros; discriminate.
intros a0; case a0.
intros a1 l0 l1; case (list_eq_dec Bool.bool_dec l l0); auto.
intros e H H0; injection H0.
intros e1; left; apply f_equal2 with (f := pair (A:=A) (B:=list bool)); auto.
Qed.

(** An element of the code can be found by find_val *)
Theorem find_val_correct2 :
 forall (c : code) (a : A) (l : list bool),
 unique_prefix c -> In (a, l) c -> find_val l c = Some a.
Proof.
intros c a l; generalize a l; elim c; clear a l c; simpl in |- *; auto.
intros a l H H0; case H0.
intros a; case a.
intros a0 l l0 H a1 l1 H0 H1; case (list_eq_dec Bool.bool_dec l1 l).
intros H2; apply f_equal with (f := Some (A:=A)).
case H1; intros H3.
injection H3; auto.
apply unique_prefix1 with (1 := H0) (lb1 := l) (lb2 := l1); simpl in |- *;
 auto.
rewrite H2; auto.
intros H2; case H1; auto.
intros H3; case H2; injection H3; auto.
intros; apply H; auto.
apply unique_prefix_inv with (1 := H0); auto.
Qed.

Opaque list_eq_dec.

(** The value of an empty list cannot be found in a non empty code *)
Theorem not_null_find_val :
 forall c : code, not_null c -> find_val [] c = None.
Proof.
intros c; elim c; simpl; auto.
intros a; case a.
intros a1 l; case (list_eq_dec Bool.bool_dec [] l); auto.
intros e l0 H H0; case (H0 a1); rewrite e; simpl in |- *; auto.
intros n l0 H H0; apply H.
unfold not_null in |- *; intros a2; red in |- *; intros H1.
case (H0 a2); simpl in |- *; auto.
Qed.

(** Encoding is done by iteratively applying find_code *)
Fixpoint encode (c : code) (m : list A) {struct m} : list bool :=
  match m with
  | [] => []
  | a :: b => find_code a c ++ encode c b
  end.

(** Encoding can be splitted for appended lists *)
Theorem encode_app :
 forall l1 l2 c, encode c (l1 ++ l2) = encode c l1 ++ encode c l2.
Proof.
intros l1; elim l1; simpl in |- *; auto.
intros a l H l2 c; rewrite H; auto.
rewrite app_ass; auto.
Qed.

(** Inversion theorem for encode *)
Theorem encode_cons_inv :
 forall a l1 l m1, ~ In a m1 -> encode ((a, l1) :: l) m1 = encode l m1.
Proof.
intros a l1 l m1; generalize a l1 l; elim m1; simpl in |- *; auto;
 clear a l1 l m1.
intros a l H a0 l1 l0 H0; case (A_eq_dec a a0); simpl in |- *; auto.
intros H1; case H0; auto.
intros e; rewrite H; auto.
Qed.

(** The encoding does not depend of permutation *)
Theorem encode_permutation :
 forall (m : list A) (c1 c2 : code),
 Permutation c1 c2 -> unique_prefix c1 -> encode c1 m = encode c2 m.
Proof.
intros m; elim m; simpl in |- *; auto.
intros a l H c1 c2 H0 H1.
apply f_equal2 with (f := app (A:=bool)); auto.
apply find_code_permutation; auto.
Qed.

(** Permuting the message permutes the encoding *)
Theorem encode_permutation_val :
 forall m1 m2 c, Permutation m1 m2 -> Permutation (encode c m1) (encode c m2).
Proof.
intros m1 m2 c H; elim H; simpl in |- *; auto; clear H m1 m2.
intros; repeat rewrite <- app_ass; auto.
intros l1 l2 l3 H H0 H1 H2; apply Permutation_trans with (1 := H0); auto.
Qed.

(**
  To decode, first find the initial section of
  booleans that maps an encoding, this initial section is
  accumulated in the head
*)
Fixpoint decode_aux (c : code) (head m : list bool) {struct m} : list A :=
  match m with
  | [] => match find_val head c with
           | Some a => a :: []
           | None => []
           end
  | a :: m1 =>
      match find_val head c with
      | Some a1 => a1 :: decode_aux c (a :: []) m1
      | None => decode_aux c (head ++ a :: []) m1
      end
  end.

(** decode_aux is correct *)
Theorem decode_aux_correct :
 forall c : code,
 unique_prefix c ->
 not_null c ->
 forall (m1 m2 head : list bool) (a : A),
 find_val (head ++ m1) c = Some a ->
 decode_aux c head (m1 ++ m2) = a :: decode_aux c [] m2.
Proof.
intros c Hc1 Hc2 m1; elim m1; simpl in |- *; auto.
intros m2; case m2; simpl in |- *; auto.
intros head a; rewrite <- app_nil_end.
intros H1; rewrite H1; auto.
rewrite not_null_find_val; auto.
intros b l head a; rewrite <- app_nil_end.
intros H1; rewrite H1; auto.
rewrite not_null_find_val; auto.
intros a l Rec m2 head a1 H2.
rewrite <- Rec with (head := head ++ a :: []).
generalize (fun a => find_val_correct1 c a head).
case (find_val head c); auto.
intros a0 H; (cut (In (a0, head) c); [ intros Hin1 | auto ]).
cut (In (a1, head ++ a :: l) c);
 [ intros Hin2 | apply find_val_correct1; auto ].
cut (a1 = a0); [ intros Heq | idtac ].
absurd (head ++ a :: l = head); auto.
elim head; simpl in |- *; auto.
red in |- *; intros; discriminate.
intros a2 l0 H0; red in |- *; intros H1; case H0; auto.
injection H1; auto.
apply unique_key_in_inv with (l := c) (a := a1); auto.
apply unique_prefix2; auto.
rewrite Heq; auto.
apply sym_equal; apply (unique_prefix1 c a0 a1 head (head ++ a :: l)); auto.
elim head; simpl in |- *; auto.
rewrite app_ass; auto.
Qed.

(** Decode is just decode_aux with an empty head *)
Definition decode (c : list (A * list bool)) (m : list bool) :=
  decode_aux c [] m.

(** Decoding is correct *)
Theorem decode_correct :
 forall c : code,
 unique_prefix c ->
 not_null c ->
 forall (m1 m2 : list bool) (a : A),
 find_val m1 c = Some a -> decode c (m1 ++ m2) = a :: decode c m2.
Proof.
intros c H H0 m1 m2 a H1; unfold decode in |- *; apply decode_aux_correct;
 auto.
Qed.

(** Encoding and decoding return the same message if the code is prefix *)
Theorem correct_encoding :
 forall c : code,
 unique_prefix c ->
 not_null c ->
 forall m : list A, in_alphabet m c -> decode c (encode c m) = m.
Proof.
intros c H1 H2 m; elim m; simpl in |- *; auto.
intros H3; unfold decode in |- *; simpl in |- *.
rewrite not_null_find_val; auto.
intros a l H H0; rewrite decode_correct with (a := a); auto.
apply f_equal2 with (f := cons (A:=A)); auto.
apply H; apply in_alphabet_inv with (1 := H0); auto.
case (H0 a); simpl in |- *; auto.
intros l1 Hl1.
apply find_val_correct2; auto.
case (H0 a); simpl in |- *; auto.
intros x1; case x1.
intros H3; case (H2 a); auto.
intros b l0 H3; cut (find_code a c = b :: l0).
intros H4; rewrite H4; apply find_code_correct1; auto.
apply find_code_correct2 with (2 := H3); auto.
case H1; auto.
Qed.

(** A unique prefix code in an alphabet of at least 2 elements is non-empty *)
Theorem frequency_not_null :
 forall m (c : code),
 1 < length (frequency_list A_eq_dec m) ->
 unique_prefix c -> in_alphabet m c -> not_null c.
Proof.
intros m c H H0 H1.
case_eq (frequency_list A_eq_dec m); auto.
intros H2; rewrite H2 in H; contradict H; simpl in |- *; auto with arith.
intros p l; case p; case l; simpl in |- *; auto.
intros a n H2; rewrite H2 in H; contradict H; simpl in |- *; auto with arith.
intros p0 l0; case p0; intros b nb a na H2.
apply unique_prefix_not_null with a b; auto.
intros H3; absurd (In (fst (a, na)) (fst (b, nb) :: map (fst (B:=_)) l0)).
cut (NoDup (map (fst (B:=_)) (frequency_list A_eq_dec m))).
rewrite H2; simpl in |- *; intros H4; inversion H4.
case H7; rewrite H3; auto with datatypes.
apply unique_key_NoDup.
apply frequency_list_unique.
simpl in |- *; rewrite H3; auto with datatypes.
case (H1 a); auto.
apply frequency_list_in with A_eq_dec na; rewrite H2; auto with datatypes.
intros l1 Hl1; apply in_alphabet_cons with l1; auto.
case (H1 b); auto.
apply frequency_list_in with A_eq_dec nb; rewrite H2; auto with datatypes.
intros l2 Hl2; apply in_alphabet_cons with l2; auto.
Qed.

End Code.
Arguments encode [A].
Arguments decode [A].
Arguments find_code [A].
Arguments find_val [A].
Arguments in_alphabet [A].
Arguments unique_prefix [A].
Arguments not_null [A].
#[export] Hint Constructors is_prefix : core.
#[export] Hint Resolve is_prefix_refl : core.
#[export] Hint Resolve not_null_map : core.
#[export] Hint Resolve unique_prefix_nil : core.
#[export] Hint Resolve in_alphabet_nil in_alphabet_cons : core.
#[export] Hint Resolve not_null_app : core.


From Coq Require Export Morphisms Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts HeterogeneousRelations.
From Coq Require Export Eqdep EqdepFacts.

Ltac inj_existT := repeat match goal with | H : existT _ _ _ = _ |- _ => apply inj_pair2 in H end.

Notation Rel A B := (A -> B -> Prop).

Definition depProdRel {A B} (RR1 : Rel A B)
  (RR2 : forall a b, RR1 a b -> Prop) : Rel A B :=
  fun r1 r2 => { p : RR1 r1 r2 | RR2 r1 r2 p }.

Notation PreRel E1 E2 := (forall (A B : Type), (E1 A : Type) -> (E2 B : Type) -> Prop).

(*this is stronger than we need *)
Class ReflexivePreRel {E : Type -> Type} (RPre : PreRel E E) : Prop :=
  reflexivePreRel : forall A (e : E A), RPre A A e e.

Class SymmetricPreRel {E : Type -> Type} (RPre : PreRel E E) : Prop :=
  symmetricPreRel : forall A B (e1 : E A) (e2 : E B), RPre A B e1 e2 -> RPre B A e2 e1.

Class TransitivePreRel {E : Type -> Type} (RPre : PreRel E E) : Prop :=
  transitivePreRel : forall A B C (e1 : E A) (e2 : E B) (e3 : E C),
    RPre A B e1 e2 -> RPre B C e2 e3 -> RPre A C e1 e3.

Definition flipPreRel {E1 E2 : Type -> Type} (RPre : PreRel E1 E2) : PreRel E2 E1 :=
  fun A B e1 e2 => RPre B A e2 e1.

Variant rcomposePreRel {E1 E2 E3 : Type -> Type}
           (RPre12 : PreRel E1 E2) (RPre23 : PreRel E2 E3) : forall A C, E1 A -> E3 C -> Prop :=
  rcomposePreRel_intro (A B C: Type) e1 e2 e3 : RPre12 A B e1 e2 -> RPre23 B C e2 e3 -> rcomposePreRel RPre12 RPre23 A C e1 e3.

Variant sumPreRel {E1 E2 F1 F2} (RPreE : PreRel E1 E2) (RPreF : PreRel F1 F2) : forall A B, (E1 +' F1) A -> (E2 +' F2) B -> Prop :=
| sumPreRel_inl A B (e1 : E1 A) (e2 : E2 B) : RPreE A B e1 e2 -> sumPreRel RPreE RPreF A B (inl1 e1) (inl1 e2)
| sumPreRel_inr A B (f1 : F1 A) (f2 : F2 B) : RPreF A B f1 f2 -> sumPreRel RPreE RPreF A B (inr1 f1) (inr1 f2).

Notation PostRel E1 E2 := (forall (A B : Type), (E1 A : Type) -> (E2 B : Type) -> A -> B -> Prop).

Variant sumPostRel {E1 E2 F1 F2} (RPreE : PostRel E1 E2) (RPreF : PostRel F1 F2) :
  forall A B, (E1 +' F1) A -> (E2 +' F2) B -> A -> B -> Prop :=
| sumPostRel_inl A B (e1 : E1 A) (e2 : E2 B) a b : RPreE A B e1 e2 a b -> sumPostRel RPreE RPreF A B (inl1 e1) (inl1 e2) a b
| sumPostRel_inr A B (f1 : F1 A) (f2 : F2 B) a b : RPreF A B f1 f2 a b -> sumPostRel RPreE RPreF A B (inr1 f1) (inr1 f2) a b
.

(* This may need to be defined in dependent on two PreRel's?*)
(*
Variant rcomposePostRel' {E1 E2 E3 : Type -> Type}
           (RPre12 : PostRel E1 E2) (RPre23 : PostRel E2 E3):
  forall A C, E1 A -> E3 C -> A -> C -> Prop :=
  | rcomposePostRel_intro (A B C : Type)
                       (*maybe I should somehow universally quantify this*)
                       (e1 : E1 A) (e2 : E2 B) (e3 : E3 C)
                       a b c :
    RPre12 A B e1 e2 a b -> RPre23 B C e2 e3 b c ->
    rcomposePostRel RPre12 RPre23 A C e1 e3 a c.
*)

(* this means that if I find an e2, there must be a b that we can link
   the two with,
   the problem is what if the post condition is empty I should think of
   a new case for this possibility
 *)
Variant rcomposePostRel {E1 E2 E3 : Type -> Type}
           (RPre12 : PostRel E1 E2) (RPre23 : PostRel E2 E3)
           (RPre : forall A B C, E1 A -> E2 B -> E3 C -> Prop)
  :
  forall A C, E1 A -> E3 C -> A -> C -> Prop :=
  | rcomposePostRel_intro (A C : Type)
                       (e1 : E1 A) (e3 : E3 C)
                       a c :
    (forall B (e2 : E2 B),
      RPre A B C e1 e2 e3 -> exists b, RPre12 A B e1 e2 a b /\ RPre23 B C e2 e3 b c) ->
    rcomposePostRel RPre12 RPre23 RPre A C e1 e3 a c.

(*this is stronger than I need*)
(* I see 2 ways to do it, either it is reflexive wrt RPre
   or *)
Class ReflexivePostRel {E : Type -> Type} (RPreA : PostRel E E) : Prop :=
  reflexivePostRel : forall A (e : E A) (a b : A),
      RPreA A A e e a b -> a = b.

Class SymmetricPostRel {E : Type -> Type} (RPreA : PostRel E E) : Prop :=
  symmetricPostRel : forall A B (e1 : E A) (e2 : E B) a b,
      RPreA A B e1 e2 a b -> RPreA B A e2 e1 b a.

Variant eqPreRel {E} : PreRel E E :=
  | eqPreRel_refl A (e : E A) : eqPreRel A A e e.

Variant eqPostRel {E} : PostRel E E :=
  | eqPostRel_refl A e a : eqPostRel A A e e a a.

Variant subEqPreRel {E} (P : forall A, E A -> Prop) : PreRel E E :=
  | subEqPreRel_intro A (e : E A) : P A e -> subEqPreRel P A A e e.

Variant subEqPostRel {E} (P : forall A, E A -> A -> Prop) : PostRel E E :=
  | subEqPostRel_intro A e a : P A e a -> subEqPostRel P A A e e a a.

Variant subEqRel {A: Type} (P : A -> Prop) : Rel A A :=
  | subEqRel_intro a : P a -> subEqRel P a a.

Lemma eqPreRel_eq_type E A B (ea : E A) (eb : E B) : eqPreRel A B ea eb -> A = B.
Proof.
  intros. inv H. auto.
Qed.

Lemma eqPreRel_eq E A (e1 : E A) (e2 : E A) : eqPreRel A A e1 e2 -> e1 = e2.
Proof.
  intros. inv H. inj_existT. subst. auto.
Qed.

Lemma eqPostRel_eq_type E A B (ea : E A) (eb : E B) a b : eqPostRel A B ea eb a b -> A = B.
Proof.
  intros. inv H. auto.
Qed.

Lemma eqPostRel_eq E A (e1 : E A) (e2 : E A) a1 a2 : eqPostRel A A e1 e2 a1 a2 -> e1 = e2 /\ a1 = a2.
Proof.
  intros. inv H. inj_existT. subst. auto.
Qed.

Ltac eqPreRel_inv H := apply eqPreRel_eq_type in H as ?H; subst; apply eqPreRel_eq in H; subst.
Ltac eqPostRel_inv H := apply eqPostRel_eq_type in H as ?H; subst; apply eqPostRel_eq in H as [?H ?H]; subst.

Lemma subEqPreRel_eq_type E P A B (ea : E A) (eb : E B) : subEqPreRel P A B ea eb -> A = B.
Proof.
  intros. inv H. auto.
Qed.

Lemma subEqPreRel_eq E P A (e1 : E A) (e2 : E A) : subEqPreRel P A A e1 e2 -> e1 = e2 /\ P A e1.
Proof.
  intros. inv H. inj_existT. subst. auto.
Qed.

Lemma subEqPostRel_eq_type E P A B (ea : E A) (eb : E B) a b : subEqPostRel P A B ea eb a b -> A = B.
Proof.
  intros. inv H. auto.
Qed.

Lemma subEqPostRel_eq E P A (e1 : E A) (e2 : E A) a1 a2 : subEqPostRel P A A e1 e2 a1 a2 -> e1 = e2 /\ a1 = a2
                                                                                /\ P A e1 a1.
Proof.
  intros. inv H. inj_existT. subst. auto.
Qed.

Ltac subEqPreRel_inv H := eapply subEqPreRel_eq_type in H as ?H; subst; eapply subEqPreRel_eq in H as [?H ?H] ; subst.
Ltac subEqPostRel_inv H := apply subEqPostRel_eq_type in H as ?H; subst; apply subEqPostRel_eq in H as [?H [?H ?H] ]; subst.

Global Instance subEqPostRel_trans E (P : forall A, E A -> A -> Prop) A (e : E A) : Transitive (subEqPostRel P A A e e).
Proof.
  intros x y z Hxy Hyz. subEqPostRel_inv Hxy. auto.
Qed.


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

Require Export isocele.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter reflexion : PO -> PO -> PO -> PO.

Axiom
  reflexion_def :
    forall A B M M' H : PO,
    A <> B ->
    H = projete_orthogonal A B M ->
    M' = reflexion A B M -> vec M M' = mult_PP 2 (vec M H).

Axiom
  reflexion_def2 :
    forall A B M M' H : PO,
    A <> B ->
    H = projete_orthogonal A B M ->
    vec M M' = mult_PP 2 (vec M H) -> M' = reflexion A B M.

Lemma reflexion_axe :
 forall A B M : PO, A <> B -> alignes A B M -> M = reflexion A B M.
intros A B M H2 H0; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
apply reflexion_def2 with H; auto.
cut (M = H); intros.
rewrite <- H1; Ringvec.
rewrite H3.
apply def_projete_orthogonal; auto.
replace (vec M M) with zero; auto with geo.
Ringvec.
Qed.
#[export] Hint Resolve reflexion_axe: geo.

Lemma reflexion_projete_orthogonal_milieu :
 forall A B M M' H : PO,
 A <> B ->
 H = projete_orthogonal A B M -> M' = reflexion A B M -> H = milieu M M'.
intros.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
cut (2 <> 0); intros.
apply vecteur_milieu.
rewrite H5; auto.
replace (mult_PP (/ 2) (mult_PP 2 (vec M H))) with
 (mult_PP (/ 2 * 2) (vec M H)).
replace (/ 2 * 2) with 1.
Ringvec.
auto with real.
Ringvec.
discrR.
Qed.

Lemma reflexion_image_distinct :
 forall A B M M' : PO, ~ alignes A B M -> M' = reflexion A B M -> M <> M'.
intros A B M M' H0 H1; try assumption.
cut (A <> B); intros H2; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
cut (M <> H); intros.
apply dist_non_nulle.
unfold not in |- *; intros; apply H6.
apply distance_nulle.
rewrite (milieu_vecteur2 (A:=M) (B:=M') (M:=H)); auto.
Simplscal.
rewrite carre_scalaire_distance; rewrite H7; ring.
unfold not in |- *; intros; apply H0.
rewrite H6.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros; try exact H7 | auto | auto ].
Qed.

Lemma reflexion_mediatrice :
 forall A B M M' : PO,
 ~ alignes A B M ->
 M' = reflexion A B M -> mediatrice M M' A /\ mediatrice M M' B.
intros A B M M' H1 H3; try assumption.
cut (A <> B); intros H0; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H2; try clear existence_projete_orthogonal | auto ].
generalize (reflexion_image_distinct (A:=A) (B:=B) (M:=M) (M':=M'));
 intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
halignes H7 k.
split; [ try assumption | idtac ].
elim (classic (H = A)); intros.
rewrite <- H10.
apply milieu_mediatrice; auto.
apply orthogonale_segment_milieu_mediatrice with H; auto.
apply ortho_sym.
cut (orthogonal (vec A B) (vec M M')); intros.
replace (vec H A) with (mult_PP (- k) (vec A B)).
Simplortho.
replace (vec H A) with (mult_PP (-1) (vec A H)).
rewrite H9.
Ringvec.
Ringvec.
apply ortho_sym.
rewrite H6; auto.
Simplortho.
elim (classic (H = B)); intros.
rewrite <- H10.
apply milieu_mediatrice; auto.
apply orthogonale_segment_milieu_mediatrice with H; auto.
apply ortho_sym.
cut (orthogonal (vec A B) (vec M M')); intros.
replace (vec H B) with
 (add_PP (mult_PP (- k) (vec A B)) (mult_PP 1 (vec A B))).
Simplortho.
replace (mult_PP (- k) (vec A B)) with (mult_PP (-1) (mult_PP k (vec A B))).
rewrite <- H9.
Ringvec.
Ringvec.
apply ortho_sym.
rewrite H6; auto.
Simplortho.
Qed.

Lemma reflexion_axe_orthogonal_segment :
 forall A B M M' : PO,
 ~ alignes A B M -> M' = reflexion A B M -> orthogonal (vec M M') (vec A B).
intros.
assert (A <> B); auto with geo.
apply ortho_sym; auto.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto; intros.
apply mediatrice_orthogonale_segment; auto.
apply reflexion_image_distinct with (2 := H0); auto.
Qed.

Lemma projete_orthogonal_image :
 forall A B M M' H : PO,
 A <> B ->
 H = projete_orthogonal A B M ->
 M' = reflexion A B M -> H = projete_orthogonal A B M'.
intros.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
apply def_projete_orthogonal; auto.
apply ortho_sym.
replace (vec H M') with (vec M H); auto with geo.
Qed.

Lemma non_axe_image_non_axe :
 forall A B M M' : PO,
 ~ alignes A B M -> M' = reflexion A B M -> ~ alignes A B M'.
intros A B M M' H0 H2; try assumption.
cut (A <> B); intros H1; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
elim reflexion_mediatrice with (A := A) (B := B) (M := M) (M' := M');
 [ intros H6 H7; try clear reflexion_mediatrice; try exact H7 | auto | auto ].
generalize (mediatrice_orthogonale_segment (A:=M) (B:=M') (M:=A) (N:=B));
 intros.
generalize (reflexion_image_distinct (A:=A) (B:=B) (M:=M) (M':=M')); intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
cut (H = projete_orthogonal A B M'); intros.
cut (M' <> H); intros.
unfold not in |- *; intros; apply H13.
rewrite H12.
apply def_projete_orthogonal; auto.
replace (vec M' M') with zero.
apply zero_ortho_tout.
Ringvec.
rewrite H4; auto.
apply milieu_distinct2; auto.
apply projete_orthogonal_image with M; auto.
Qed.

Lemma reflexion_symetrie :
 forall A B M M' : PO, A <> B -> M' = reflexion A B M -> M = reflexion A B M'.
intros A B M M' H1 H0; try assumption.
elim (classic (alignes A B M)); intros H20.
rewrite H0.
rewrite <- reflexion_axe.
rewrite <- reflexion_axe; auto.
auto.
rewrite <- reflexion_axe; auto.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
generalize (projete_orthogonal_image (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
generalize (non_axe_image_non_axe (A:=A) (B:=B) (M:=M) (M':=M')); intros.
apply reflexion_def2 with H; auto with geo.
Qed.

Lemma reflexion_isocele :
 forall A B M M' : PO, A <> B -> M' = reflexion A B M -> isocele A M M'.
intros.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
unfold isocele in |- *; auto.
rewrite H0; rewrite <- reflexion_axe; auto.
apply mediatrice_isocele.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto.
Qed.

Lemma axe_reflexion_droite :
 forall A B C M M' : PO,
 A <> B ->
 A <> C -> alignes A B C -> M' = reflexion A B M -> M' = reflexion C A M.
intros A B C M M' H10 H0 H1 H2; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H4; try clear existence_projete_orthogonal; try exact H3 | auto ].
halignes H1 k.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
apply reflexion_def2 with H; auto.
apply def_projete_orthogonal.
auto.
halignes H5 k0.
elim (classic (k = 0)); intros.
absurd (A = C); auto.
rewrite H8 in H3.
apply conversion_PP with (a := 1) (b := 1); auto with real.
RingPP2 H3.
Ringvec.
apply colineaire_alignes with (/ k * (k + - k0)).
replace (vec C H) with (add_PP (vec A H) (mult_PP (-1) (vec A C))).
replace (vec C A) with (mult_PP (-1) (vec A C)).
rewrite H7; rewrite H3.
replace (mult_PP (/ k * (k + - k0)) (mult_PP (-1) (mult_PP k (vec A B))))
 with (mult_PP (/ k * (k + - k0) * (-1 * k)) (vec A B)).
replace (/ k * (k + - k0) * (-1 * k)) with (/ k * k * (-1 * (k + - k0))).
replace (/ k * k) with 1.
Ringvec.
auto with real.
ring.
Ringvec.
Ringvec.
Ringvec.
replace (vec C A) with
 (add_PP (mult_PP 0 (vec A B)) (mult_PP (- k) (vec A B))).
apply ortho_combinaison_lineaire; auto.
replace (vec C A) with (mult_PP (-1) (vec A C)).
rewrite H3.
Ringvec.
Ringvec.
rewrite (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); auto.
Qed.

Theorem axe_reflexion_bissectrice :
 forall A B M M' : PO,
 ~ alignes A B M ->
 M' = reflexion A B M ->
 cons_AV (vec A M) (vec A B) = cons_AV (vec A B) (vec A M').
intros A B M M' H1 H2; try assumption.
cut (A <> B); intros H0; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H4; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (non_axe_image_non_axe (A:=A) (B:=B) (M:=M) (M':=M')); intros.
generalize (non_alignes_distincts (A:=A) (B:=B) (C:=M')); intros.
generalize (non_alignes_distincts (A:=A) (B:=B) (C:=M)); intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros; try exact H13 | auto | auto ].
elim (classic (A = H)); intros.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
apply milieu_angles_orthogonaux; auto.
apply reflexion_image_distinct with (2 := H2); auto.
rewrite H9; auto.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros.
replace (vec M M') with
 (add_PP (mult_PP (-1) (vec H M)) (mult_PP (-1) (vec H M))).
apply ortho_combinaison_lineaire; apply ortho_sym; auto.
rewrite H11; auto.
Ringvec.
cut (cons_AV (vec A M) (vec A H) = cons_AV (vec A H) (vec A M')); intros;
 auto.
rewrite angles_representants_unitaires; auto.
rewrite angles_representants_unitaires; auto.
elim existence_representant_unitaire with (A := A) (B := H);
 [ intros; try clear existence_representant_unitaire | auto ].
elim existence_representant_unitaire with (A := A) (B := M');
 [ intros; try clear existence_representant_unitaire | auto ].
elim existence_representant_unitaire with (A := A) (B := M);
 [ intros; try clear existence_representant_unitaire | auto ].
elim alignes_representant_unitaire with (A := A) (B := B) (C := H);
 [ intros; try clear alignes_representant_unitaire; auto
 | intros; auto
 | auto
 | auto
 | auto ].
rewrite H14.
rewrite <- angles_representants_unitaires; auto.
rewrite <- angles_representants_unitaires; auto.
replace (representant_unitaire (vec A B)) with
 (mult_PP (-1) (representant_unitaire (vec A H))).
cut (A <> x); intros.
replace (mult_PP (-1) (representant_unitaire (vec A H))) with (vec x A).
replace (cons_AV (representant_unitaire (vec A M)) (vec x A)) with
 (plus (cons_AV (representant_unitaire (vec A M)) (vec A x))
    (cons_AV (vec A x) (vec x A))).
replace (cons_AV (vec x A) (representant_unitaire (vec A M'))) with
 (plus (cons_AV (vec x A) (vec A x))
    (cons_AV (vec A x) (representant_unitaire (vec A M')))).
rewrite <- angle_plat; auto.
rewrite <- angle_plat; auto.
rewrite H11.
rewrite <- angles_representants_unitaires; auto.
rewrite <- angles_representants_unitaires; auto.
rewrite <- H10; auto.
mesure A M A H.
replace (x2 + pi) with (pi + x2); (try ring; auto).
rewrite <- H12.
cut (A <> x0); intros.
rewrite Chasles; auto.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := A) (B := M') (C := x0);
 [ intros; elim H17; intros H22 H23; try clear H17 def_representant_unitaire2;
    rewrite H22; try discrR
 | auto
 | auto ].
rewrite <- H13.
cut (A <> x1); intros.
rewrite Chasles; auto.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := A) (B := M) (C := x1);
 [ intros; elim H17; intros H22 H23; try clear H18 def_representant_unitaire2;
    rewrite H22; try discrR
 | auto
 | auto ].
rewrite <- H11; Ringvec.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := A) (B := H) (C := x);
 [ intros; elim H16; intros H22 H23; try clear H18 def_representant_unitaire2;
    rewrite H22; try discrR
 | auto
 | auto ].
rewrite H14.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros; try clear existence_representant_unitaire | auto ].
rewrite <- H15; Ringvec.
generalize (reflexion_image_distinct (A:=A) (B:=B) (M:=M) (M':=M')); intros.
generalize (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); intros.
elim H11; auto; intros.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
apply mediatrice_milieu_angles; auto.
Qed.

Lemma reflexion_isocele2 :
 forall A B M M' : PO, A <> B -> M' = reflexion A B M -> isocele B M M'.
intros.
apply reflexion_isocele with A; auto.
apply axe_reflexion_droite with B; auto with geo.
Qed.

Lemma reflexion_inverse_angle :
 forall A B M M' : PO,
 A <> B ->
 M <> A ->
 M <> B ->
 M' = reflexion A B M ->
 cons_AV (vec M' A) (vec M' B) = opp (cons_AV (vec M A) (vec M B)).
intros.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
cut (double_AV (cons_AV (vec M A) (vec M B)) = image_angle 0); intros.
replace (opp (cons_AV (vec M A) (vec M B))) with
 (plus (image_angle 0) (opp (cons_AV (vec M A) (vec M B))));
 auto.
rewrite <- H4; unfold double_AV in |- *.
mesure M A M B.
replace (x + x + - x) with x; auto.
ring.
mesure M A M B.
replace (0 + - x) with (- x); auto.
ring.
apply angle_alignes; auto with geo.
rewrite H2; rewrite <- reflexion_axe; auto.
cut (M <> M'); intros.
cut (~ alignes A B M'); intros.
cut (A <> M'); intros.
cut (B <> M'); intros.
replace (cons_AV (vec M A) (vec M B)) with
 (plus (cons_AV (vec M A) (vec M M')) (cons_AV (vec M M') (vec M B))).
rewrite opp_plus_plus_opp; auto.
rewrite def_opp; auto.
lapply (reflexion_isocele (A:=A) (B:=B) (M:=M) (M':=M')); auto; intros.
lapply (reflexion_isocele2 (A:=A) (B:=B) (M:=M) (M':=M')); auto; intros.
lapply (isocele_angles_base (A:=A) (B:=M) (C:=M')); auto; intros.
lapply (isocele_angles_base (A:=B) (B:=M) (C:=M')); auto; intros.
rewrite H11; auto.
rewrite H10; auto.
rewrite def_opp; auto.
rewrite Chasles; auto.
rewrite Chasles; auto.
lapply (non_alignes_distincts2 (A:=A) (B:=B) (C:=M')); auto; intros.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=M')); auto; intros.
apply non_axe_image_non_axe with M; auto.
apply reflexion_image_distinct with (2 := H2); auto.
Qed.

Lemma reflexion_isometrie :
 forall A B M M' N N' : PO,
 A <> B ->
 M' = reflexion A B M ->
 N' = reflexion A B N -> distance M N = distance M' N'.
intros.
discrimine M N.
rewrite H2 in H0.
rewrite H0; rewrite <- H1.
rewrite distance_refl2; auto.
rewrite distance_refl2; auto.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
rewrite H1; rewrite <- reflexion_axe; auto.
cut (A <> N); intros.
cut (A <> N'); intros.
discrimine M A.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=N) (M':=N')); auto;
 unfold mediatrice in |- *; intros.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=M) (M:=N) (M':=N')); auto;
 intros.
elim (reflexion_mediatrice (A:=M) (B:=A) (M:=N) (M':=N')); auto with geo;
 unfold mediatrice in |- *; intros.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=N) (D:=M)); auto with geo;
 intros.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto with geo; intros.
apply non_axe_image_non_axe with N; auto with geo.
apply non_alignes_distincts with B; auto with geo.
rewrite H0; rewrite <- reflexion_axe; auto.
cut (A <> M); intros.
cut (A <> M'); intros.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
discrimine N A.
rewrite distance_sym; rewrite (distance_sym M' A).
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto with geo;
 unfold mediatrice in |- *; intros.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=N) (M:=M) (M':=M'));
 auto with geo; intros.
rewrite distance_sym; rewrite (distance_sym M' N).
elim (reflexion_mediatrice (A:=N) (B:=A) (M:=M) (M':=M')); auto with geo;
 unfold mediatrice in |- *; intros.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=M) (D:=N)); auto with geo;
 intros.
rewrite H1; rewrite <- reflexion_axe; auto.
cut (A <> N); intros.
cut (A <> N'); intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := N) (A' := A) (B' := M') (C' := N');
 (auto; intros).
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto with geo;
 unfold mediatrice in |- *; intros.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=N) (M':=N')); auto with geo;
 unfold mediatrice in |- *; intros.
replace (cons_AV (vec A M) (vec A N)) with
 (plus (cons_AV (vec A M) (vec A B)) (cons_AV (vec A B) (vec A N))).
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=M) (M':=M')); auto.
replace (cons_AV (vec A B) (vec A N)) with (cons_AV (vec A N') (vec A B)).
replace (plus (cons_AV (vec A B) (vec A M')) (cons_AV (vec A N') (vec A B)))
 with (plus (cons_AV (vec A N') (vec A B)) (cons_AV (vec A B) (vec A M'))).
rewrite Chasles; auto.
mesure A B A M'.
mesure A N' A B.
replace (x0 + x) with (x + x0); auto.
ring.
apply permute_angles; auto.
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=N) (M':=N')); auto.
rewrite Chasles; auto.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto; intros.
apply non_axe_image_non_axe with N; auto.
apply non_alignes_distincts with B; auto.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=M')); auto; intros.
apply non_axe_image_non_axe with M; auto.
apply non_alignes_distincts with B; auto.
Qed.

Lemma reflexion_inverse_AMN :
 forall A B M M' N N' : PO,
 A <> B ->
 A <> M ->
 A <> N ->
 M' = reflexion A B M ->
 N' = reflexion A B N ->
 cons_AV (vec A M') (vec A N') = opp (cons_AV (vec A M) (vec A N)).
intros.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
lapply (alignes_trans (A:=A) (B:=B) (C:=M) (D:=N)); auto; intros.
cut (double_AV (cons_AV (vec A M) (vec A N)) = image_angle 0); intros.
replace (opp (cons_AV (vec A M) (vec A N))) with
 (plus (image_angle 0) (opp (cons_AV (vec A M) (vec A N))));
 auto.
rewrite <- H7; unfold double_AV in |- *.
mesure A M A N.
replace (x + x + - x) with x; auto.
ring.
rewrite plus_commutative; auto with geo.
apply angle_alignes; auto.
rewrite H3; rewrite <- reflexion_axe; auto.
cut (A <> N'); intros.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=M) (M:=N) (M':=N')); auto;
 intros.
rewrite <- (axe_reflexion_bissectrice (A:=A) (B:=M) (M:=N) (M':=N')); auto.
rewrite def_opp; auto.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=N) (D:=M)); auto; intros.
lapply (axe_reflexion_droite (A:=M) (B:=A) (C:=A) (M:=N) (M':=N'));
 auto with geo; intros.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto; intros.
apply non_axe_image_non_axe with N; auto.
rewrite H2; rewrite <- reflexion_axe; auto.
cut (A <> M'); intros.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=N) (M:=M) (M':=M')); auto;
 intros.
rewrite (axe_reflexion_bissectrice (A:=A) (B:=N) (M:=M) (M':=M')); auto.
rewrite def_opp; auto.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=M) (D:=N)); auto; intros.
lapply (axe_reflexion_droite (A:=N) (B:=A) (C:=A) (M:=M) (M':=M'));
 auto with geo; intros.
rewrite H3; rewrite <- reflexion_axe; auto.
cut (A <> N'); intros.
replace (cons_AV (vec A M) (vec A N)) with
 (plus (cons_AV (vec A M) (vec A B)) (cons_AV (vec A B) (vec A N))).
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=M) (M':=M')); auto.
replace (cons_AV (vec A B) (vec A N)) with (cons_AV (vec A N') (vec A B)).
replace (plus (cons_AV (vec A B) (vec A M')) (cons_AV (vec A N') (vec A B)))
 with (plus (cons_AV (vec A N') (vec A B)) (cons_AV (vec A B) (vec A M'))).
rewrite Chasles; auto.
rewrite def_opp; auto.
mesure A B A M'.
mesure A N' A B.
replace (x0 + x) with (x + x0); auto.
ring.
apply permute_angles; auto.
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=N) (M':=N')); auto.
rewrite Chasles; auto.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto; intros.
apply non_axe_image_non_axe with N; auto.
apply non_alignes_distincts with B; auto.
apply non_axe_image_non_axe with M; auto.
Qed.

Theorem reflexion_anti_deplacement :
 forall A B M M' N N' P P' : PO,
 A <> B ->
 M <> N ->
 M <> P ->
 N <> P ->
 M' = reflexion A B M ->
 N' = reflexion A B N ->
 P' = reflexion A B P ->
 cons_AV (vec M' N') (vec M' P') = opp (cons_AV (vec M N) (vec M P)).
intros.
cut (M' <> N'); intros.
cut (M' <> P'); intros.
discrimine M A.
cut (M' = A); intros.
rewrite H9.
cut (A <> N); intros.
cut (A <> P); intros.
apply reflexion_inverse_AMN with B; auto.
red in |- *; intros; apply H1.
rewrite H8; auto.
red in |- *; intros; apply H0.
rewrite H8; auto.
rewrite H3; rewrite H8; rewrite <- reflexion_axe; auto with geo.
discrimine N A.
cut (N' = A); intros.
rewrite H10.
cut (A <> P); intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := P) (A' := A) (B' := M') (C' := P');
 (auto; intros).
elim H13; intros.
rewrite <- H14; rewrite def_opp; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=P) (N':=P'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=P) (M':=P') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
red in |- *; intros; apply H2.
rewrite H9; auto.
rewrite H4; rewrite H9; rewrite <- reflexion_axe; auto with geo.
discrimine P A.
cut (P' = A); intros.
rewrite H11.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := N) (A' := A) (B' := M') (C' := N');
 (auto; intros).
elim H13; intros.
rewrite H14; rewrite def_opp; auto.
red in |- *; intros; apply H7.
rewrite H16; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=N) (N':=N'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=N) (M':=N') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
rewrite H5; rewrite H10; rewrite <- reflexion_axe; auto with geo.
cut (A <> M'); intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := N) (A' := A) (B' := M') (C' := N');
 (auto; intros).
elim H13; intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := P) (A' := A) (B' := M') (C' := P');
 (auto; intros).
elim H17; intros.
replace (cons_AV (vec M N) (vec M P)) with
 (plus (cons_AV (vec M N) (vec M A)) (cons_AV (vec M A) (vec M P))).
replace (cons_AV (vec M A) (vec M P)) with (cons_AV (vec M' P') (vec M' A)).
rewrite H14.
replace
 (plus (cons_AV (vec M' A) (vec M' N')) (cons_AV (vec M' P') (vec M' A)))
 with
 (plus (cons_AV (vec M' P') (vec M' A)) (cons_AV (vec M' A) (vec M' N'))).
rewrite Chasles; auto.
rewrite def_opp; auto.
mesure M' P' M' A.
mesure M' A M' N'.
replace (x + x0) with (x0 + x); auto.
ring.
apply permute_angles; auto.
rewrite Chasles; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=P) (N':=P'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=P) (M':=P') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=N) (N':=N'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=N) (M':=N') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
apply (isometrie_distinct (A:=A) (B:=M) (A':=A) (B':=M')); auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
apply (isometrie_distinct (A:=M) (B:=P) (A':=M') (B':=P')); auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=M) (M':=M') (N:=P) (N':=P'));
 auto.
apply (isometrie_distinct (A:=M) (B:=N) (A':=M') (B':=N')); auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=M) (M':=M') (N:=N) (N':=N'));
 auto.
Qed.

Lemma mediatrices_reflexion :
 forall A B M M' : PO,
 M <> M' ->
 ~ alignes A B M ->
 mediatrice M M' A -> mediatrice M M' B -> M' = reflexion A B M.
intros A B M M' H0 H1 H2 H3; try assumption.
cut (A <> B); intros H; [ idtac | auto with geo ].
soit_milieu M M' K.
apply reflexion_def2 with K; auto with geo.
apply def_projete_orthogonal; auto.
discrimine K A.
apply alignes_ordre_cycle; auto.
apply mediatrice_droite with (2 := H4); auto.
cut (orthogonal (vec M M') (vec A B)); intros.
apply ortho_sym.
replace (vec K M) with (mult_PP (-1) (vec M K)).
rewrite (milieu_vecteur2 (A:=M) (B:=M') (M:=K)); auto.
replace (mult_PP (-1) (mult_PP (/ 2) (vec M M'))) with
 (mult_PP (- / 2) (vec M M')).
Simplortho.
cut (2 <> 0); intros; auto with real.
Fieldvec 2.
Ringvec.
apply ortho_sym.
apply mediatrice_orthogonale_segment; auto.
Qed.

Lemma existence_reflexion_AB :
 forall A B M : PO, A <> B -> exists M' : PO, M' = reflexion A B M.
intros A B M H1; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H4; try clear existence_projete_orthogonal; try exact H3 | auto ].
elim existence_representant_vecteur with (A := H) (B := M) (C := H);
 intros M' H3; try clear existence_representant_vecteur;
 try exact H3.
exists M'.
apply reflexion_def2 with H; auto.
replace (vec M M') with (add_PP (vec M H) (vec H M')).
rewrite H3; Ringvec.
Ringvec.
Qed.


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

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

Require Export Gates_Del.
Require Export dlist_Compl.
Require Import Syntactic_Def.

Set Implicit Arguments.
Unset Strict Implicit.

Definition IN_BUF := d_map IBUF.
Definition OUT_BUF := d_map OBUF.

Definition ILATCH := d_map2 INFFd.
Definition IN_LATCH (n : nat) := d_map2 (ILATCH (n:=n)).
Definition OLATCH := d_map2 OUTFFd.
Definition OUT_LATCH (n : nat) := d_map2 (OLATCH (n:=n)).
Definition LATCH := d_map2 DFFd.
Definition PAUSE (n : nat) := d_map2 (LATCH (n:=n)).

Definition Ackor (n : nat) := Fold_with_f_S (n:=n) OR2.

Definition NORL (n : nat) (H : 0 < n) := Fold_with_f (n:=n) NOR2 H.
Definition NORL3 := NORL (n:=3) lt_O_3.

Definition ANDL (n : nat) (H : 0 < n) := Fold_with_f (n:=n) AND2 H.
Definition ANDL4 := ANDL (n:=4) lt_O_4.
Definition ANDL3 := ANDL (n:=3) lt_O_3.

Definition AO (a b c d : bool) := a && b || c && d.

Definition RLATCH (rd : Stream bool) := d_map2 (DFFRD rd).


Require Import Cdcl.Itauto.
Require Import Lia.
Require Import ZArith.

Ltac tlia := time "lia" lia.

Lemma elim_eq : forall (x y: Z), x = y <-> not (x < y \/ x > y)%Z.
Proof.
  intros. lia.
Qed.

Goal forall input mapper0In mapper1In reducer0In reducer1In aggregatorIn output : nat,
 mapper0In = input \/
 mapper1In = mapper0In \/
 reducer0In = mapper1In \/
 reducer1In = reducer0In \/
 aggregatorIn = reducer1In \/
 output = aggregatorIn \/
 mapper1In = input \/
 reducer0In = mapper0In \/
 reducer1In = mapper1In \/
 aggregatorIn = reducer0In \/
 output = reducer1In \/
 reducer0In = input \/
 reducer1In = mapper0In \/
 aggregatorIn = mapper1In \/
 output = reducer0In \/
 reducer1In = input \/
 aggregatorIn = mapper0In \/
 output = mapper1In \/ aggregatorIn = input \/ output = mapper0In \/ output = input \/ 0 = 1.
Proof.
  intros.
  Zify.zify. (* zify needs to be called before. Otherwise, we get equalities over nat. *)
  Fail itauto tlia.
Abort.


Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.

Require Import LIR.maps.
Require Import LIR.lir.
Require Import LIR.precision.
Require Import LIR.dyn.

Set Implicit Arguments.

(*
** Precision relation for memories: implies that memory is correct,
** because the precision relation needs the types of the expressions
** being compared.
*)
Inductive PrecMem : Mem -> Mem -> Prop :=
| PrecMemE : PrecMem EmptyMem EmptyMem
| PrecMemUD : forall addr idx v1 v2 m1 m2,
    Precision MEmpty (EV2Val v1) IRTStar MEmpty (EV2Val v2) IRTStar ->
    PrecMem m1 m2 ->
    PrecMem (UpdateT addr idx v1 m1) (UpdateT addr idx v2 m2)
| PrecMemUDF : forall addr var b1 b2 m1 m2,
    Precision (var |=> IRTStar; MEmpty) b1 IRTStar (var |=> IRTStar; MEmpty)b2 IRTStar ->
    PrecMem m1 m2 ->
    PrecMem (UpdateF addr var b1 m1) (UpdateF addr var b2 m2)
.

Infix "<M|" := PrecMem (at level 80).

(*
** Memory precision is reflexive
*)
Lemma PrecMemRefl : forall m,
    mem_correct m -> m <M| m.
Proof.
  induction 1; eauto using PrecMem, PrecisionRefl.
Qed.

(*
** Memory precision implies that memory 1 is correct.
*)
Lemma PrecCorrect1 : forall m1 m2, m1 <M| m2 -> mem_correct m1.
Proof.
  induction 1; eauto using mem_correct, PrecisionType1.
Qed.

(*
** Memory precision implies that memory 2 is correct.
*)
Lemma PrecCorrect2 : forall m1 m2, m1 <M| m2 -> mem_correct m2.
Proof.
  induction 1; eauto using mem_correct, PrecisionType2.
Qed.

(*
** Expressions equal "up to precision" generate the same indices
*)
Lemma PrecIndex : forall e1 e2,
    Precision MEmpty e1 IRTStar MEmpty e2 IRTStar ->
    ToIndex e1 = ToIndex e2.
Proof. induction 1; eauto. Qed.

(*
** Memories in a precision relation generate equal "fresh" addresses
*)
Lemma PrecFreshaux : forall m1 m2,
    m1 <M| m2 -> freshaux m1 = freshaux m2.
Proof. induction 1; simpl; eauto. Qed.

(*
** Creating a new table entry preserves memory precision and
** results in equal addresses.
*)
Lemma PrecFreshT : forall m1 m2 free m1',
    m1 <M| m2 ->
    (free, m1') = freshT m1 ->
    exists m2', (free, m2') = freshT m2 /\ m1' <M| m2'.
Proof.
  unfold freshT.
  injection 2; intros; subst.
  replace (freshaux m2) with (freshaux m1) by auto using PrecFreshaux.
  eexists; split;
  eauto using PrecMem, Precision, EnvCompRefl.
Qed.

(*
** Creating a new closure preserves memory precision and
** results in equal addresses.
*)
Lemma PrecFreshF : forall m1 m2 var d1 d2 free m1',
    m1 <M| m2 ->
    Precision
       (var |=> IRTStar; MEmpty) d1 IRTStar
       (var |=> IRTStar; MEmpty) d2 IRTStar ->
    (free, m1') = freshF m1 var d1 ->
    exists m2', m1' <M| m2' /\ (free, m2') = freshF m2 var d2.
Proof.
  unfold freshF.
  injection 3; intros; subst.
  replace (freshaux m2) with (freshaux m1) by auto using PrecFreshaux.
  eauto using PrecMemUDF.
Qed.

Lemma PrecQueryT : forall m1 m2 a i1 i2,
    m1 <M| m2 ->
    Precision MEmpty i1 IRTStar MEmpty i2 IRTStar ->
    Precision MEmpty (queryT a i1 m1) IRTStar MEmpty (queryT a i2 m2) IRTStar.
Proof.
  intros * HOM HP.
  induction HOM; simpl; eauto using Precision, EnvCompRefl.
  replace (ToIndex i2) with (ToIndex i1) by eauto using PrecIndex.
  breakIndexDec; subst. trivial.
Qed.

Lemma PrecQueryF : forall m1 m2 a var var' body body',
    m1 <M| m2 ->
    (var, body) = queryF a m1 ->
    (var', body') = queryF a m2 ->
    var = var' /\
      Precision
         (var |=> IRTStar; MEmpty) body IRTStar
         (var |=> IRTStar; MEmpty) body' IRTStar.
Proof.
  intros * HM HEq1 HEq2.
  induction HM; simpl in *;
    breakIndexDec; eauto;
    injection HEq1; injection HEq2; intros; subst;
    split; eauto 6 using Precision, EnvCompRefl.
Qed.

Lemma PrecUpdate : forall m1 m2 a i1 i2 v1 v2,
    m1 <M| m2 ->
    forall (vv1 : Value v1) (vv2 : Value v2),
    Precision MEmpty i1 IRTStar MEmpty i2 IRTStar ->
    Precision MEmpty v1 IRTStar MEmpty v2 IRTStar ->
    UpdateT a (ToIndex i1) (EV v1 vv1) m1 <M|
    UpdateT a (ToIndex i2) (EV v2 vv2) m2.
Proof.
  intros.
  replace (ToIndex i2) with (ToIndex i1) by eauto using PrecIndex.
  auto using PrecMem.
Qed.

(*
** Substitution preserves precision
*)
Lemma PrecSubs : forall body Γ Γ' Δ Δ' var  body' v1 v2 t1 t2 t1' t2',
    Precision MEmpty v1 t1 MEmpty v2 t2 ->
    map_eq (var |=> t1; Γ) Γ' ->
    map_eq (var |=> t2; Δ) Δ' ->
    Γ <E| Δ ->
    Precision Γ' body t1' Δ' body' t2' ->
    Precision Γ ([var := v1] body) t1' Δ ([var := v2] body') t2'.
Proof.
  intros * HPV HE1 HE2 HPE HPB.
  generalize dependent Δ.
  generalize dependent Γ.
  induction HPB; intros; eauto using Precision, EnvCompRefl;
     simpl.

  - (* variable *)
    breakStrDec.
    + replace t1 with t0 in * by eauto using map_eq_In.
      replace t2 with t3 in * by eauto using map_eq_In.
      auto using PrecisionInclusionE.
    + eapply PVar; trivial.
      * eapply InNotEq with (var := var0) in HE1; congruence.
      * eapply InNotEq with (var := var0) in HE2; congruence.

  - (* let *)
    breakStrDec;
      eauto 12 using Precision, PrecisionInclusion, map_eq_incl,
      map_eq_sym, eqeq_shadow, EnvCompExt, extend2Types, eqeq_permute.

  - (* fun *)
    breakStrDec;
      eauto 12 using Precision, PrecisionInclusion, map_eq_incl,
      map_eq_sym, eqeq_shadow, EnvCompExt, extend2Types, eqeq_permute.
Qed.

(*
** Substitution applied to function bodies
*)
Lemma PrecSubs' : forall var body body' v1 v2,
    Precision MEmpty (IREFun var body) IRTFun
              MEmpty (IREFun var body') IRTFun ->
    Precision MEmpty v1 IRTStar MEmpty v2 IRTStar ->
    Precision MEmpty ([var := v1] body) IRTStar MEmpty ([var := v2] body') IRTStar.
Proof.
  inversion 1; subst.
  eauto using PrecSubs, map_eq_refl.
Qed.

Ltac ContraTags :=
  try match goal with
    [H: IRTStar <| Tag2Type _ |- _] =>
      apply NoneBiggerThanStar in H
  end;
  try match goal with
    [H: IRTStar = Tag2Type ?g |- _] =>
      destruct g; discriminate
  end.

Lemma GroundFlat': forall g g', (Tag2Type g) <| (Tag2Type g') -> g = g'.
Proof.
  intros. GroundFlat. congruence.
Qed.

Lemma GroundType: forall g t g',
    t <| Tag2Type g -> Type2Tag t = Some g' -> g = g'.
Proof.
  intros.
  destruct t eqn:Heq';
  ContraTags;
  GroundFlat;
  simpl in *; congruence.
Qed.

(*
** About "catch-up": when e1 ⊑ e2 and e1 is a value, e2 may not be
** a value (e.g., (unbox (box 10))). But we can guarantee that e2
** reduces to a value (nor errors or infinite loops) in a somewhat
** restricted way. This property is called "catch-up", and several
** of the following lemmas help its proof.
*)

(*
** Catch-up steps do not change the memory
*)
Lemma stepValueMem : forall e1 e2 e2' t1 t2 m m',
    Precision MEmpty e1 t1 MEmpty e2 t2 ->
    Value e1 ->
    m / e2 --> m' / e2' -> m = m'.
Proof.
  intros * HP HV HStep.
  remember MEmpty as Γ.
  generalize dependent e2'.
  induction HP; intros * HStep; inversion HV;
  inversion HStep; subst; eauto using Precision.
Qed.

Ltac ForceΓEmpty Γ :=
    replace Γ with (@MEmpty IRType) in *
      by (symmetry; eauto using PPE, EnvCompEmpty).

(*
** Catch-up steps preserve precision
*)
Lemma PrecisionPreservation : forall e1 e2 e2' t1 t2 m m',
    Precision MEmpty e1 t1 MEmpty e2 t2 ->
    Value e1 ->
    m / e2 --> m' / e2' ->
    Precision MEmpty e1 t1 MEmpty e2' t2.
Proof.
  intros * HP HV HStep.
  remember MEmpty as Γ.
  generalize dependent e2'.
  induction HP; subst; intros * HStep; inversion HV; subst;
  ForceΓEmpty Γ;
  inversion HStep; subst; eauto using Precision;
  try (inversion HP; subst; trivial; fail).

  exfalso.
  apply PrecisionType1 in HP. inversion HP; subst.
  ContraTags.
Qed.

(*
** Catch-up multi-steps preserve precision
*)
Lemma PrecisionPreservationMult : forall e1 e2 e2' t1 t2 m m',
    Precision MEmpty e1 t1 MEmpty e2 t2 ->
    Value e1 ->
    m / e2 -->* m' / e2' ->
    Precision MEmpty e1 t1 MEmpty e2' t2.
Proof.
  induction 3; eauto using PrecisionPreservation.
Qed.

(*
** Catch-up applied to boxes: if the term "catching-up" is a box,
** it remains a box.
*)
Lemma BoxPreservePrecision : forall e m m' b tg v t,
  m / IREBox tg e -->* m' / b ->
  Precision MEmpty v t MEmpty (IREBox tg e) IRTStar ->
  Value v ->
  exists o, b = IREBox tg o /\ Precision MEmpty v t MEmpty b IRTStar.
Proof.
  intros * Hst.
  remember (IREBox tg e) as E.
  generalize dependent e.
  induction Hst; intros * HEq HP HV; eauto.
  - subst.
    replace m' with m in * by (eauto using stepValueMem).
    inversion H; subst.
    eauto using PrecisionPreservation.
Qed.

Ltac typePrecLT :=
  match goal with
    [HP: Precision _ _ ?t _ _ (Tag2Type ?g),
     HT: ?t <| Tag2Type ?tg |- _] =>
       replace g with tg in * by (eauto using GroundTop, PPT)
  end.

(*
** If the term "catching-up" has type '*', it converges to a box.
*)
Lemma ValueStarP : forall tg t v e m e',
    Precision MEmpty v t MEmpty e IRTStar ->
    t <| Tag2Type tg ->
    Value v ->
    m / e -->* m / e' ->
    Value e' ->
      exists o,
        e' = IREBox tg o /\ Precision MEmpty v t MEmpty e' IRTStar.
Proof.
  intros * HP HSty HVP HStep HV.
  inversion HP; subst; try (inversion HVP; fail);
  ContraTags.
  typePrecLT.
  eauto using BoxPreservePrecision.
Qed.

(*
** Obs: reduction uses only unbox(box x); it does not change memory
*)
Theorem CatchUp : forall e1 t1 e2 t2 m,
  Precision MEmpty e1 t1 MEmpty e2 t2 ->
  Value e1 ->
  exists e2', m / e2 -->* m / e2' /\ Value e2'.
Proof.
  intros * HP HV.
  remember MEmpty as Γ eqn:Heq.
  induction HP; subst; inversion HV; subst;
  (* instanciate and break induction hypothesis *)
  try match goal with
  [IH: _ -> Value ?E -> _ ,
   HV: Value ?E |- _] =>
     specialize (IH eq_refl HV) as [? [? ?]]
  end;
  try (eexists; split; eauto using MStRefl, Value; fail);
  try (eexists; split; eauto using CongBox, Value; fail);

  pose proof HP as HP';
  apply PrecisionType1 in HP';
  inversion HP'; subst; clear HP';
  ContraTags;
  ForceΓEmpty Γ;

  specialize (ValueStarP HP H HV H0 H1) as [? [? _]];
      subst;

  try (eapply GroundType in H; only 2: (simpl; trivial);
    apply valBoxVal in H1;
    exists x0; split;
    eauto using multiTrans, CongUnbox, StUnbox, multistep).
Qed.

Ltac BreakIH :=
  match goal with
    [IH: context [_ / ?E --> _ / _ -> (PrecMem _ _) -> _] ,
     HSt: ?M / ?E --> _ / _ ,
     HM: ?M <M| ?M' |- _ ] =>
       specialize (IH eq_refl _ _ _ _ HSt HM) as [? [? [? [? ?]]]]
  end.

Lemma NoValueUnbox : forall tg e (C : Type),
    Value (IREUnbox tg e) -> C.
Proof.
  intros * H.
  exfalso.
  inversion H.
Qed.

Ltac NoValueUnbox :=
  match goal with [H: Value (IREUnbox _ _) |- _] =>
    eapply NoValueUnbox; eauto
  end.

(* Try to instantiate CatchUp. First, find a precision relation HP.
   If its E' already progresses, there is nothing to be done. (Probably
   the tactic already handled that case.) Otherwise, try to prove
   that E is a value. If so, instantiate CatchUp. *)
Ltac doCatchUp :=
  match goal with
  [ HP: Precision _ ?E _ _ ?E' _ |- context [?M / _ -->* _ / _] ] =>
      match goal with
      | [ H: _ / E' -->* _ / _  |- _ ] => fail 1  (* already done *)
      | [ |- _ ] =>  (* otherwise *)
        assert (HXX: Value E) by eauto using Value;
        specialize (CatchUp M HP HXX) as [? [? ?]];
        clear HXX
      end
  end.

Ltac applyRules := repeat split;
  eauto 9 using EnvCompRefl, CongBox, CongUnbox,
    multiTrans, EnvCompRefl,
    CongPlus1, CongPlus2, CongGet1, CongGet2,
    CongApp1, CongApp2, CongSet1, CongSet2, CongSet3, CongLet,
    PrecQueryT, PrecUpdate, PrecSubs, map_eq_refl,
    Precision, PrecisionPreservationMult, multiTrans, multistep1, step
.

Ltac solveSim2 := eexists; eexists; applyRules.

Ltac solveSim1 m := eexists; exists m; applyRules.

Ltac solveSim e m := exists e; exists m; applyRules.

(*
** Main simulation lemma
*)
Theorem Sim : forall m1 e1 t1 e2 m2 t2 m1' e1',
  Precision MEmpty e1 t1 MEmpty e2 t2 ->
  m1 / e1 --> m1' / e1'   ->
  m1 <M| m2 ->
  exists e2' m2',
    m2 / e2 -->* m2' / e2' /\ m1' <M| m2' /\ Precision MEmpty e1' t1 MEmpty e2' t2.
Proof.
  intros * HP.
  generalize dependent m2.
  generalize dependent e1'.
  generalize dependent m1'.
  generalize dependent m1.
  remember MEmpty as Γ.
  induction HP; intros * Hstep HM;

  (* Handle BoxR and UnboxR, which should not invert step *)
  try (subst; BreakIH; solveSim2;
    fail);

  inversion Hstep; subst; repeat BreakIH;
  try ForceΓEmpty Γ;

  repeat doCatchUp;

  (* Handle all "congruence" cases *)
  try (solveSim1 x0; fail).

  - (* StPlus *)
    assert (N1: x = IRENum n1). {
      specialize (PrecisionPreservationMult HP1 (Vnum n1) H) as NH1.
      inversion NH1; subst; trivial; NoValueUnbox.
    }

    assert (N2: x0 = IRENum n2). {
      specialize (PrecisionPreservationMult HP2 (Vnum n2) H1) as NH2.
      inversion NH2; subst; trivial; NoValueUnbox.
    }

    subst.
    solveSim (IRENum (n1 + n2)) m2.

  - (* StCstr *)
    specialize (PrecFreshT HM H0) as [? [? ?]].
    solveSim2.

  - (* StGet *)
    clear IHHP1 IHHP2.

    assert (N1: x = IRETAddr a). {
      specialize (PrecisionPreservationMult HP1 (Vtbl a) H) as NH1.
      inversion NH1; subst; trivial; NoValueUnbox.
    } subst.

    solveSim (queryT a x0 m2) m2.

  - (* StSet *)
    clear IHHP1 IHHP2 IHHP3.

    assert (N1: x = IRETAddr a). {
      specialize (PrecisionPreservationMult HP1 (Vtbl a) H) as NH1.
      inversion NH1; subst; trivial; NoValueUnbox.
    } subst.

    exists IRENil. eexists (UpdateT _ _ (EV x1 H4) _).
    applyRules.

  - (* StLet *)
    clear IHHP1 IHHP2.
    solveSim ([var := x] b2) m2.

  - (* StFun *)
    clear IHHP.
    specialize (PrecFreshF HM HP H5) as [? [? ?]].
    solveSim2.

  - (* StApp *)
    clear IHHP1 IHHP2.

    assert (N1: x0 = IREFAddr a). {
      specialize (PrecisionPreservationMult HP2 (Vfun a) H1) as NH1.
      inversion NH1; subst. eauto. NoValueUnbox.
    }
    subst.

    destruct (queryF a m2) as [var' body'] eqn:HEq2. symmetry in HEq2.
    specialize (PrecQueryF _ HM H5 HEq2) as [? ?]; subst.
    solveSim (IRELet var' IRTStar x body') m2.

  - (* StUnbox *)
    clear IHHP.
    inversion HP; subst; ContraTags.
    * exfalso. apply PPT in H1. ContraTags.
    * specialize (ValueStarP H3 (TPrecisionRefl (Tag2Type g))
        H5 H H0) as [? [? ?]].
      subst.
      solveSim2.

Qed.

(*
** Simulation theorem
*)
Theorem SimMult : forall m1 e1 t1 e2 m2 t2 m1' e1',
  m1 / e1 -->* m1' / e1'   ->
  Value e1' ->
  Precision MEmpty e1 t1 MEmpty e2 t2 ->
  m1 <M| m2 ->
  exists e2' m2',
    m2 / e2 -->* m2' / e2' /\
    Precision MEmpty e1' t1 MEmpty e2' t2 /\
    m1' <M| m2' /\
    Value e2'.
Proof.
  intros * HMSt.
  generalize dependent m2.
  generalize dependent t2.
  generalize dependent e2.
  induction HMSt; intros * HV HPE HMem.
  - specialize (CatchUp m2 HPE HV) as [? [? ?]].
    eexists. eexists; repeat split; eauto using PrecisionPreservationMult.
  - specialize (Sim HPE H HMem) as [? [? [? [? ?]]]].
    specialize (IHHMSt _ _ _ HV H2 H1) as [? [? [? [? [? ?]]]]].
    exists x1. exists x2. repeat split; eauto using multiTrans.
Qed.

(*
** Simulation theorem for programmers: no mentions to precision,
** concept expressed only in terms of 'dyn'
*)
Corollary SimDyn : forall m1 e1 t1 m1' e1',
  m1 / e1 -->* m1' / e1'   ->
  MEmpty |= e1 : t1 ->
  mem_correct m1 ->
  Value e1' ->
  exists e2' m2',
    m1 / dyn e1 -->* m2' / e2' /\
    e2' = dyn e1' /\
    (* m1' <M| m2' /\ *)
    Value e2'.
Proof.
  intros * HSt Hty HM HV.
  assert(Precision MEmpty e1 t1 MEmpty (dyn e1) IRTStar)
    by (eapply DynLessPrecise; trivial).
  assert (m1 <M| m1) by auto using PrecMemRefl.
  specialize (SimMult HSt HV H H0) as [? [? [? [? [? ?]]]]].
  eexists x. eexists. repeat split;
  eauto using PrecDynEqualVal.
Qed.


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.

From Coq Require Import
     Relation_Definitions
     RelationClasses
     Morphisms
.

Require Import GHC.Base.
Require Import Fix.
Require Import Tactics.Tactics.

Require Import Adverb.Composable.Adverb.
Require Import Adverb.Composable.Purely.
Require Import Adverb.Composable.Dynamically.

Section EqBindK.

  Variable D : (Set -> Set) -> Set -> Set.
  Context `{PurelyAdv -≪ D} `{DynamicallyAdv -≪ D} `{Functor1 D}.

  Definition DynamicallyK {A B : Set} := A -> Fix1 D B.

  Variable R : (forall (A : Set), relation (Fix1 D A)) ->
               forall (A : Set), relation (Fix1 D A).

  Definition EqDynamicallyK (A B : Set) :
      relation (DynamicallyK) :=
    fun (x y : A -> Fix1 D B) => forall (a : A), FixRel R _ (x a) (y a).

  Global Instance OrderEqDynamicallyK {A B : Set}
         `{forall (A : Set), PreOrder (FixRel R A)} :
    PreOrder (@EqDynamicallyK A B).
  Proof.
    constructor.
    - intros x ?. reflexivity.
    - intros x y z Hxy Hyz ?.
      etransitivity; auto.
  Qed.

  Global Instance EquivEqDynamicallyK {A B : Set}
         `{forall (A : Set), Equivalence (FixRel R A)} :
    Equivalence (@EqDynamicallyK A B).
  Proof.
    constructor.
    - intros x ?. reflexivity.
    - intros x y Hxy ?. symmetry. apply Hxy.
    - intros x y z Hxy Hyz ?.
      etransitivity; auto.
  Qed.

End EqBindK.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import excl.
From iris.heap_lang.lib Require Import lock.
Set Default Proof Using "Type".

Definition newlock : val := λ: <>, ref #false.
Definition try_acquire : val := λ: "l", CAS "l" #false #true.
Definition acquire : val :=
  rec: "acquire" "l" := if: try_acquire "l" then #() else "acquire" "l".
Definition release : val := λ: "l", "l" <- #false.

(** The CMRA we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class lockG Σ := LockG { lock_tokG :> inG Σ (exclR unitC) }.
Definition lockΣ : gFunctors := #[GFunctor (exclR unitC)].

Instance subG_lockΣ {Σ} : subG lockΣ Σ → lockG Σ.
Proof. solve_inG. Qed.

Section proof.
  Context `{!heapG Σ, !lockG Σ} (N : namespace).

  Definition lock_inv (γ : gname) (l : loc) (R : iProp Σ) : iProp Σ :=
    (∃ b : bool, l ↦ #b ∗ if b then True else own γ (Excl ()) ∗ R)%I.

  Definition is_lock (γ : gname) (lk : val) (R : iProp Σ) : iProp Σ :=
    (∃ l: loc, ⌜lk = #l⌝ ∧ inv N (lock_inv γ l R))%I.

  Definition locked (γ : gname) : iProp Σ := own γ (Excl ()).

  Lemma locked_exclusive (γ : gname) : locked γ -∗ locked γ -∗ False.
  Proof. iIntros "H1 H2". by iDestruct (own_valid_2 with "H1 H2") as %?. Qed.

  Global Instance lock_inv_ne γ l : NonExpansive (lock_inv γ l).
  Proof. solve_proper. Qed.
  Global Instance is_lock_ne l : NonExpansive (is_lock γ l).
  Proof. solve_proper. Qed.

  (** The main proofs. *)
  Global Instance is_lock_persistent γ l R : PersistentP (is_lock γ l R).
  Proof. apply _. Qed.
  Global Instance locked_timeless γ : TimelessP (locked γ).
  Proof. apply _. Qed.

  Lemma newlock_spec (R : iProp Σ):
    {{{ R }}} newlock #() {{{ lk γ, RET lk; is_lock γ lk R }}}.
  Proof.
    iIntros (Φ) "HR HΦ". rewrite -wp_fupd /newlock /=.
    wp_seq. wp_alloc l as "Hl".
    iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
    iMod (inv_alloc N _ (lock_inv γ l R) with "[-HΦ]") as "#?".
    { iIntros "!>". iExists false. by iFrame. }
    iModIntro. iApply "HΦ". iExists l. eauto.
  Qed.

  Lemma try_acquire_spec γ lk R :
    {{{ is_lock γ lk R }}} try_acquire lk
    {{{ b, RET #b; if b is true then locked γ ∗ R else True }}}.
  Proof.
    iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l) "[% #?]"; subst.
    wp_rec. iInv N as ([]) "[Hl HR]" "Hclose".
    - wp_cas_fail. iMod ("Hclose" with "[Hl]"); first (iNext; iExists true; eauto).
      iModIntro. iApply ("HΦ" $! false). done.
    - wp_cas_suc. iDestruct "HR" as "[Hγ HR]".
      iMod ("Hclose" with "[Hl]"); first (iNext; iExists true; eauto).
      iModIntro. rewrite /locked. by iApply ("HΦ" $! true with "[$Hγ $HR]").
  Qed.

  Lemma acquire_spec γ lk R :
    {{{ is_lock γ lk R }}} acquire lk {{{ RET #(); locked γ ∗ R }}}.
  Proof.
    iIntros (Φ) "#Hl HΦ". iLöb as "IH". wp_rec.
    wp_apply (try_acquire_spec with "Hl"). iIntros ([]).
    - iIntros "[Hlked HR]". wp_if. iApply "HΦ"; iFrame.
    - iIntros "_". wp_if. iApply ("IH" with "[HΦ]"). auto.
  Qed.

  Lemma release_spec γ lk R :
    {{{ is_lock γ lk R ∗ locked γ ∗ R }}} release lk {{{ RET #(); True }}}.
  Proof.
    iIntros (Φ) "(Hlock & Hlocked & HR) HΦ".
    iDestruct "Hlock" as (l) "[% #?]"; subst.
    rewrite /release /=. wp_let. iInv N as (b) "[Hl _]" "Hclose".
    wp_store. iApply "HΦ". iApply "Hclose". iNext. iExists false. by iFrame.
  Qed.
End proof.

Typeclasses Opaque is_lock locked.

Definition spin_lock `{!heapG Σ, !lockG Σ} : lock Σ :=
  {| lock.locked_exclusive := locked_exclusive; lock.newlock_spec := newlock_spec;
     lock.acquire_spec := acquire_spec; lock.release_spec := release_spec |}.


Require Import MetaCoq.Template.Loader.

Definition I (t:Type) (x:t) : t := x.
Definition II := I (forall t:Type, t -> t) I.
MetaCoq Quote Recursively Definition qII := II.