(* This file formalises some basic facts about coinductively defined equality == (bisimulation). *)

Require Import defs.
Require Import tactics.

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

Definition peek (t : term) :=
  match t with
  | bot => bot
  | var n => var n
  | app x y => app x y
  | abs x => abs x
  end.

Lemma lem_peek_eq : forall t, t = peek t.
Proof.
  unfold peek; sauto.
Qed.

Lemma lem_peek_eq_match :
  forall t, match t with
            | bot => bot
            | var n => var n
            | app x y => app x y
            | abs x => abs x
            end = t.
Proof.
  sauto.
Qed.

Ltac peek_on t :=
  replace t with (peek t); [ unfold peek; simpl; rewrite lem_peek_eq_match |
                             rewrite <- lem_peek_eq; reflexivity ].
Ltac peek_at n :=
  rewrite lem_peek_eq at n; unfold peek; simpl; rewrite lem_peek_eq_match.

Ltac peek_tac := intros; rewrite lem_peek_eq at 1; unfold peek; sauto.

Tactic Notation "peek" constr(t) := peek_on t.
Tactic Notation "peek" "at" integer(n) := peek_at n.

Lemma lem_shift_simpl_bot : forall d c, shift d c bot = bot.
Proof.
  peek_tac.
Qed.

Lemma lem_shift_simpl_var : forall d c n, shift d c (var n) = var (if c <=? n then n + d else n).
Proof.
  peek_tac.
Qed.

Lemma lem_shift_simpl_app : forall d c t1 t2, shift d c (app t1 t2) = app (shift d c t1) (shift d c t2).
Proof.
  peek_tac.
Qed.

Lemma lem_shift_simpl_abs : forall d c t, shift d c (abs t) = abs (shift d (c+1) t).
Proof.
  peek_tac.
Qed.

Hint Rewrite lem_shift_simpl_bot lem_shift_simpl_var lem_shift_simpl_app lem_shift_simpl_abs : shints.

Lemma lem_subst_simpl_bot : forall n x, subst n x bot = bot.
Proof.
  peek_tac.
Qed.

Lemma lem_subst_simpl_var :
  forall n s m, subst n s (var m) =
                if n <? m then var (m - 1) else if n =? m then shift n 0 s else var m.
Proof.
  peek_tac.
Qed.

Lemma lem_subst_simpl_app : forall n x t1 t2, subst n x (app t1 t2) = app (subst n x t1) (subst n x t2).
Proof.
  peek_tac.
Qed.

Lemma lem_subst_simpl_abs : forall n x t, subst n x (abs t) = abs (subst (n + 1) x t).
Proof.
  peek_tac.
Qed.

Hint Rewrite lem_subst_simpl_bot lem_subst_simpl_var lem_subst_simpl_app lem_subst_simpl_abs : shints.

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

Lemma lem_par_clos_refl : forall R x y, x == y -> par_clos R x y.
Proof.
  coinduction.
Qed.

Lemma lem_par_clos_refl_0 : forall R, reflexive term (par_clos R).
Proof.
  coinduction on 1.
Qed.

Lemma lem_par_clos_sym : forall R, symmetric term R -> symmetric term (par_clos R).
Proof.
  coinduction.
Qed.

Lemma lem_term_eq_refl : reflexive term term_eq.
Proof.
  apply lem_par_clos_refl_0.
Qed.

Lemma lem_term_eq_sym : symmetric term term_eq.
Proof.
  assert (symmetric term (fun _ _ => False)) by scrush.
  pose lem_par_clos_sym; scrush.
Qed.

Lemma lem_term_eq_trans : transitive term term_eq.
Proof.
  coinduction.
Qed.

Lemma lem_term_eq_app : forall x y x' y', x == x' -> y == y' -> app x y == app x' y'.
Proof.
  coinduction.
Qed.

Lemma lem_term_eq_abs : forall x y, x == y -> abs x == abs y.
Proof.
  coinduction.
Qed.

Ltac pose_term_eq := pose proof lem_term_eq_app; pose proof lem_term_eq_abs;
                     pose proof lem_term_eq_refl; pose proof lem_term_eq_sym; pose proof lem_term_eq_trans;
                     autounfold with shints in *.

Add Parametric Relation : term term_eq
    reflexivity proved by (lem_term_eq_refl)
    symmetry proved by (lem_term_eq_sym)
    transitivity proved by (lem_term_eq_trans)
as term_eq_rel.

Add Parametric Morphism : app with
    signature term_eq ==> term_eq ==> term_eq as app_mor.
Proof.
  eauto using lem_term_eq_app.
Qed.

Add Parametric Morphism : abs with
    signature term_eq ==> term_eq as abs_mor.
Proof.
  eauto using lem_term_eq_abs.
Qed.

Add Parametric Morphism : beta_redex with
    signature term_eq ==> term_eq ==> iff as beta_redex_mor.
Proof.
  pose_term_eq; sauto; eapply beta_redex_c; eauto.
Qed.

Lemma lem_beta_redex_morphism : morphism beta_redex.
Proof.
  unfold morphism; intros.
  rewrite <- H0.
  rewrite <- H1.
  auto.
Qed.

Lemma lem_shift_mor : forall d c t t', t == t' -> shift d c t == shift d c t'.
Proof.
  coinduction.
Qed.

Lemma lem_subst_mor_0 : forall n t s s', s == s' -> t[n := s] == t[n := s'].
Proof.
  pose lem_shift_mor; coinduction on 1.
Qed.

Lemma lem_subst_mor : forall n t s t' s', t == t' -> s == s' -> t[n := s] == t'[n := s'].
Proof.
  coinduction CH.
  clear CH; intro; apply lem_subst_mor_0; auto.
Qed.

Add Parametric Morphism (n m : nat) : (shift n m) with
    signature term_eq ==> term_eq as shift_mor.
Proof.
  eauto using lem_shift_mor.
Qed.

Add Parametric Morphism (n : nat) : (subst n) with
    signature term_eq ==> term_eq ==> term_eq as subst_mor.
Proof.
  eauto using lem_subst_mor.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Integers                                                                *
**************************************************************************)

Set Implicit Arguments.
Require Export Coq.ZArith.ZArith.
From TLC Require Import LibTactics LibLogic LibReflect LibRelation.
Export LibTacticsCompatibility.
From TLC Require Export LibNat.

(* --LATER: rename [plus] to [add] everywhere? *)

(* ********************************************************************** *)
(** * Parsing of integers and operations *)

(* ---------------------------------------------------------------------- *)
(** ** Notation for type and operation *)

(** Define [int] as an alias for [Z], the type of integers from Coq's stdlib.
    Create a scope called [Int_scope] for notation on integers. *)

Notation "'int'" := Z : Int_scope.

Infix "+" := Zplus : Int_scope.
Notation "- x" := (Zopp x) : Int_scope.
Infix "-" := Zminus : Int_scope.
Infix "*" := Zmult : Int_scope.

Bind Scope Int_scope with Z.
Delimit Scope Int_scope with I.
Open Scope Int_scope.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited type *)

Instance Inhab_int : Inhab int.
Proof using. intros. apply (Inhab_of_val 0%Z). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Coercion from nat *)

(** Remark: we cannot simply use the coercion:
      Coercion Z_of_nat : nat >-> Z.
   because otherwise when we try to make the coercion opaque using:
      Opaque Z_of_nat.
   the omega fails to work.
   Thus, we introduce an alias, called [nat_to_Z] for [Z_of_nat],
   and we register [nat_to_Z] as coercion.
*)

Definition nat_to_Z := Z_of_nat.

Lemma nat_to_Z_eq_Z_of_nat : nat_to_Z = Z_of_nat.
Proof using. reflexivity. Qed.

Global Opaque nat_to_Z.

Coercion nat_to_Z : nat >-> Z.

(* --TODO: check this coercion is actually the one in use *)

(* ---------------------------------------------------------------------- *)
(** ** Order relation *)

(** The comparison operators on integers are those from [LibOrder],
    not the ones from Coq's [ZArith]. *)

Open Scope Z_scope.
Open Scope comp_scope.

(** The typeclass [le] on type [int] is bound to [Zle], from Coq's
    standard library *)

Instance le_int_inst : Le int := Build_Le Zle.

(* ********************************************************************** *)
(** * Conversion to natural numbers, for tactic programming *)

(** These tactics are helpful to convert a number passed to a Ltac tactic
    into a [nat], regardless of whether it is a [nat] or an [int]. *)

Definition ltac_int_to_nat (x:Z) : nat :=
  match x with
  | Z0 => 0%nat
  | Zpos p => nat_of_P p
  | Zneg p => 0%nat
  end.

Ltac number_to_nat N ::=
  match type of N with
  | nat => constr:(N)
  | int => let N' := constr:(ltac_int_to_nat N) in eval compute in N'
  | Z => let N' := constr:(ltac_int_to_nat N) in eval compute in N'
  (*todo: last case not needed*)
  end.

(* ********************************************************************** *)
(** * Decision procedure *)

(** A lot of hacks to allow calling the [omega] tactic *)

(* ---------------------------------------------------------------------- *)
(** ** Translation from typeclass order to ZArith, for using [omega] *)

Lemma le_zarith : le = Zle.
Proof using. extens*. Qed.

Global Opaque le_int_inst.

Lemma lt_zarith : lt = Zlt.
Proof using.
  extens. rew_to_le. rewrite le_zarith.
  unfold strict. intros. omega.
Qed.

Lemma ge_zarith : ge = Zge.
Proof using.
  extens. rew_to_le. rewrite le_zarith.
  unfold inverse. intros. omega.
Qed.

Lemma gt_zarith : gt = Zgt.
Proof using.
  extens. rew_to_le. rewrite le_zarith.
  unfold strict, inverse. intros. omega.
Qed.

Hint Rewrite le_zarith lt_zarith ge_zarith gt_zarith : rew_int_comp.

Ltac int_comp_to_zarith :=
  autorewrite with rew_int_comp in *.

(* ---------------------------------------------------------------------- *)
(** ** Hypothesis selection *)

(** [is_arity_type T] returns a boolean indicating whether
    [T] is equal to [nat] or [int] *)

Ltac is_arith_type T :=
  match T with
  | nat => constr:(true)
  | int => constr:(true)
  | _ => constr:(false)
  end.

(** [is_arity E] returns a boolean indicating whether
    [E] is an arithmetic expression *)

Ltac is_arith E :=
  match E with
  | _ = _ :> ?T => is_arith_type T
  | _ <> _ :> ?T => is_arith_type T
  | ~ ?E' => is_arith E'
  | ?E' -> False => is_arith E'
  | @le ?T _ _ _ => is_arith_type T
  | @ge ?T _ _ _ => is_arith_type T
  | @lt ?T _ _ _ => is_arith_type T
  | @gt ?T _ _ _ => is_arith_type T
  | (_ <= _)%Z => constr:(true)
  | (_ >= _)%Z => constr:(true)
  | (_ < _)%Z => constr:(true)
  | (_ > _)%Z => constr:(true)
  | (_ <= _)%nat => constr:(true)
  | (_ >= _)%nat => constr:(true)
  | (_ < _)%nat => constr:(true)
  | (_ > _)%nat => constr:(true)
  | _ => constr:(false)
  end.

(** [arith_goal_or_false] looks at the current goal and
    replaces it with [False] if it is not an arithmetic goal*)

Ltac arith_goal_or_false :=
  match goal with |- ?E =>
    match is_arith E with
    | true => idtac
    | false => false
    end
  end.

(** [generalize_arith] generalizes all hypotheses which correspond
    to some arithmetic goal. It destructs conjunctions on the fly. *)

Lemma istrue_isTrue_forw : forall (P:Prop),
  istrue (isTrue P) ->
  P.
Proof using. introv H. rew_istrue~ in H. Qed.

Ltac generalize_arith :=
  repeat match goal with
  | H: istrue (isTrue _) |- _ => generalize (@istrue_isTrue_forw _ H); clear H; intro
  | H:?E1 /\ ?E2 |- _ => destruct H
  | H: ?E -> False |- _ =>
    match is_arith E with
    | true => change (E -> False) with (~ E) in H
    | false => clear H
    end
  | H:?E |- _ =>
    match is_arith E with
    | true => generalize H; clear H (* --todo: revert H? *)
    | false => clear H
    end
  end.

(* --TODO:
Ltac split_if_eq_bool :=
  let go _ := apply eq_bool_prove; intros in
  match goal with
  | |- @eq bool _ _ => go tt
  | |- istrue (@eqb bool _ _ _) => apply eq_to_equ; go tt
  end.
*)

(* ---------------------------------------------------------------------- *)
(** ** Normalization of arithmetic expressions *)

(** Two lemmas to help omega out *)

Lemma Z_of_nat_O :
  Z_of_nat O = 0.
Proof using. reflexivity. Qed.

Lemma Z_of_nat_S : forall n,
  Z_of_nat (S n) = Zsucc (Z_of_nat n).
Proof using. intros. rewrite~ <- Zpos_P_of_succ_nat. Qed.

Lemma Z_of_nat_plus1 : forall n,
  Z_of_nat (1 + n) = Zsucc (Z_of_nat n).
Proof using. intros. rewrite <- Z_of_nat_S. fequals~. Qed.

(** [rew_maths] rewrite any lemma in the base [rew_maths].
    The goal should not contain any evar, otherwise tactic might loop. *)

Hint Rewrite nat_to_Z_eq_Z_of_nat Z_of_nat_O Z_of_nat_S Z_of_nat_plus1 : rew_maths.

Ltac rew_maths :=
  autorewrite with rew_maths in *.

(* ---------------------------------------------------------------------- *)
(** ** Setting up the goal for [omega] *)

(** [math_setup_goal] does introduction, splits, and replace
    the goal by [False] if it is not arithmetic. If the goal
    is of the form [P1 = P2 :> Prop], then the goal is
    changed to [P1 <-> P2]. *)

Ltac math_setup_goal_step tt :=
  match goal with
  | |- _ -> _ => intro
  | |- _ <-> _ => iff
  | |- forall _, _  => intro
  | |- _ /\ _ => split
  | |- _ = _ :> Prop => apply prop_ext; iff
  end.

Ltac math_setup_goal :=
  repeat (math_setup_goal_step tt);
  arith_goal_or_false.

  (* DEPRECATED
  Ltac math_setup_goal :=
    intros;
    try match goal with |- _ /\ _ => split end;
    try match goal with |- _ = _ :> Prop => apply prop_ext; iff end;
    arith_goal_or_false.
    (* try split_if_eq_bool. *)
  *)

(* --TODO; [int_nat_conv]
Lemma int_nat_plus : forall (n m:nat),
  (n + m)%nat = (n + m)%Z :> int.
Proof using. applys inj_plus. Qed.
Hint Rewrite int_nat_plus : int_nat_conv.
*)

(** [math] tactics performs several preprocessing step,
    selects all arithmetic hypotheses, and the call omega. *)
(* --TODO: autorewrite with int_nat_conv in *. after int_comp_to_zarith *)

(* ---------------------------------------------------------------------- *)
(** ** Main driver for the set up process to goal [omega] *)

(* --TODO: this probably is no longer necessary, since
     LibTactic version seems equivalent *)
Ltac check_noevar_goal ::=
  match goal with |- ?G => first [ has_evar G; fail 1 | idtac ] end.

Ltac math_0 := idtac.
Ltac math_1 := intros; generalize_arith.
(* Work around for the slow [autorewrite in *] *)
Ltac math_2 := instantiate; check_noevar_goal.
Ltac math_3 := autorewrite with rew_maths rew_int_comp rew_nat_comp; intros.
(* original:
Ltac math_2 := instantiate; check_noevar_goal; intros.
Ltac math_3 := rew_maths; nat_comp_to_peano; int_comp_to_zarith.
*)
Ltac math_4 := math_setup_goal.
Ltac math_5 := omega.

Ltac math_setup := math_0; math_1; math_2; math_3; math_4.
Ltac math_base := math_setup; math_5.

Tactic Notation "math" := math_base.

Tactic Notation "math" simple_intropattern(I) ":" constr(E) :=
  asserts I: E; [ math | ].
Tactic Notation "maths" constr(E) :=
  let H := fresh "H" in asserts H: E; [ math | ].
(* --TODO: parsing conflit *)

(* ---------------------------------------------------------------------- *)
(** ** [math] tactic restricted to arithmetic goals *)

(** [math_only] calls [math] but only on goals which
    have an arithmetic form. Thus, contracty to [math],
    it does not attempt to look for a contradiction in
    the hypotheses if the conclusion is not an arithmetic
    goal. Useful for efficiency. *)

Ltac math_only_if_arith_core tt :=
  match goal with |- ?T =>
    match is_arith T with true => math end end.

Tactic Notation "math_only_if_arith" :=
  math_only_if_arith_core tt.

(* ---------------------------------------------------------------------- *)
(** ** Elimination of multiplication, to call omega *)

(* In order to use [math] with simple multiplications, add the command:
     Hint Rewrite mult_2_eq_plus mult_3_eq_plus : rew_maths.
   TEMPORARY: these lemmas should go away as [omega] is able to inline
   trivial multiplication by itself
*)

Lemma mult_2_eq_plus : forall x, 2 * x = x + x.
Proof using. intros. ring. Qed.

Lemma mult_3_eq_plus : forall x, 3 * x = x + x + x.
Proof using. intros. ring. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Hint externs for calling math in the hint base [maths] *)

(* --TODO: rename [maths] database to [math] *)

Ltac math_hint := math.

Hint Extern 3 (_ = _ :> nat) => math_hint : maths.
Hint Extern 3 (_ = _ :> int) => math_hint : maths.
Hint Extern 3 (_ <> _ :> nat) => math_hint : maths.
Hint Extern 3 (_ <> _ :> int) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ = _ :> nat))) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ = _ :> int))) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ <> _ :> nat))) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ <> _ :> int))) => math_hint : maths.
Hint Extern 3 ((_ <= _)%nat) => math_hint : maths.
Hint Extern 3 ((_ >= _)%nat) => math_hint : maths.
Hint Extern 3 ((_ < _)%nat) => math_hint : maths.
Hint Extern 3 ((_ > _)%nat) => math_hint : maths.
Hint Extern 3 ((_ <= _)%Z) => math_hint : maths.
Hint Extern 3 ((_ >= _)%Z) => math_hint : maths.
Hint Extern 3 ((_ < _)%Z) => math_hint : maths.
Hint Extern 3 ((_ > _)%Z) => math_hint : maths.
Hint Extern 3 (@le nat _ _ _) => math_hint : maths.
Hint Extern 3 (@lt nat _ _ _) => math_hint : maths.
Hint Extern 3 (@ge nat _ _ _) => math_hint : maths.
Hint Extern 3 (@gt nat _ _ _) => math_hint : maths.
Hint Extern 3 (@le int _ _ _) => math_hint : maths.
Hint Extern 3 (@lt int _ _ _) => math_hint : maths.
Hint Extern 3 (@ge int _ _ _) => math_hint : maths.
Hint Extern 3 (@gt int _ _ _) => math_hint : maths.
Hint Extern 3 (~ @le int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @lt int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @ge int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @gt int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @eq int _ _) => unfold not; math_hint : maths.
Hint Extern 3 (@le int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@lt int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@ge int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@gt int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@eq int _ _ -> False) => math_hint : maths.
Hint Extern 3 (~ @le nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @lt nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @ge nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @gt nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @eq nat _ _) => unfold not; math_hint : maths.
Hint Extern 3 (@le nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@lt nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@ge nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@gt nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@eq nat _ _ -> False) => math_hint : maths.

(* ********************************************************************** *)
(** * Rewriting on arithmetic expressions *)

(* ---------------------------------------------------------------------- *)
(** ** Rewriting equalities provable by the [math] tactic *)

(** [math_rewrite (E = F)] replaces all occurences of [E]
    with the expression [F]. It produces the equality [E = F]
    as subgoal, and tries to solve it using the tactic [math] *)

Tactic Notation "math_rewrite" constr(E) :=
  asserts_rewrite E; [ try math | ].
Tactic Notation "math_rewrite" constr(E) "in" hyp(H) :=
  asserts_rewrite E in H; [ try math | ].
Tactic Notation "math_rewrite" constr(E) "in" "*" :=
  asserts_rewrite E in *; [ try math | ].

Tactic Notation "math_rewrite" "~" constr(E) :=
  math_rewrite E; auto_tilde.
Tactic Notation "math_rewrite" "~" constr(E) "in" hyp(H) :=
  math_rewrite E in H; auto_tilde.
Tactic Notation "math_rewrite" "~" constr(E) "in" "*" :=
  math_rewrite E in *; auto_tilde.

Tactic Notation "math_rewrite" "*" constr(E) :=
  math_rewrite E; auto_star.
Tactic Notation "math_rewrite" "*" constr(E) "in" hyp(H) :=
  math_rewrite E in H; auto_star.
Tactic Notation "math_rewrite" "*" constr(E) "in" "*" :=
  math_rewrite E in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Addition and substraction *)

Lemma plus_zero_r : forall n,
  n + 0 = n.
Proof using. math. Qed.

Lemma plus_zero_l : forall n,
  0 + n = n.
Proof using. math. Qed.

Lemma minus_zero_r : forall n,
  n - 0 = n.
Proof using. math. Qed.

Lemma minus_zero_l : forall n,
  0 - n = (-n).
Proof using. math. Qed.

Lemma mult_zero_l : forall n,
  0 * n = 0.
Proof using. math. Qed.

Lemma mult_zero_r : forall n,
  n * 0 = 0.
Proof using. math. Qed.

Lemma mult_one_l : forall n,
  1 * n = n.
Proof using. math. Qed.

Lemma mult_one_r : forall n,
  n * 1 = n.
Proof using. math. Qed.

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

(** [rew_int] performs some basic simplification on
    expressions involving integers *)

Hint Rewrite plus_zero_r plus_zero_l minus_zero_r minus_zero_l
  mult_zero_l mult_zero_r mult_one_l mult_one_r : rew_nat.

Tactic Notation "rew_int" :=
  autorewrite with rew_int.
Tactic Notation "rew_int" "~" :=
  rew_int; auto_tilde.
Tactic Notation "rew_int" "*" :=
  rew_int; auto_star.
Tactic Notation "rew_int" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_int).
  (* autorewrite with rew_int in *. *)
Tactic Notation "rew_int" "~" "in" "*" :=
  rew_int in *; auto_tilde.
Tactic Notation "rew_int" "*" "in" "*" :=
  rew_int in *; auto_star.
Tactic Notation "rew_int" "in" hyp(H) :=
  autorewrite with rew_int in H.
Tactic Notation "rew_int" "~" "in" hyp(H) :=
  rew_int in H; auto_tilde.
Tactic Notation "rew_int" "*" "in" hyp(H) :=
  rew_int in H; auto_star.

(* ********************************************************************** *)
(** * Conversions of operations from [nat] to [int] and back *)

(** -- LATER: make proofs below no longer depend on Coq's stdlib *)

(* ---------------------------------------------------------------------- *)
(** ** Lifting of comparisons from [nat] to [int] *)

(* --TODO: perhaps only state those as equalities? *)

Lemma eq_nat_of_eq_int : forall (n m:nat),
  (n:int) = (m:int) ->
  n = m :> nat.
Proof using. math. Qed.

Lemma neq_nat_of_neq_int : forall (n m:nat),
  (n:int) <> (m:int) ->
  (n <> m)%nat.
Proof using. math. Qed.

Lemma eq_int_of_eq_nat : forall (n m:nat),
  n = m :> nat ->
  (n:int) = (m:int).
Proof using. math. Qed.

Lemma neq_int_of_neq_nat : forall (n m:nat),
  (n <> m)%nat ->
  (n:int) <> (m:int).
Proof using. math. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Lifting of inequalities from [nat] to [int] *)

Lemma le_nat_of_le_int : forall (n m:nat),
  (n:int) <= (m:int) ->
  (n <= m).
Proof using. math. Qed.

Lemma le_int_of_le_nat : forall (n m:nat),
  (n <= m) ->
  (n:int) <= (m:int).
Proof using. math. Qed.

Lemma lt_nat_of_lt_int : forall (n m:nat),
  (n:int) < (m:int) ->
  (n < m).
Proof using. math. Qed.

Lemma lt_int_of_lt_nat : forall (n m:nat),
  (n < m) ->
  (n:int) < (m:int).
Proof using. math. Qed.

Lemma ge_nat_of_ge_int : forall (n m:nat),
  (n:int) >= (m:int) ->
  (n >= m).
Proof using. math. Qed.

Lemma ge_int_of_ge_nat : forall (n m:nat),
  (n >= m) ->
  (n:int) >= (m:int).
Proof using. math. Qed.

Lemma gt_nat_of_gt_int : forall (n m:nat),
  (n:int) > (m:int) ->
  (n > m).
Proof using. math. Qed.

Lemma gt_int_of_gt_nat : forall (n m:nat),
  (n > m) ->
  (n:int) > (m:int).
Proof using. math. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Lifting of operations from [nat] to [int] *)

Lemma plus_nat_eq_plus_int : forall (n m:nat),
  (n+m)%nat = (n:int) + (m:int) :> int.
Proof using.
  Transparent nat_to_Z.
  intros. unfold nat_to_Z. applys Nat2Z.inj_add.
Qed.

Lemma minus_nat_eq_minus_int : forall (n m:nat),
  (n >= m)%nat ->
  (n-m)%nat = (n:int) - (m:int) :> int.
Proof using.
  Transparent nat_to_Z.
  intros. unfold nat_to_Z. applys Nat2Z.inj_sub. math.
Qed.

(* -- LATER: tactic for lifting all operators and comparisons into Z *)

(* -- LATER: complete with other operators *)

(* -- LATER: is the hint below really necessary?
     if so, there should probably be other hints similar to it *)

Hint Rewrite plus_nat_eq_plus_int : rew_maths.

(* ---------------------------------------------------------------------- *)
(** ** Absolute function in [nat] *)

Notation "'abs'" := Zabs_nat (at level 0).

Global Opaque Zabs Zabs_nat.

Lemma abs_nat : forall (n:nat),
  abs n = n.
Proof using. exact Zabs_nat_Z_of_nat. Qed.

Lemma abs_nonneg : forall (x:int),
  x >= 0 ->
  abs x = x :> int.
Proof using.
  intros. rewrite inj_Zabs_nat.
  rewrite Zabs_eq. math. math.
Qed.

Lemma abs_eq_nat_eq : forall (x:int) (y:nat),
  x >= 0 ->
  (abs x = y :> nat) = (x = Z_of_nat y :> int).
Proof using.
  introv M. extens. iff E.
  { subst. rewrite Zabs2Nat.id_abs, Z.abs_eq; math. }
  { subst. rewrite~ Zabs2Nat.id. }
Qed.

Lemma lt_abs_abs : forall (n m : int),
  (0 <= n) ->
  (n < m) ->
  (abs n < abs m).
Proof using.
  intros. nat_comp_to_peano. apply Zabs_nat_lt. math.
Qed.

(** -- TODO: many useful lemmas missing *)

(* ---------------------------------------------------------------------- *)
(** ** [abs] distribute on constants and operators *)

Lemma abs_0 : abs 0 = 0%nat :> nat.
Proof using. reflexivity. Qed.

Lemma abs_1 : abs 1 = 1%nat :> nat.
Proof using. reflexivity. Qed.

Lemma abs_plus : forall (x y:int),
  (x >= 0) ->
  (y >= 0) ->
  abs (x + y) = (abs x + abs y)%nat :> nat.
Proof using. intros. applys Zabs2Nat.inj_add; math. Qed.

Lemma abs_minus : forall (x y:int),
  (x >= y) ->
  (y >= 0) ->
  abs (x - y) = (abs x - abs y)%nat :> nat.
Proof using. intros. applys Zabs2Nat.inj_sub; math. Qed.

Lemma abs_nat_plus_nonneg : forall (n:nat) (x:int),
  x >= 0 ->
 abs (n + x)%Z = (n + abs x)%nat.
Proof using.
  introv N. applys eq_nat_of_eq_int.
  rewrite plus_nat_eq_plus_int.
  do 2 (rewrite abs_nonneg; [|math]). auto.
Qed.

Lemma abs_gt_minus_nat : forall (n:nat) (x:int),
  (x >= n)%Z ->
 abs (x - n)%Z = (abs x - n)%nat.
Proof using.
  introv N. applys eq_nat_of_eq_int.
  rewrite minus_nat_eq_minus_int.
  do 2 (rewrite abs_nonneg; [|math]). auto.
  applys ge_nat_of_ge_int. rewrite abs_nonneg; math.
Qed.

Lemma succ_abs_eq_abs_one_plus : forall (x:int),
  x >= 0 ->
  S (abs x) = abs (1 + x) :> nat.
Proof using.
  intros x. pattern x. applys (@measure_induction _ abs). clear x.
  intros x IH Pos. rewrite <- Zabs_nat_Zsucc. fequals. math. math.
Qed.

Lemma abs_eq_succ_abs_minus_one : forall (x:int),
  x > 0 ->
  abs x = S (abs (x - 1)) :> nat.
Proof using.
  intros. apply eq_nat_of_eq_int.
  rewrite abs_nonneg; try math.
  rewrite succ_abs_eq_abs_one_plus; try math.
  rewrite abs_nonneg; math.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [rew_abs_nonneg] to normalize expressions involving [abs]
       issuing side-conditions that arguments are nonnegative *)

Hint Rewrite abs_nat abs_0 abs_1 abs_plus abs_nonneg : rew_abs_nonneg.

Tactic Notation "rew_abs_nonneg" :=
  autorewrite with rew_abs_nonneg.
Tactic Notation "rew_abs_nonneg" "~" :=
  autorewrite with rew_abs_nonneg; try math; autos~.


Require Export euclidean__axioms.
Require Export euclidean__tactics.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__doublereverse.
Require Export lemma__inequalitysymmetric.
Require Export lemma__localextension.
Require Export logic.
Definition lemma__differenceofparts : forall A B C a b c, (euclidean__axioms.Cong A B a b) -> ((euclidean__axioms.Cong A C a c) -> ((euclidean__axioms.BetS A B C) -> ((euclidean__axioms.BetS a b c) -> (euclidean__axioms.Cong B C b c)))).
Proof.
intro A.
intro B.
intro C.
intro a.
intro b.
intro c.
intro H.
intro H0.
intro H1.
intro H2.
assert (* Cut *) (euclidean__axioms.Cong B C b c) as H3.
- assert (* Cut *) ((B = A) \/ (euclidean__axioms.neq B A)) as H3.
-- apply (@euclidean__tactics.eq__or__neq B A).
-- assert ((B = A) \/ (euclidean__axioms.neq B A)) as H4 by exact H3.
assert ((B = A) \/ (euclidean__axioms.neq B A)) as __TmpHyp by exact H4.
destruct __TmpHyp as [H5|H5].
--- assert (* Cut *) (euclidean__axioms.Cong A A a b) as H6.
---- apply (@eq__ind__r euclidean__axioms.Point A (fun B0 => (euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.BetS A B0 C) -> (euclidean__axioms.Cong A A a b)))) with (x := B).
-----intro H6.
intro H7.
exact H6.

----- exact H5.
----- exact H.
----- exact H1.
---- assert (* Cut *) (euclidean__axioms.Cong a b A A) as H7.
----- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a A A b H6).
----- assert (* Cut *) (~(euclidean__axioms.neq a b)) as H8.
------ intro H8.
assert (* Cut *) (euclidean__axioms.neq A A) as H9.
------- apply (@euclidean__axioms.axiom__nocollapse a b A A H8 H7).
------- assert (* Cut *) (A = A) as H10.
-------- assert (* Cut *) (False) as H10.
--------- assert (* Cut *) (A = A) as H10.
---------- apply (@logic.eq__refl Point A).
---------- apply (@H9 H10).
--------- assert (False) as H11 by exact H10.
apply (@logic.eq__refl Point A).
-------- apply (@H9 H10).
------ assert (* Cut *) (euclidean__axioms.Cong A C A C) as H9.
------- apply (@euclidean__axioms.cn__congruencereflexive A C).
------- assert (* Cut *) (euclidean__axioms.Cong B C A C) as H10.
-------- apply (@eq__ind__r euclidean__axioms.Point A (fun B0 => (euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.BetS A B0 C) -> (euclidean__axioms.Cong B0 C A C)))) with (x := B).
---------intro H10.
intro H11.
exact H9.

--------- exact H5.
--------- exact H.
--------- exact H1.
-------- assert (* Cut *) (euclidean__axioms.Cong B C a c) as H11.
--------- apply (@eq__ind__r euclidean__axioms.Point A (fun B0 => (euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.BetS A B0 C) -> ((euclidean__axioms.Cong B0 C A C) -> (euclidean__axioms.Cong B0 C a c))))) with (x := B).
----------intro H11.
intro H12.
intro H13.
exact H0.

---------- exact H5.
---------- exact H.
---------- exact H1.
---------- exact H10.
--------- assert (* Cut *) (euclidean__axioms.Cong b c b c) as H12.
---------- apply (@euclidean__axioms.cn__congruencereflexive b c).
---------- assert (* Cut *) (euclidean__axioms.Cong b c a c) as H13.
----------- apply (@eq__ind__r euclidean__axioms.Point b (fun X => euclidean__axioms.Cong b c X c)) with (x := a).
------------ exact H12.
------------apply (@euclidean__tactics.NNPP (a = b) H8).

----------- assert (* Cut *) (euclidean__axioms.Cong a c b c) as H14.
------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a b c c H13).
------------ assert (* Cut *) (euclidean__axioms.Cong B C b c) as H15.
------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B C a c b c H11 H14).
------------- exact H15.
--- assert (* Cut *) (~(C = A)) as H6.
---- intro H6.
assert (* Cut *) (euclidean__axioms.BetS A B A) as H7.
----- apply (@eq__ind__r euclidean__axioms.Point A (fun C0 => (euclidean__axioms.Cong A C0 a c) -> ((euclidean__axioms.BetS A B C0) -> (euclidean__axioms.BetS A B A)))) with (x := C).
------intro H7.
intro H8.
exact H8.

------ exact H6.
------ exact H0.
------ exact H1.
----- assert (* Cut *) (~(euclidean__axioms.BetS A B A)) as H8.
------ apply (@euclidean__axioms.axiom__betweennessidentity A B).
------ apply (@H8 H7).
---- assert (* Cut *) (euclidean__axioms.neq A C) as H7.
----- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C A H6).
----- assert (* Cut *) (exists E, (euclidean__axioms.BetS C A E) /\ (euclidean__axioms.Cong A E A C)) as H8.
------ apply (@lemma__localextension.lemma__localextension C A C H6 H7).
------ destruct H8 as [E H9].
destruct H9 as [H10 H11].
assert (euclidean__axioms.neq A C) as H12 by exact H7.
assert (* Cut *) (euclidean__axioms.neq a c) as H13.
------- apply (@euclidean__axioms.axiom__nocollapse A C a c H12 H0).
------- assert (* Cut *) (euclidean__axioms.neq c a) as H14.
-------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric a c H13).
-------- assert (* Cut *) (exists e, (euclidean__axioms.BetS c a e) /\ (euclidean__axioms.Cong a e a c)) as H15.
--------- apply (@lemma__localextension.lemma__localextension c a c H14 H13).
--------- destruct H15 as [e H16].
destruct H16 as [H17 H18].
assert (* Cut *) (euclidean__axioms.Cong E A A E) as H19.
---------- apply (@euclidean__axioms.cn__equalityreverse E A).
---------- assert (* Cut *) (euclidean__axioms.Cong E A A C) as H20.
----------- apply (@lemma__congruencetransitive.lemma__congruencetransitive E A A E A C H19 H11).
----------- assert (* Cut *) (euclidean__axioms.Cong E A a c) as H21.
------------ apply (@lemma__congruencetransitive.lemma__congruencetransitive E A A C a c H20 H0).
------------ assert (* Cut *) (euclidean__axioms.Cong e a a e) as H22.
------------- apply (@euclidean__axioms.cn__equalityreverse e a).
------------- assert (* Cut *) (euclidean__axioms.Cong e a a c) as H23.
-------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive e a a e a c H22 H18).
-------------- assert (* Cut *) (euclidean__axioms.Cong a c e a) as H24.
--------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a e a c H23).
--------------- assert (euclidean__axioms.Cong E A a c) as H25 by exact H21.
assert (* Cut *) (euclidean__axioms.Cong E A e a) as H26.
---------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive E A a c e a H25 H24).
---------------- assert (* Cut *) (euclidean__axioms.BetS E A C) as H27.
----------------- apply (@euclidean__axioms.axiom__betweennesssymmetry C A E H10).
----------------- assert (* Cut *) (euclidean__axioms.BetS e a c) as H28.
------------------ apply (@euclidean__axioms.axiom__betweennesssymmetry c a e H17).
------------------ assert (* Cut *) (euclidean__axioms.Cong E C e c) as H29.
------------------- apply (@euclidean__axioms.cn__sumofparts E A C e a c H26 H0 H27 H28).
------------------- assert (* Cut *) (euclidean__axioms.BetS E A B) as H30.
-------------------- apply (@euclidean__axioms.axiom__innertransitivity E A B C H27 H1).
-------------------- assert (* Cut *) (euclidean__axioms.BetS e a b) as H31.
--------------------- apply (@euclidean__axioms.axiom__innertransitivity e a b c H28 H2).
--------------------- assert (* Cut *) (euclidean__axioms.Cong C B c b) as H32.
---------------------- apply (@euclidean__axioms.axiom__5__line E A B C e a b c H H29 H0 H30 H31 H26).
---------------------- assert (* Cut *) (euclidean__axioms.Cong b c B C) as H33.
----------------------- assert (* Cut *) ((euclidean__axioms.Cong b c B C) /\ (euclidean__axioms.Cong B C b c)) as H33.
------------------------ apply (@lemma__doublereverse.lemma__doublereverse C B c b H32).
------------------------ destruct H33 as [H34 H35].
exact H34.
----------------------- assert (* Cut *) (euclidean__axioms.Cong B C b c) as H34.
------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B b c C H33).
------------------------ exact H34.
- exact H3.
Qed.


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Export nondet_bool.
From iris_examples.proph Require Import eager_coin_spec.
From iris.prelude Require Import options.

(* Lazy implementation of the eager specification. The value of the coin is
unknown at the time of the creation of the coin. As a consequence, we rely on
a prophecy variable. *)

Definition new_lazy_coin : val :=
  λ: <>, (ref NONE, NewProph).

Definition read_lazy_coin : val :=
  λ: "cp",
  let: "c" := Fst "cp" in
  let: "p" := Snd "cp" in
  match: !"c" with
    NONE => let: "r" := nondet_bool #() in
           "c" <- SOME "r";; resolve_proph: "p" to: "r";; "r"
  | SOME "b" => "b"
  end.

Section proof.
  Context `{!heapGS Σ}.

  Definition val_to_bool (v : val) : bool := bool_decide (v = #true).

  Definition prophecy_to_bool (vs : list (val * val)) : bool :=
    default false (val_to_bool ∘ snd <$> head vs).

  Lemma prophecy_to_bool_of_bool (b : bool) v vs :
    prophecy_to_bool ((v, #b) :: vs) = b.
  Proof. by destruct b. Qed.

  Definition lazy_coin (cp : val) (b : bool) : iProp Σ :=
    (∃ (c : loc) (p : proph_id) (vs : list (val * val)),
        ⌜cp = (#c, #p)%V⌝ ∗ proph p vs ∗
        (c ↦ SOMEV #b ∨ (c ↦ NONEV ∗ ⌜b = prophecy_to_bool vs⌝)))%I.

  Lemma lazy_coin_exclusive (cp : val) (b1 b2 : bool) :
    lazy_coin cp b1 -∗ lazy_coin cp b2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (c1 p1 vs1) "(-> & Hp1 & _)".
    iDestruct "H2" as (c2 p2 vs2) "(% & Hp2 & _)".
    simplify_eq. iApply (proph_exclusive with "Hp1 Hp2").
  Qed.

  Lemma new_lazy_coin_spec :
    {{{ True }}}
      new_lazy_coin #()
    {{{ c b, RET c; lazy_coin c b }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam.
    wp_apply wp_new_proph; first done.
    iIntros (vs p) "Hp".
    wp_alloc c as "Hc".
    wp_pair.
    iApply ("HΦ" $! (#c, #p)%V ).
    rewrite /lazy_coin; eauto 10 with iFrame.
  Qed.

  Lemma read_lazy_coin_spec cp b :
    {{{ lazy_coin cp b }}}
      read_lazy_coin cp
    {{{ RET #b; lazy_coin cp b }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p vs ->) "[Hp [Hc | [Hc ->]]]".
    - wp_lam. wp_load. wp_match.
      iApply "HΦ".
      rewrite /lazy_coin; eauto 10 with iFrame.
    - wp_lam. wp_load. wp_match.
      wp_apply nondet_bool_spec; first done.
      iIntros (r) "_".
      wp_let.
      wp_store.
      wp_apply (wp_resolve_proph with "[Hp]"); first done.
      iIntros (ws) "[-> Hws]".
      rewrite !prophecy_to_bool_of_bool.
      wp_seq.
      iApply "HΦ".
      rewrite /lazy_coin; eauto 10 with iFrame.
  Qed.

End proof.

Definition lazy_coin_spec_instance `{!heapGS Σ} :
  eager_coin_spec.eager_coin_spec Σ :=
  {| eager_coin_spec.new_coin_spec := new_lazy_coin_spec;
     eager_coin_spec.read_coin_spec := read_lazy_coin_spec;
     eager_coin_spec.coin_exclusive := lazy_coin_exclusive |}.

Typeclasses Opaque lazy_coin.


Require Import HoTT HoTT_axioms.
From Coq Require Import ssreflect.

Set Universe Polymorphism.

Class IsFun {A B} (R : A -> B -> Type) :=
  isFun : forall x, IsContr {y:B & R x y} .

Hint Mode IsFun - - ! : typeclass_instances.

Definition sym {A B} (R : A -> B -> Type) := fun b a => R a b.

Typeclasses Opaque sym.

Class IsWeakEquiv {A B} (R : A -> B -> Type) :=
  { isWFun :> IsFun R;
    isWFunSym :> IsFun (sym R) }.

Arguments isFun {_ _ _} _.
Arguments isWFun {_ _ _} _.
Arguments isWFunSym {_ _ _} _.

Definition funR {A B R} : IsFun R -> A -> B := fun H x => (isFun H x).1.1.

Definition center {A B} {R : A -> B -> Type} (F : IsFun R) :
  forall x, R x (funR F x) := fun x => (F x).1.2.

Definition IsFunIsHProp A B (R : A -> B -> Type) : IsHProp (IsFun R).
Proof.
by apply: IsTrunc_Forall => [|?]; [apply: funext|apply: IsHPropIsContr].
Defined.

Definition IsFunSymIsHProp A B (R : A -> B -> Type) : IsHProp (IsFun (sym R)) :=
  IsFunIsHProp B A (sym R).

Instance IsWeakEquiv_sym A B (R : A -> B -> Type) :
  forall (f : IsWeakEquiv R), IsWeakEquiv (sym R).
Proof. by move=> Rwe; split; [apply: isWFunSym|apply isWFun]. Defined.

Definition IsWeakEquiv_IsEquiv A B (R : A -> B -> Type) :
  forall (f : IsWeakEquiv R), IsEquiv (funR (isWFun f)).
Proof.
move=> [f g]; apply: (isequiv_adjointify _ (funR g)) => [x|y] /=.
  exact: (((g (funR f x)).2 (x;(center f) x))..1).
exact: (((f (funR g y)).2 (y;(center g) y))..1).
Defined.

Definition IsFunRf A B (f : A -> B) : IsFun (fun a b => f a = b).
Proof.
move=> a; exists (f a;eq_refl) => - [b b_fa].
by apply: path_sigma_uncurried; exists b_fa; apply: transport_paths_r.
Defined.

Definition IsFunRfsymIsWeakEquiv A B (f : A -> B) :
  IsFun (sym (fun a b => f a = b)) -> IsWeakEquiv (fun a b => f a = b).
Proof. by move=> ?; split=> //; apply: IsFunRf. Defined.

Definition IsFun_sym A A' (R R': A -> A' -> Type) :
  (forall a a', R a a' ≃ R' a a') -> IsFun R -> IsFun R'.
Proof.
move=> ReR' FR x; set R'xFx := ReR' _ _ (center FR x).
exists (funR FR x;R'xFx) => - [y R'xy].
apply: path_sigma_uncurried; have Fxy := ((FR x).2 (y; e_inv' (ReR' _ _) R'xy)).
exists (Fxy..1); have /= := (Fxy..2); move: (Fxy..1) => /= {Fxy} Fxy.
by case: _ / Fxy R'xy => /= ??; apply: Move_equiv_equiv.
Defined.

Class Rel A B := rel : A -> B -> Type.

Hint Mode Rel ! ! : typeclass_instances.
Typeclasses Transparent Rel.

Arguments rel {_ _ _} _ _.

Notation "x ≈ y" := (rel x y) (at level 20).

Class FR_Type A B :=
  { _Rel :> Rel A B;
    _REquiv:> IsWeakEquiv (@rel _ _ _Rel);
  }.

Infix "⋈" := FR_Type (at level 25).

Arguments _Rel {_ _} _.
Arguments _REquiv {_ _} _.
Typeclasses Transparent _Rel.

(*! Universe !*)

Instance FR_Type_def@{i j} : Rel@{j j j} Type@{i} Type@{i} :=
 FR_Type@{i i i i i}.

Hint Extern 0 (?x ≈ ?y) => eassumption : typeclass_instances.

Hint Extern 0 (_Rel _ _ _) => eassumption : typeclass_instances.

Definition FRForall {A A'} {B : A -> Type} {B' : A' -> Type} (RA : Rel A A')
          (RB: forall x y (H: x ≈ y), Rel (B x) (B' y)) :
  Rel (forall x, B x) (forall y, B' y)
  :=
  fun f g => forall x y (H:x ≈ y), f x ≈ g y.

Definition IsFun_id A : IsFun (fun a a' : A => a = a').
Proof. exact: IsFun_sym (fun _ _ => Equiv_id _) (IsFunRf _ _ id). Defined.

Definition FR_Type_id A: FR_Type_def A A.
Proof.
suff : IsWeakEquiv (fun a b : A => a = b) by apply: Build_FR_Type.
split; first exact: IsFun_id.
move=> a; exists (a;eq_refl : sym _ a a) => - [b b_a].
by apply: path_sigma_uncurried; exists b_a^; case: b_a.
Defined.

Instance FP_Type : Type ⋈ Type.
Proof.
  econstructor. unfold rel. unshelve econstructor.
  intro A. unshelve econstructor.
  exists A. apply FR_Type_id.
  intros [B e]. apply path_sigma_uncurried. unshelve eexists.
  cbn. apply univalence.
  unshelve econstructor.
  exact (funR (e.(_REquiv).(isWFun))). apply IsWeakEquiv_IsEquiv.
  cbn. cheat.
  intro A. unshelve econstructor.
  exists A. apply FR_Type_id.
  intros [B e]. apply path_sigma_uncurried. unshelve eexists.
  cbn. apply univalence.
  unshelve econstructor.
  exact (funR (e.(_REquiv).(isWFunSym))).
  unfold sym in e.
  apply (IsWeakEquiv_IsEquiv _ _ _ (IsWeakEquiv_sym _ _ _ (_REquiv e))).
  cbn.
  cheat.
Defined.

Definition IsFun_forall (A A' : Type)
           (B : A -> Type) (B' : A' -> Type)
           (RA : Rel A A')
           (RB: forall x y (H: x ≈ y), Rel (B x) (B' y))
           (eAsym : IsFun (sym RA))
           (eB : forall a a' e, IsFun (RB a a' e)):
  IsFun (FRForall RA RB).
Proof.
  intro f.
  unshelve econstructor.
  - unshelve eexists.
    + intros x. apply ((funR (eB ((funR eAsym) x) x (center eAsym x))) (f (funR eAsym x))).
    + intros a a' ea. cbn.
      pose (e := (eAsym a').2 (a ; ea)).
      apply (transport_eq (fun X => (RB a a' ea) (f a)
                                                  (((eB X .1 a' X .2) (f X .1)).1) .1) e^).
        exact (center (eB a a' ea) (f a)).
  - intros [g efg]. cbn in *. eapply path_sigma_uncurried.
    unshelve eexists. cbn. apply funext.
    + intros a'.
        exact ((((eB (funR eAsym a') a' (center eAsym a')) (f (funR eAsym a'))).2 (g a'; efg _ a' _))..1).
    + cbn. unfold FRForall.
      rewrite transport_forall_cst.
      apply funext; intro a; apply funext; intro a'; apply funext ; intro e. unfold rel in eB.
      rewrite (transport_funext_aux (fun y0 y  =>
                                       forall (e0 : RA a y0), (RB a y0 e0) (f a) y)).
        rewrite transport_forall_cst.
        set (T := (RB a a' e) (f a)).
        rewrite <- (transport_ap T ((fun X : {y : A & sym RA a' y} =>
                                       (((eB X .1 a' X .2)(f X .1)) .1) .1))).
        rewrite <- transport_pp.
        unfold center, funR, isFun.
        set (isContrT := (eB a a' e) (f a)).
        destruct ((eAsym a') .2 (a; e))^. cbn.
        change (transport_eq T (isContrT .2 (g a'; efg a a' e) ..1)
                             (isContrT .1) .2 = efg a a' e).
        apply transport_pr1_path.
Defined.

Hint Extern 1 (Rel (forall x:?A, _) (forall x:?A', _)) =>
  refine (@FRForall A A' _ _ _ _); cbn in *; intros : typeclass_instances.

Definition Forall_sym_sym
           {A A'} {B : A -> Type} {B' : A' -> Type} (RA : Rel A A')
           (RB: forall x y (H: x ≈ y), Rel (B x) (B' y)) :
  forall f g, FRForall RA RB f g ≃ sym (FRForall (sym RA) (fun x y e => sym (RB y x e))) f g.
Proof.
  intros. unshelve econstructor; cbn.
  compute; intros; auto.
  unshelve econstructor.
  - compute; intros; auto.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Defined.

Definition FP_forall (A A' : Type) (eA : A ⋈ A')
           (B : A -> Type) (B' : A' -> Type) (eB : B ≈ B') :
  (forall x : A, B x) ⋈ (forall x : A', B' x).
Proof.
  unshelve econstructor.
  unshelve eapply FRForall.
  intros. eapply eB. typeclasses eauto.
  split.
  apply IsFun_forall; typeclasses eauto.
  eapply IsFun_sym. eapply Forall_sym_sym.
  apply IsFun_forall. destruct eA. destruct _REquiv0. assumption.
  intros. destruct (eB a' a e). destruct _REquiv0. assumption.
Defined.

Inductive list (A : Type) : Type :=
    nil : list A | cons : A -> list A -> list A.

Arguments nil {_}.
Arguments cons {_} _ _.

Notation "[ ]" := nil (format "[ ]").
Notation "[ x ]" := (cons x nil).
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)).

Infix "::" := cons (at level 60, right associativity).

Inductive listR {A B} (R : A -> B -> Type) : list A -> list B -> Type :=
  listR_nil : listR R nil nil
| listR_cons : forall {a b l l'},
    (R a b) -> (listR R l l') -> listR R (a::l) (b::l').

Definition transport_listR_cons A B (RA : A -> B -> Type)
           (a :A) b b' (l: list A ) (lb lb':list B) (h:b=b') (e:lb=lb')
  (E: RA a b) (E': listR RA l lb):
   transport_eq
    (fun Y => listR RA (a::l) Y)
    (ap2 cons h e) (listR_cons _ E E')  =
  listR_cons RA (transport_eq (fun X => RA _ X) h E)
                (transport_eq (fun X : list B => listR RA l X) e E').
  destruct h, e. reflexivity.
Defined.

Definition IsFun_list (A A' : Type) (RA : A -> A' -> Type)
           (FA : IsFun RA) : IsFun (listR RA).
Proof.
  intro l. unshelve econstructor.
  - unshelve eexists.
    + exact (list_rec A (fun _ => list A') []
                      (fun a _ l' => cons (funR FA a) l') l).
    + induction l.
      * exact (listR_nil _).
      * eapply listR_cons; try assumption. apply center.
  - intros [l' ell'].
    induction ell'; cbn.
    + reflexivity.
    + apply path_sigma_uncurried. unshelve eexists; cbn in *.
      * apply ap2. exact (((FA a).2 (b ;r))..1). exact (IHell'..1).
      * rewrite transport_listR_cons. apply ap2.
        exact (((FA a).2 (b ;r))..2).
        exact (IHell'..2).
Defined.

Definition listR_sym_sym A A' (R : A -> A' -> Type) :
  forall l l', listR R l l' ≃ sym (listR (sym R)) l l'.
Proof.
  intros l l'. unshelve econstructor.
  induction 1; constructor; assumption.
  unshelve eapply isequiv_adjointify.
  - induction 1; constructor; assumption.
  - intro e; induction e; cbn. reflexivity.
    apply ap2; try reflexivity; assumption.
  - intro e; induction e; cbn. reflexivity.
    apply ap2; try reflexivity; assumption.
Defined.

Definition FP_list (A A' : Type) (eA : A ⋈ A'):
  list A ⋈ list A'.
Proof.
  unshelve econstructor.
  exact (listR (_Rel eA)).
  split.
  apply IsFun_list; typeclasses eauto.
  eapply IsFun_sym. eapply listR_sym_sym.
  apply IsFun_list. destruct eA. destruct _REquiv0.
  exact isWFunSym0.
Defined.


Require Import SquiggleEq.varInterface.
Require Import SquiggleEq.UsefulTypes.

Section VarPair.

Context {Var T2 vc} {deqnvar : Deq Var} {varcl freshv}
{varclass: @VarType Var vc deqnvar varcl freshv} {deqt2 : Deq T2} (def: T2).

Notation NVar := (Var * T2)%type.

Instance varClassNVar : VarClass NVar vc :=
fun p => varClass (fst p).

Require  Import SquiggleEq.list.
Require  Import Coq.Lists.List.

Instance freshVarsNVar : FreshVars NVar vc:=
fun (n:nat)
  (c : option vc) (avoid suggested : list NVar)
=>
  let vars := freshVars n c (map fst avoid) (map fst suggested) in
  let names := listPad def (map snd suggested) n in
  combine vars names.

Require Import SquiggleEq.tactics.

Lemma freshVarsPosCorrect:
forall (n : nat) (oc : option vc) (avoid original : list NVar),
let lf := freshVarsNVar n oc avoid original in
(NoDup lf /\ list.disjoint lf avoid /\ Datatypes.length lf = n) /\
(forall c : vc, oc = Some c -> forall v : NVar, In v lf -> varClassNVar v = c).
Proof.
  simpl. intros ? ? ? ?. unfold freshVarsNVar.
  addFreshVarsSpec. repnd.
  dands.
- apply (nodup_map fst).
  rewrite <- combine_map_fst2; auto.
  rewrite HfreshVars0. apply listPad_length.
- intros Hl. apply (disjoint_map fst).
  rewrite <- combine_map_fst2; auto.
  rewrite HfreshVars0. apply listPad_length.
- unfold  freshVarsNVar. setoid_rewrite combine_length.
  rewrite HfreshVars0.
  apply Min.min_l. apply listPad_length.
- intros ? ? ? Hin. destruct v.
  apply in_combine in Hin. apply proj1 in Hin.
  eapply HfreshVars in Hin; eauto.
Qed.

Instance vartypePos : VarType NVar vc.
  apply Build_VarType.
  exact freshVarsPosCorrect.
Defined.

End VarPair.