(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** A constructive proof of a non-standard version of the weak Fan Theorem
    in the formulation of which infinite paths are treated as
    predicates. The representation of paths as relations avoid the
    need for classical logic and unique choice. The idea of the proof
    comes from the proof of the weak König's lemma from separation in
    second-order arithmetic [[Simpson99]].

    [[Simpson99]] Stephen G. Simpson. Subsystems of second order
    arithmetic, Cambridge University Press, 1999 *)

Require Import List.
Import ListNotations.

(** [inductively_barred P l] means that P eventually holds above l *)

Inductive inductively_barred P : list bool -> Prop :=
| now l : P l -> inductively_barred P l
| propagate l :
    inductively_barred P (true::l) ->
    inductively_barred P (false::l) ->
    inductively_barred P l.

(** [approx X l] says that [l] is a boolean representation of a prefix of [X] *)

Fixpoint approx X (l:list bool) :=
  match l with
  | [] => True
  | b::l => approx X l /\ (if b then X (length l) else ~ X (length l))
  end.

(** [barred P] means that for any infinite path represented as a predicate,
    the property [P] holds for some prefix of the path *)

Definition barred P :=
  forall (X:nat -> Prop), exists l, approx X l /\ P l.

(** The proof proceeds by building a set [Y] of finite paths
   approximating either the smallest unbarred infinite path in [P], if
   there is one (taking [true]>[false]), or the path [true::true::...]
   if [P] happens to be inductively_barred *)

Fixpoint Y P (l:list bool) :=
  match l with
  | [] => True
  | b::l =>
      Y P l /\
      if b then inductively_barred P (false::l) else ~ inductively_barred P (false::l)
  end.

Lemma Y_unique : forall P l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2.
Proof.
induction l1, l2.
- trivial.
- discriminate.
- discriminate.
- intros H (HY1,H1) (HY2,H2).
  injection H as H.
  pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1.
  subst l1.
  f_equal.
  destruct a, b; firstorder.
Qed.

(** [X] is the translation of [Y] as a predicate *)

Definition X P n := exists l, length l = n /\ Y P (true::l).

Lemma Y_approx : forall P l, approx (X P) l -> Y P l.
Proof.
induction l.
- trivial.
- intros (H,Hb). split.
  + auto.
  + unfold X in Hb.
    destruct a.
    * destruct Hb as (l',(Hl',(HYl',HY))).
      rewrite <- (Y_unique P l' l Hl'); auto.
    * firstorder.
Qed.

Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P [].
Proof.
intros P Hbar.
destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)).
assert (inductively_barred P l) by (apply (now P l), HP).
clear Hbar HP.
induction l as [|a l].
- assumption.
- destruct Hd as (Hd,HX).
  apply (IHl Hd). clear IHl.
  destruct a; unfold X in HX; simpl in HX.
  + apply propagate; assumption.
  + exfalso; destruct (HX H).
Qed.


Set Implicit Arguments.

Require Import Setoid.

Parameter Base : Set.

Inductive arg_type : Set :=
 | base_arg : arg_type
 | pred_arg : pred_type -> arg_type
with pred_type : Set :=
 | pred_done : pred_type
 | pred_fun : arg_type -> pred_type -> pred_type
 | pred_neg_fun : arg_type -> pred_type -> pred_type
 .

Fixpoint arg_sem (a : arg_type) : Type :=
  match a with
  | base_arg => Base
  | pred_arg p => pred_sem p
  end
with pred_sem (p : pred_type) : Type :=
  match p with
  | pred_done => Prop
  | pred_fun a r => arg_sem a -> pred_sem r
  | pred_neg_fun a r => arg_sem a -> pred_sem r
  end.

Definition rel A := A -> A -> Prop.

Fixpoint arg_rel (a : arg_type) : rel (arg_sem a) :=
  match a with
  | base_arg => fun x y => x = y
  | pred_arg p => pred_rel_mut p
  end
with pred_rel_mut p : rel (pred_sem p) :=
  match p with
  | pred_done => fun P Q => P -> Q
  | pred_fun a r => fun P Q => forall x y, arg_rel a x y -> pred_rel_mut r (P x) (Q y)
  | pred_neg_fun a r => fun P Q => forall x y, arg_rel a y x -> pred_rel_mut r (P x) (Q y)
  end
.

Scheme arg_mut_ind := Induction for arg_type Sort Prop
with pred_mut_ind := Induction for pred_type Sort Prop.

Fixpoint pred_rel p : rel (pred_sem p) :=
  match p with
  | pred_done => fun P Q => P -> Q
  | pred_fun base_arg r => fun P Q => forall x, pred_rel r (P x) (Q x)
  | pred_neg_fun base_arg r => fun P Q => forall x, pred_rel r (P x) (Q x)
  | pred_fun (pred_arg p) r => fun P Q => forall x y, pred_rel p x y -> pred_rel r (P x) (Q y)
  | pred_neg_fun (pred_arg p) r => fun P Q => forall x y, pred_rel p y x -> pred_rel r (P x) (Q y)
  end
.

Require Import Setoid.

Lemma reps : forall p P Q, pred_rel p P Q <-> pred_rel_mut p P Q.
intro p.
induction p using pred_mut_ind
  with (P := fun a => match a with
     | base_arg => True
     | pred_arg p => forall P Q, pred_rel p P Q <-> pred_rel_mut p P Q
     end);trivial.

reflexivity.

destruct a;simpl;
repeat match goal with
 [H : forall P Q, _ <-> _ |- _] => setoid_rewrite H;clear H
end.

split;intros;subst;auto.

reflexivity.

destruct a;simpl;
repeat match goal with
 [H : forall P Q, _ <-> _ |- _] => setoid_rewrite H;clear H
end.

split;intros;subst;auto.

reflexivity.
Qed.

Definition RRel := Base -> (Base -> Prop) -> Prop.
Definition rrel_type : pred_type :=
  pred_fun base_arg (pred_fun (pred_arg (pred_fun base_arg pred_done)) pred_done).

Lemma rrel_rep : RRel = pred_sem rrel_type.
Proof. reflexivity. Defined.

Definition subrel (A B : RRel) : Prop := forall x P, A x P -> B x P.
Definition mono (F : RRel -> RRel) : Prop :=
  forall (S T : RRel), subrel S T -> subrel (F S) (F T).

Definition weakenable (R : RRel) : Prop :=
  forall (P Q : Base -> Prop), (forall x, P x -> Q x) ->
     forall x, (R x P -> R x Q).

Lemma weaken_good : forall R, weakenable R <-> pred_rel rrel_type R R.
firstorder.
Qed.

Definition adj_weak (F : RRel -> RRel) : Prop :=
  forall (X Y : RRel),
    (forall (P Q : Base -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, X x P -> Y x Q)) ->
    forall (P Q : Base -> Prop),
       (forall x, P x -> Q x) ->
       forall x, F X x P -> F Y x Q.

Definition adj1 (F : RRel -> RRel) : Prop :=
  forall (X Y : RRel),
     (forall x P, X x P -> Y x P) ->
    (forall x P, F X x P -> F Y x P).
Definition adj2 (F : RRel -> RRel) : Prop :=
  forall (P Q : Base -> Prop),
    (forall x, P x -> Q x) ->
    forall (X : RRel) x, F X x P -> F X x Q.

Goal forall F, adj1 F -> adj2 F -> adj_weak F.
unfold adj1, adj2, adj_weak.
intros.
eauto.
Qed.

Lemma adj_arg :
  forall (X Y : RRel),
    (forall (P Q : Base -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, X x P -> Y x Q))
    <-> pred_rel rrel_type X Y.
firstorder.
Qed.

Lemma adj_good : forall R, adj_weak R <->
  pred_rel (pred_fun (pred_arg rrel_type) rrel_type) R R.
unfold adj_weak.
setoid_rewrite adj_arg.
reflexivity.
Qed.

Definition lift_weakenable (R : RRel -> RRel) : Prop :=
  forall X, weakenable X -> weakenable (R X).

Definition lift_rrel (R : RRel -> RRel) : Prop :=
  forall (X Y : RRel),
    (forall x P, X x P -> Y x P) ->
    (forall x P, R X x P -> R Y x P).

Goal forall R, lift_rrel R <-> (forall X Y, subrel X Y -> subrel (R X) (R Y)).
firstorder.
Qed.
(* Aka, mono *)

Definition mk_weak (X : RRel) : RRel :=
  fun x Q => exists (P : Base -> Prop),
    (forall x, P x -> Q x) /\ X x P.

Lemma weakens : forall X, weakenable (mk_weak X).
firstorder.
Qed.

Lemma adj_from_props : forall R, lift_weakenable R -> lift_rrel R -> adj_weak R.
intros.
unfold adj_weak.
intros.
(* cut through mk_weak X *)
assert (forall x P, X x P -> mk_weak X x P).
  firstorder.
apply H0 in H4.
apply H4 in H3.
assert (weakenable (mk_weak X)) by apply weakens.
specialize (H _ H5 _ _ H2).
apply H in H3.
revert H3.
apply H0.
clear -H1.
firstorder.
Qed.

Goal forall R, adj_weak R -> lift_weakenable R.
firstorder.
Qed.

Goal forall R, lift_rrel R -> (lift_weakenable R <-> adj_weak R).
intros;split.
auto using adj_from_props.
firstorder.
Qed.

(*
Eval compute in pred_rel
  (pred_neg_fun (pred_arg rrel_type)
  (pred_fun (pred_arg rrel_type)
            rrel_type)).
 *)

(* adj_weak doesn't seem to imply lift_rrel *)

(*
Definition weakenable (R : (Base -> Prop) -> Base -> Prop) : Prop :=
  forall P Q, pred_rel (pred_fun base_arg pred_done) P Q ->
              pred_rel (pred_fun base_arg pred_done) (R P) (R Q).

Definition mono_rel : rel Prop := fun P Q => P -> Q.
Definition pred_rel : rel (Base -> Prop) :=
  fun P Q => forall b, mono_rel (P b) (Q b).

(P Q : Prop) : Prop := P -> Q.
Definition mono_pred (P Q : Base -> Prop) : Prop :=
  forall
 *)


(******************************************************************************)
(*       Copyright (C) 2019-2021 Florent Hivert <florent.hivert@lri.fr>       *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import order.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.Syntax.
Import Order.TTheory.

(** Clone of option nat to avoid the very confusing chain of coercions *)
(**   option -> bool -> nat                                            *)

Section NatBar.

Open Scope order_scope.

Inductive natbar : Set :=  Nat of nat | Inf.
Definition opt_natbar (v : natbar) : option nat :=
  if v is Nat n then Some n else None.
Definition natbar_opt (v : option nat) : natbar :=
  if v is Some n then Nat n else Inf.

Lemma opt_natbarK : cancel opt_natbar natbar_opt.
Proof. by case. Qed.
Lemma natbar_optK : cancel natbar_opt opt_natbar.
Proof. by case. Qed.
Definition natbar_eqMixin := CanEqMixin opt_natbarK.
Canonical natbar_eqType := Eval hnf in EqType natbar natbar_eqMixin.
Definition natbar_choiceMixin := CanChoiceMixin opt_natbarK.
Canonical natbar_choiceType := Eval hnf in ChoiceType natbar natbar_choiceMixin.
Definition natbar_countMixin := CanCountMixin opt_natbarK.
Canonical natbar_countType := Eval hnf in CountType natbar natbar_countMixin.

Implicit Type (m n o p : nat).
Implicit Type (u v w x y : natbar).

Lemma Nat_inj : injective Nat. Proof. by move=> m n []. Qed.
Lemma Nat_eqE m n : (Nat m == Nat n) = (m == n).
Proof. by apply/eqP/eqP => [/Nat_inj|<-]. Qed.

Definition addbar u v : natbar :=
  match u, v with
  | Nat m, Nat n => Nat (m + n)
  | _, _ => Inf
  end.

Lemma add0bar : left_id  (Nat 0) addbar. Proof. by case. Qed.
Lemma addbar0 : right_id (Nat 0) addbar.
Proof. by case=> //= n; rewrite addn0. Qed.

Lemma addIbar : left_zero  Inf addbar. Proof. by case. Qed.
Lemma addbarI : right_zero Inf addbar. Proof. by case. Qed.

Lemma addbarCA : left_commutative addbar.
Proof. by case=> [m|] [n|] [p|] //=; rewrite addnCA. Qed.

Lemma addbarC : commutative addbar.
Proof. by case=> [m|] [n|] //=; rewrite addnC. Qed.

Lemma addbarA : associative addbar.
Proof. by case=> [m|] [n|] [p|] //=; rewrite addnA. Qed.

Lemma addbarAC : right_commutative addbar.
Proof. by case=> [m|] [n|] [p|] //=; rewrite addnAC. Qed.

Lemma addbarACA : interchange addbar addbar.
Proof. by case=> [m|] [n|] [p|] [q|] //=; rewrite addnACA. Qed.

Lemma addbar_eq0 u v : (addbar u v == Nat 0) = (u == Nat 0) && (v == Nat 0).
Proof.
by case: u v => [m|] [n|] //=; rewrite !Nat_eqE /= ?addn_eq0 ?andbF.
Qed.

Lemma addbar_eqI u v : (addbar u v == Inf) = (u == Inf) || (v == Inf).
Proof. by case: u v => [m|] [n|]. Qed.

Canonical natbar_monoid := Monoid.Law addbarA add0bar addbar0.
Canonical natbar_comoid := Monoid.ComLaw addbarC.

(** Valuation ordering *)
Definition lebar u v :=
  match u, v with
  | _, Inf => true
  | Nat m, Nat n => m <= n
  | _, _ => false
  end.
Definition ltbar u v := (v != u) && (lebar u v).
Definition meetbar x y := if ltbar x y then x else y.
Definition joinbar x y := if ltbar x y then y else x.
Definition lebar_display : unit. Proof. exact: tt. Qed.

Program Definition natbar_OrderMixin :=
  @LeOrderMixin _ lebar ltbar meetbar joinbar _ _ _ _ _ _.
Next Obligation. by case=> [m|] [n|] //=; rewrite -eqn_leq => /eqP ->. Qed.
Next Obligation. by case=> [m|] [n|] [p|] //=; apply leq_trans. Qed.
Next Obligation. by case=> [m|] [n|] //=; exact: leq_total. Qed.

Canonical natbar_porderType :=
  Eval hnf in POrderType lebar_display natbar natbar_OrderMixin.
Canonical natbar_atticeType :=
  Eval hnf in LatticeType natbar natbar_OrderMixin.
Canonical natbar_distrLatticeType :=
  Eval hnf in DistrLatticeType natbar natbar_OrderMixin.
Canonical natbar_orderType :=
  Eval hnf in OrderType natbar natbar_OrderMixin.

Lemma le0bar v : Nat 0 <= v. Proof. by case: v. Qed.
Canonical natbar_bLatticeType :=
  Eval hnf in BLatticeType natbar (BottomMixin le0bar).

Lemma leEnatbar (n m : nat) : (Nat n <= Nat m) = (n <= m)%N.
Proof. by []. Qed.

Lemma ltEnatbar (n m : nat) : (Nat n < Nat m) = (n < m)%N.
Proof. by rewrite lt_neqAle leEnatbar Nat_eqE ltn_neqAle. Qed.

Lemma lebar_total : total lebar.
Proof. exact: le_total. Qed.

Lemma lebarI v : v <= Inf. Proof. by case v. Qed.

Canonical natbar_tbDistrLatticeType :=
  Eval hnf in TBLatticeType natbar (TopMixin lebarI).

Lemma ltbar0Sn n : 0 < Nat n.+1.       Proof. by []. Qed.
Lemma ltbarS n : Nat n < Nat n.+1.     Proof. by rewrite ltEnatbar. Qed.
Lemma lebarS n : Nat n <= Nat n.+1.    Proof. by rewrite leEnatbar. Qed.
Hint Resolve lebarS : core.
Lemma ltIbar v : Inf < v = false.      Proof. exact/le_gtF/lex1. Qed.
Lemma leInatbar n : Inf <= Nat n = false.
Proof. by []. Qed.

Lemma minbarE : {morph Nat : m n / minn m n >-> Order.meet m n}.
Proof.
move=> m n; case: (leqP m n) => [| /ltnW].
- by rewrite -leEnatbar => /meet_idPl.
- by rewrite -leEnatbar => /meet_idPr.
Qed.

Lemma maxbarE : {morph Nat : m n / maxn m n >-> Order.join m n}.
Proof.
move=> m n; case: (leqP m n) => [| /ltnW].
- by rewrite -leEnatbar => /join_idPr.
- by rewrite -leEnatbar => /join_idPl.
Qed.

End NatBar.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 4 *)

Require Import Frap.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(* In Lab 4, we saw a few ways to model function calls with operational
 * semantics.  In this problem set, we extend the picture with *exceptions*,
 * including their interactions with function calls.  But first, the same old
 * boring language of expressions. *)

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Definition valuation := fmap var nat.

Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (then_ else_ : cmd)
| While (e : arith) (body : cmd)
| Call (lhs f : var) (arg : arith)
| InCall (v : valuation) (lhs ret : var) (c : cmd)

(* The new cases: *)

| Try (try : cmd) (exn : var) (handler : cmd)
(* Run [try].  If it throws an uncaught exception, switch to running [handler],
 * with variable [exn] bound to the exception that was thrown. *)

| Throw (e : arith).
(* Abort normal execution, throwing the value of [e]. *)

(* Boring old expression interpreter *)
Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Minus e1 e2 => interp e1 v - interp e2 v
  | Times e1 e2 => interp e1 v * interp e2 v
  end.

(* Function specifications, as in the lab *)
Record fun_spec := {
  Arg : var;
  Ret : var;
  Body : cmd
}.

Definition environment := fmap var fun_spec.

(* To describe the results of our big-step semantics, we need this new type. *)
Inductive outcome :=
| Normal
  (* Execution finished normally. *)

| Exception (exn : nat).
  (* Execution finished with this uncaught exception.
   * Note that our exceptions are numbers, since our expressions all evaluate to
   * numbers. *)

Section env.

  Variable env : environment.

  (** Big-step semantics *)
  Inductive eval : valuation -> cmd -> outcome * valuation -> Prop :=
  | EvalSkip : forall v,
      eval v Skip (Normal, v)
    (* Note that the old rules tend to return [Normal] values. *)
  | EvalAssign : forall v x e,
      eval v (Assign x e) (Normal, v $+ (x, interp e v))
  | EvalSeq : forall v c1 v1 c2 ov2,
      eval v c1 (Normal, v1)
      -> eval v1 c2 ov2
      -> eval v (Sequence c1 c2) ov2
    (* However, this rule passes along whatever is the outcome [ov2] of the
     * second command, be it normal or exceptional. *)
  | EvalSeqExn : forall v c1 exn v1 c2,
      eval v c1 (Exception exn, v1)
      -> eval v (Sequence c1 c2) (Exception exn, v1)
    (* This second [Seq] rule handles the case where the first command raises an
     * exception. *)
  | EvalIfTrue : forall v e then_ else_ ov',
      interp e v <> 0
      -> eval v then_ ov'
      -> eval v (If e then_ else_) ov'
  | EvalIfFalse : forall v e then_ else_ ov',
      interp e v = 0
      -> eval v else_ ov'
      -> eval v (If e then_ else_) ov'
  | EvalWhileTrue : forall v e body v' ov'',
      interp e v <> 0
      -> eval v body (Normal, v')
      -> eval v' (While e body) ov''
      -> eval v (While e body) ov''
  | EvalWhileTrueExn : forall v e body exn v',
      interp e v <> 0
      -> eval v body (Exception exn, v')
      -> eval v (While e body) (Exception exn, v')
  | EvalWhileFalse : forall v e body,
      interp e v = 0
      -> eval v (While e body) (Normal, v)

  | EvalCall : forall v lhs f arg spec v',
      env $? f = Some spec
      -> eval ($0 $+ (spec.(Arg), interp arg v)) spec.(Body) (Normal, v')
      -> eval v (Call lhs f arg) (Normal, v $+ (lhs, interp (Var spec.(Ret)) v'))
  | EvalCallExn : forall v lhs f arg spec exn v',
      env $? f = Some spec
      -> eval ($0 $+ (spec.(Arg), interp arg v)) spec.(Body) (Exception exn, v')
      -> eval v (Call lhs f arg) (Exception exn, v)
    (* Note the crucial difference between the two [EvalCall] rules: with a
     * normal outcome (other rule) of the called function, we extend the
     * valuation with the return value.  In case of an exception (this rule), we
     * leave the valuation alone. *)

  | EvalTry : forall v c v' x handler,
      eval v c (Normal, v')
      -> eval v (Try c x handler) (Normal, v')
    (* Normal evaluation of a [try] body bubbles out of the [try]. *)

  | EvalTryExn : forall v c exn v' x handler ov'',
      eval v c (Exception exn, v')
      -> eval (v' $+ (x, exn)) handler ov''
      -> eval v (Try c x handler) ov''
    (* Exceptional evaluation of the body switches to running the handler. *)

  | EvalThrow : forall v e,
      eval v (Throw e) (Exception (interp e v), v)
    (* Throwing generates the expected exceptional outcome. *)

  | EvalInCall : forall v0 lhs ret v c v',
      eval v c (Normal, v')
      -> eval v (InCall v0 lhs ret c) (Normal, v0 $+ (lhs, interp (Var ret) v'))
  | EvalInCallExn : forall v0 lhs ret v c exn v',
      eval v c (Exception exn, v')
      -> eval v (InCall v0 lhs ret c) (Exception exn, v0).
    (* Finally, two goofy rules just to make this semantics complete for
     * [InCall], which we really only need for the small-step semantics. *)

  (** Small-step semantics *)

  Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
  | StepAssign : forall v x e,
      step (v, Assign x e) (v $+ (x, interp e v), Skip)
  | StepSeq1 : forall v c1 c2 v' c1',
      step (v, c1) (v', c1')
      -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
  | StepSeq2 : forall v c2,
      step (v, Sequence Skip c2) (v, c2)
  | StepSeqThrow : forall v (n : nat) c2,
      step (v, Sequence (Throw (Const n)) c2) (v, Throw (Const n))
    (* Note how a [Throw] can bubble up from the first part of a sequence. *)
  | StepIfTrue : forall v e then_ else_,
      interp e v <> 0
      -> step (v, If e then_ else_) (v, then_)
  | StepIfFalse : forall v e then_ else_,
      interp e v = 0
      -> step (v, If e then_ else_) (v, else_)
  | StepWhileTrue : forall v e body,
      interp e v <> 0
      -> step (v, While e body) (v, Sequence body (While e body))
  | StepWhileFalse : forall v e body,
      interp e v = 0
      -> step (v, While e body) (v, Skip)
  | StepStartCall : forall v lhs f arg spec,
      env $? f = Some spec
      -> step (v, Call lhs f arg) ($0 $+ (spec.(Arg), interp arg v), InCall v lhs spec.(Ret) spec.(Body))
  | StepInCall : forall v c v' c' v0 lhs ret,
      step (v, c) (v', c')
      -> step (v, InCall v0 lhs ret c) (v', InCall v0 lhs ret c')
  | StepEndCall : forall v0 lhs ret v,
      step (v, InCall v0 lhs ret Skip) (v0, Assign lhs (Const (interp (Var ret) v)))
  | StepEndCallThrow : forall v0 lhs ret v (n : nat),
      step (v, InCall v0 lhs ret (Throw (Const n))) (v0, Throw (Const n))
    (* Here we also see a [Throw] bubble up out of a call.  That is, the
     * callee's uncaught exceptions escape to the caller. *)
  | StepTry : forall v c v' c' x handler,
      step (v, c) (v', c')
      -> step (v, Try c x handler) (v', Try c' x handler)
  | StepTryDone : forall v x handler,
      step (v, Try Skip x handler) (v, Skip)
  | StepTryThrow : forall v (n : nat) x handler,
      step (v, Try (Throw (Const n)) x handler) (v $+ (x, n), handler)
    (* Exceptions also bubble out of [Try]s, but they go to the handler instead
     * of to other surrounding code.  (Of course, if the handler raises another
     * exception, the adventure continues.) *)
  | StepThrow : forall v (e : arith),
      (forall n : nat, e <> Const n)
      -> step (v, Throw e) (v, Throw (Const (interp e v))).
    (* If throwing an expression that isn't fully evaluated, evaluate it before
     * continuing. *)

   (* Notice how the small-step style was more convenient to update in some
    * places.  We didn't need to create dual versions of as many rules, for
    * the normal and exceptional cases.  On the other hand, the "bubbling" rules
    * make up for it, so we get just as many rules. *)

   (* See the bottom of this file for the theorems we ask you to prove about
    * these semantics. *)

  (** Small-step semantics with control stack *)

  (* Now we take the same step that we finished up with in the lab. *)

  Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
  | Step0Assign : forall v x e,
      step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
  | Step0IfTrue : forall v e then_ else_,
      interp e v <> 0
      -> step0 (v, If e then_ else_) (v, then_)
  | Step0IfFalse : forall v e then_ else_,
      interp e v = 0
      -> step0 (v, If e then_ else_) (v, else_)
  | Step0WhileTrue : forall v e body,
      interp e v <> 0
      -> step0 (v, While e body) (v, Sequence body (While e body))
  | Step0WhileFalse : forall v e body,
      interp e v = 0
      -> step0 (v, While e body) (v, Skip)
  | Step0Throw : forall v (e : arith),
      (forall n : nat, e <> Const n)
      -> step0 (v, Throw e) (v, Throw (Const (interp e v))).
    (* This last rule is the one new one vs. the lab.  It's pretty similar to
     * the last rule of the basic small-step semantics. *)

  (* Call frames: just as in the lab, with a different name *)
  Record call_frame := {
    Val : valuation;
    Cont : cmd;
    LHS : var;
    RetVar : var
  }.

  (* However, now our control stacks have *two* kinds of frames!
   * The other represents a pending exception handler. *)
  Record handler_frame := {
    ExnVar : var;  (* In case of uncaught exception, save it to this
                    * variable... *)
    Handler : cmd; (* ...and commence running this command. *)
    ExnCont : cmd  (* Afterward, run this command. *)
  }.

  Inductive frame :=
  | CallFrame (fr : call_frame)
  | HandlerFrame (fr : handler_frame).

  Definition stack := list frame.

  (* Now we proceed much as in the lab. *)
  Inductive stepcs : stack * valuation * cmd * cmd -> stack * valuation * cmd * cmd -> Prop :=
  | StepcsStep0 : forall v c v' c' s k,
      step0 (v, c) (v', c') ->
      stepcs (s, v, c, k) (s, v', c', k)
  | StepcsSeq : forall s v c1 c2 k,
      stepcs (s, v, Sequence c1 c2, k) (s, v, c1, Sequence c2 k)
  | StepcsCont : forall s v k1 k2,
      stepcs (s, v, Skip, Sequence k1 k2) (s, v, k1, k2)
  | StepcsReturn : forall fr s v,
      stepcs (CallFrame fr :: s, v, Skip, Skip) (s, fr.(Val) $+ (fr.(LHS), interp (Var fr.(RetVar)) v), Skip, fr.(Cont))

  | StepcsReturnHandlerFrame : forall fr s v,
      stepcs (HandlerFrame fr :: s, v, Skip, Skip) (s, v, Skip, fr.(ExnCont))
    (* When a command finishes normally and there is a pending exception
     * handler, tell that handler "Sorry, Bub; not today!" and pop it off. *)

  | StepcsThrowDiscardCont : forall s v n k,
      k <> Skip ->
      stepcs (s, v, Throw (Const n), k) (s, v, Throw (Const n), Skip)
    (* When we throw an exception, discard the continuation, as we will never
     * finish normally and get around to running it. *)

  | StepcsHandleThrow : forall fr s v (n : nat),
      stepcs (HandlerFrame fr :: s, v, Throw (Const n), Skip) (s, v $+ (fr.(ExnVar), n), fr.(Handler), fr.(ExnCont))
    (* When throwing with a handler on top of the stack, pop it and start
     * running it. *)

  | StepcsThrowCallFrame : forall fr s v (n : nat),
      stepcs (CallFrame fr :: s, v, Throw (Const n), Skip) (s, fr.(Val), Throw (Const n), Skip)
    (* On the other hand, when throwing with a call frame on top, pop it and
     * jump past it to the next frame. *)

  | StepcsCall : forall s v lhs f arg k spec,
      env $? f = Some spec
      -> stepcs (s, v, Call lhs f arg, k) (CallFrame {| Val := v; Cont := k; LHS := lhs; RetVar := spec.(Ret)|} :: s, $0 $+ (spec.(Arg), interp arg v), spec.(Body), Skip)
    (* Calls proceed as before. *)

  | StepcsTry : forall s v c x handler k,
      stepcs (s, v, Try c x handler, k) (HandlerFrame {| ExnVar := x; Handler := handler; ExnCont := k|} :: s, v, c, Skip)
    (* To run a [Try], install its handler on top of the stack. *)

  | StepcsInCall : forall s v0 lhs ret v c k,
      stepcs (s, v, InCall v0 lhs ret c, k) (CallFrame {| Val := v0; Cont := k; LHS := lhs; RetVar := ret|} :: s, v, c, Skip).
    (* Same goofy [InCall] rule as before *)

End env.

Module Type S.
  Section env.
    Variable env : environment.

    Axiom big_small : forall v c v',
        eval env v c (Normal, v')
        -> (step env)^* (v, c) (v', Skip).

    Axiom big_small_exn : forall v c n v',
        eval env v c (Exception n, v')
        -> (step env)^* (v, c) (v', Throw (Const n)).

    Axiom small_big : forall v c v',
        (step env)^* (v, c) (v', Skip)
        -> eval env v c (Normal, v').

    Axiom small_big_exn : forall v c v' n,
        (step env)^* (v, c) (v', Throw (Const n))
        -> eval env v c (Exception n, v').

    Axiom eval_stepcs : forall v c v',
        eval env v c (Normal, v')
        -> (stepcs env)^* ([], v, c, Skip) ([], v', Skip, Skip).

    Axiom eval_stepcs_exn : forall v c (n : nat) v',
        eval env v c (Exception n, v')
        -> (stepcs env)^* ([], v, c, Skip) ([], v', Throw (Const n), Skip).

    Axiom stepcs_eval : forall v c v',
        (stepcs env)^* ([], v, c, Skip) ([], v', Skip, Skip)
        -> eval env v c (Normal, v').

    Axiom stepcs_eval_exn : forall v c v' (n : nat),
        (stepcs env)^* ([], v, c, Skip) ([], v', Throw (Const n), Skip)
        -> eval env v c (Exception n, v').
  End env.
End S.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06
- William Delobel, 2005-10-07

This file provides some basic results concerning relations that were
missing in the standard library.
*)

Set Implicit Arguments.

Require Import RelUtil LogicUtil Max Arith Setoid Morphisms Basics.

(***********************************************************************)
(** strict order *)

Section StrictOrder.

  Variables (A : Type) (R : relation A).

  Record strict_order : Prop := {
    sord_trans : transitive R;
    sord_irrefl : irreflexive R }.

  Variable so : strict_order.

  Lemma so_not_symmetric : forall a b, R a b -> R b a -> False.

  Proof.
    unfold not; intros a b Rab Rba.
    exact (sord_irrefl so (sord_trans so Rab Rba)).
  Qed.

  Variables (eq : relation A)
            (Req_compat : Proper (eq ==> eq ==> impl) R)
            (eq_Equivalence : Equivalence eq).

  Existing Instance eq_Equivalence.
  Existing Instance Req_compat.

  Lemma so_strict : forall x y, eq x y -> ~R x y.

  Proof. intros x y xy. rewrite xy. apply sord_irrefl. hyp. Qed.

End StrictOrder.

(***********************************************************************)
(** module types for setoids with decidable equality *)

Module Type SetA.
  Parameter A : Type.
End SetA.

Module Type Eqset.

  Parameter A : Type.

  Parameter eqA : relation A.
  Notation "X =A= Y" := (eqA X Y) (at level 70).

  Declare Instance eqA_Equivalence : Equivalence eqA.

  Hint Resolve (Seq_refl  A eqA eqA_Equivalence) : sets.
  Hint Resolve (Seq_trans A eqA eqA_Equivalence) : sets.
  Hint Resolve (Seq_sym   A eqA eqA_Equivalence) : sets.

End Eqset.

Module Type Eqset_dec.

  Declare Module Export Eq : Eqset.

  Parameter eqA_dec : forall x y, {x =A= y} + {~x =A= y}.

End Eqset_dec.

Module Eqset_def (A : SetA) <: Eqset.

  Definition A := A.A.

  Definition eqA := eq (A:=A).

  Instance eqA_Equivalence : Equivalence eqA.

  Proof. unfold eqA. class. Qed.

  Hint Resolve (Seq_refl  A eqA eqA_Equivalence) : sets.
  Hint Resolve (Seq_trans A eqA eqA_Equivalence) : sets.
  Hint Resolve (Seq_sym   A eqA eqA_Equivalence) : sets.

End Eqset_def.

(***********************************************************************)
(** module types for ordered setoids *)

Section Eqset_def_gtA_eqA_compat.

  Variables (A : Type) (gtA : relation A).

  Instance Eqset_def_gtA_eqA_compat : Proper (eq ==> eq ==> impl) gtA.

  Proof.
    intros x x' x_x' y y' y_y' x_y. rewrite <- x_x', <- y_y'; trivial.
  Qed.

End Eqset_def_gtA_eqA_compat.

Module Type Ord.

  Parameter A : Type.

  Declare Module Export S : Eqset with Definition A := A.

  Parameter gtA : relation A.
  Notation "X >A Y" := (gtA X Y) (at level 70).

  Declare Instance gtA_eqA_compat : Proper (eqA ==> eqA ==> impl) gtA.

  Hint Resolve gtA_eqA_compat : sets.

End Ord.

Module OrdLemmas (Export P : Ord).

  Definition ltA := transp gtA.
  Definition geA x y := ~ ltA x y.
  Definition leA x y := ~ gtA x y.
  Definition AccA := Acc ltA.

  Notation "X <A Y" := (ltA X Y) (at level 70).
  Notation "X >=A Y" := (geA X Y) (at level 70).
  Notation "X <=A Y" := (leA X Y) (at level 70).

  Hint Unfold ltA geA leA AccA : sets.

(*REMOVE?*)
  Instance gtA_morph : Proper (eqA ==> eqA ==> iff) gtA.

  Proof. intros a b ab c d cd. split; apply gtA_eqA_compat; (hyp||sym;hyp). Qed.

(*REMOVE?*)
  Instance ltA_morph : Proper (eqA ==> eqA ==> iff) ltA.

  Proof. intros a b ab c d cd. split; apply gtA_eqA_compat; (hyp||sym;hyp). Qed.

  Instance AccA_morph : Proper (eqA ==> iff) AccA.

  Proof.
    intros a b eq_ab. split.
    intro acc_a. inversion acc_a. constructor. intros.
    apply H. rewrite eq_ab. hyp.
    intros acc_b. inversion acc_b. constructor. intros.
    apply H. rewrite <- eq_ab. hyp.
  Qed.

End OrdLemmas.

Module Type Poset.

  Parameter A : Type.

  Declare Module Export O : Ord with Definition A := A.

  Parameter gtA_so : strict_order gtA.

  Hint Resolve (sord_trans gtA_so) : sets.
  Hint Resolve (sord_irrefl gtA_so) : sets.
  Hint Resolve (so_not_symmetric gtA_so) : sets.
  Hint Resolve (so_strict gtA_so gtA_eqA_compat eqA_Equivalence) : sets.

End Poset.

Module nat_ord <: Ord.

  Module natSet <: SetA.
    Definition A := nat.
    Definition eqA_dec := eq_nat_dec.
  End natSet.

  Module S := Eqset_def natSet.

  Definition A := nat.
  Definition gtA := gt.

  Instance gtA_eqA_compat : Proper (eq ==> eq ==> impl) gt.

  Proof. fo. Qed.

End nat_ord.

(***********************************************************************)
(** specification *)

Section Specif.

  Inductive sigPS2 (A : Type) (P : A -> Prop) (Q : A -> Set) : Type :=
    existPS2 : forall x, P x -> Q x -> sigPS2 (A:=A) P Q.

  Notation "{ x : A # P & Q }"
    := (sigPS2 (fun x : A => P) (fun x : A => Q)) : type_scope.

  Variables (A : Type) (P Q : A -> Prop).

  Definition proj1_sig2 (e: sig2 P Q) :=
    match e with
    | exist2  _ _ a p q  => a
    end.

End Specif.

(***********************************************************************)
(** tactics *)

Ltac rewrite_lr term := apply (proj1 term).
Ltac rewrite_rl term := apply (proj2 term).

Ltac try_solve :=
   simpl in *; try (intros; solve
     [ contr
     | discr
     | auto with terms
     | tauto
     | congruence
     ]).


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Let's figure out the pack/Upsilon problem. Basically upsilon
  is referenced once and never filled.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsHeapObjects.
Require Export StaticSemanticsTypingHeapObjects.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.

Require Import TestUtilities.
Require Import Tacticals.

(* SL_3_1 *)

(* The mininal closed type test assignment with an empty path.
   Gettyp_nil applies. *)
Example ltyp_assign_cint:
    ltyp [] [] [(x,cint)] (p_e x []) cint.
Proof.
  intros.
  apply SL_3_1 with (tau' := cint).
  reflexivity.
  apply gettype_nil.
  eauto 20 with Chapter3.
  eauto 20 with Chapter3.
Qed.

Example ltyp_assign_a_pair:
    ltyp []
         [] (* Utype needs nothing as it has a nil path. *)
         [(x,(cross cint cint))]
         (p_e x []) (cross cint cint).
Proof.
  intros.
  apply SL_3_1 with (tau' := cross cint cint).
  reflexivity.
  apply gettype_nil.
  eauto 20 with Chapter3.
  eauto 20 with Chapter3.
Qed.

(* Now follow a pair for an assignment. *)

Example ltyp_assign_into_pair:
    ltyp []
         [] (* Upsilon needs nothing as the only place it reads is in pack. *)
         [(x,(cross cint cint))]
         (p_e x [i_pe zero_pe]) cint.
Proof.
  intros.
  apply SL_3_1 with (tau' := cross cint cint).
  reflexivity.
  apply gettype_pair_zero.
  apply gettype_nil.
  eauto 20 with Chapter3.
  eauto 20 with Chapter3.
Qed.

(* So an assignment of a pack goes through this ltype on the LHS.
  There must be an Upsilon entry mapping x, p to the witness type
  for all etype alias within any path in the typing. *)

Example ltyp_read_pack:
    ltyp []
         [(x,[],cint)] (* Upsilon must be filled with witness. *)
         [(x, (etype aliases alpha B (tv_t alpha)))]
         (p_e x [u_pe]) cint.
Proof.
  intros.
  apply SL_3_1 with (tau' := (etype aliases alpha B (tv_t alpha))).
  reflexivity.
  apply gettype_etype with (tau'':= cint).
  constructor.
  simpl.
  apply gettype_nil.
  constructor; try eauto 20 with Chapter3.
  apply K_etype; try eauto 20 with Chapter3.
Qed.

(* SL 3 1 must map x to all its paths that have packs and know their type.
 Not quite right, p' is not specified, should not be used. *)

(*
Inductive settype : Upsilon -> EVar -> P -> Tau -> Upsilon -> Prop :=
 | settype_cint:
     forall (u : Upsilon) (x : EVar) (p : P) (tau : Tau),
            settype u x [] cint u

 | settype_pair :
     forall (u : Upsilon) (x : EVar) (p : P) (t0 t1 : Tau) (p' : P) (u1' u2': Upsilon),
       settype u x  (p ++ [i_pe zero_pe]) t0 u1' ->
       settype u x  (p ++ [i_pe zero_pe]) t1 u2' ->
       settype u x p (cross t0 t1) (union_Upsilon u u1' u2')

 | settype_etype :
     forall (u : Upsilon) (x : EVar) (p : P) (tau' : Tau) (u': Upsilon),
       settype
       settype u x p (etype aliases alpha k tau') [u_pe] u'.
*)

(* I need to go from a pack to a typing. *)

Example rtyp_pack_int:
  rtyp
    []
    []
    []
    (pack cint (i_e (i_i 0)) (etype aliases alpha B (tv_t alpha)))
    (etype aliases alpha B (tv_t alpha)).
Proof.
  apply SR_3_12.
  simpl.
  constructor; eauto 20 with Chapter3.
  eauto 20 with Chapter3.
  eauto 20 with Chapter3.
Qed.

(* Okay the simplest full test is to dynamically execute this and then
   type it. *)

Definition pkt := (etype aliases alpha B (tv_t alpha)).
Definition pk := (pack cint (i_e (i_i 0)) pkt).

Definition t :=
  (seq (e_s (assign (p_e x []) pk))
       (e_s (p_e x []))).

Definition t' := (assign (p_e x []) pk).

Example eval_assign_pk:
  R
    []
    (e_s t')
    [(x, pk)]
    (e_s pk).
Proof.
  apply R_initial_assign_3_2; eauto 20 with Chapter3.
Qed.

Example type_assign_pk:
  rtyp
    []
    []
    []
    t'
    pkt.
Proof.
  apply SR_3_8.
  admit.
  admit.
Admitted.

Example execute_pack_read:
  Sstar
    []
    t
    [(x,pk)]
    (e_s pk).
Proof.
Admitted.

(* SR_3_1 *)


Require Export Fin.

Set Implicit Arguments.

(*
Require Export PointWiseRing.
  FS_as_CSetoid (Fin n) T.
*)
Fixpoint Vector (n:nat) (T : Type)  : Type :=
match n with
| 0 => unit
| S n => (Vector n T) × T
end.

Definition VectInd {T} {P : forall n, Type}
 (bas: P 0)
 (rect: forall {n}, Vector n T -> P n ->  T -> P (S n))
 {m} (v : Vector m T): P m.
  induction m.
  - exact bas.
  - simpl in v. destruct v as [v t].
    exact (rect m v (IHm v) t).
Defined.

Definition vnth {T : Type} {m:nat} (v : Vector m T) (n : Fin m) : T.
  induction m;[apply f0; trivial| ].
  simpl in v. destruct n as [n np].
  destruct n; simpl in np.
  - exact (snd v).
  - apply fst in v. apply IHm;[exact v| ].
    exists n. apply sdjflksdjsdlkf3. trivial.
Defined.

(*
Definition isVecDerivativeOf
    {n : nat} (f f' : Vector n TContR) : Type.
  revert f f'.
  induction n as [| np Hind]; intros f f';[exact unit|].
  destruct f as [fv ft].
  destruct f' as [fv' ft'].
  exact ((isDerivativeOf ft ft') × (Hind fv fv')).
Defined.
*)
Record Cart2D (T : Type) : Type := mkCart2D {X : T; Y: T}.
Record Polar2D (T : Type) : Type := mkPolar2D {rad : T; θ : T}.

Definition fromVec2D {T:Type}  (v2: Cart2D T) : Vector 2 T := (tt, X v2, Y v2).

Definition toVec2D {T:Type}  (v2: Vector 2 T) : Cart2D T
  := {|X := snd (fst v2); Y:= (snd v2) |}.

(* copied from https://coq.inria.fr/library/Coq.Logic.ExtensionalityFacts.html#is_inverse *)
Definition is_inverse A B (f : A->B) (g : B -> A)
  := (forall a:A, g (f a) = a) /\ (forall b:B, f (g b) = b).

Lemma toFromVecInv {T:Type}: @is_inverse (Cart2D T) _ fromVec2D toVec2D.
Proof.
  split; intro t; destruct t as [X Y];[reflexivity|].
  destruct X as [X XU]. destruct X.
  simpl. reflexivity.
Qed.

Coercion fromVec2D : Cart2D >-> Vector.
Coercion toVec2D : Vector >-> Cart2D.

Require Export CoRN.algebra.CRings.

Definition dotProduct {n:nat} {T : CRing} (vl vr : Vector n T) : T :=
@VectInd _ (fun n =>  Vector n T -> T)
  (fun vr => [0])
  (fun  b _ rec tl vr =>
              (tl [*]snd vr) [+] rec (fst vr)) n vl vr.

Require Export CanonicalNotations.
Require Import Coq.Unicode.Utf8.
Require Export MathClasses.interfaces.canonical_names.
Require Export MathClasses.interfaces.abstract_algebra.

Instance castCart `{Cast A B} : Cast (Cart2D A) (Cart2D B) :=
  fun c => {|X := cast A B (X c) ;  Y := cast A B (Y c) |}.

Instance EquivCart  `{Equiv A} : Equiv (Cart2D A) :=
fun ca cb => (X ca = X cb /\ Y ca = Y cb).

Require Export StdlibMisc.

Instance Equivalence_instance_Cart2D2
  `{r: Equiv A}
    `{Equivalence _ r} : @Equivalence (Cart2D A) equiv.
  unfold EquivCart. split.
  - intros x. destruct x. compute. split; auto with *.
  - intros x y. destruct x,y. compute. intros Hd; destruct Hd;
      split; auto with relations.

  - intros x y z. destruct x,y,z. compute. intros H0 H1.
    repnd.
    split; eauto 10
    with relations.
    rewrite H0l. auto.
    rewrite H0r. auto.
Qed.

Open Scope mc_scope.

Instance NormSpace_instance_Cart2D
  (A B : Type) `{SqrtFun A B}
  `{Plus A} `{Mult A} : NormSpace (Cart2D A) B :=
 λ (cart : Cart2D A),
    (√((X cart) * (X cart) +  (Y cart) * (Y cart))).

Definition normSqr
  {A : Type}
  `{Plus A} `{Mult A} (cart : Cart2D A) : A  :=
    (((X cart) * (X cart) +  (Y cart) * (Y cart))).

Instance Zero_instance_Cart2D `{Zero A} : Zero (Cart2D A)
    := (({|X:=0 ; Y:=0|}))%mc.
Instance One_instance_Cart2D `{One A} : One (Cart2D A)
    := (({|X:=1 ; Y:=1|}))%mc.
Instance Plus_instance_Cart2D `{Plus A} : Plus (Cart2D A)
    := (λ a b, ({|X:= X a + X b ; Y:= Y a + Y b|}))%mc.
Instance Mutt_instance_Cart2D `{Mult A} : Mult (Cart2D A)
    := (λ a b, ({|X:= X a * X b ; Y:= Y a * Y b|}))%mc.
Instance Negate_instance_Cart2D `{Negate A} : Negate (Cart2D A)
    := (λ a, ({|X:= -(X a) ; Y:= -(Y a)|}))%mc.

Section Cart2DRing.

Require Export MathClasses.theory.rings.
Context `{Ring A}.

Add Ring  stdlib_ring_theoryldsjfsd : (rings.stdlib_ring_theory A).

Global Instance Ring_instance_Cart2D : Ring (Cart2D A).
  repeat(split);
  (repeat match goal with
  | [ H: Cart2D A |- _ ] => destruct H
  | [ H: equiv _ _ |- _ ] => unfold equiv, EquivCart in H; simpl in H; destruct H
  end);
  simpl; subst; eauto 2 with *; try ring; try( apply sg_op_proper; auto).
Qed.

Definition shiftOrigin (newOr pt : Cart2D A) :  Cart2D A :=
  pt - newOr.

Definition distSqr (a b : Cart2D A) : A :=
  normSqr (a - b ).

Global Instance Proper_Cart2DX :
     Proper  (equiv ==> equiv) (@X A).
  intros a b Heq.
  unfold equiv, EquivCart in Heq.
  repnd. assumption.
Defined.

Global Instance Proper_Cart2DY :
     Proper  (equiv ==> equiv) (@Y A).
  intros a b Heq.
  unfold equiv, EquivCart in Heq.
  repnd. assumption.
Qed.

Global Instance Proper_normSqr :
     Proper  (equiv ==> equiv) (@normSqr A _ _).
  intros a b Heq.
  unfold normSqr. rewrite Heq.
  reflexivity.
Qed.

Global Instance Proper_distSqr :
     Proper  (equiv ==> equiv ==> equiv) (@distSqr ).
  intros a b Heql c d  Heqr.
  unfold distSqr.
  idtac. rewrite Heql, Heqr.
  reflexivity.
Qed.

End Cart2DRing.

Global Instance Cart2D_instance_le `{Le A}: Le (Cart2D A) :=
  λ p1 p2, (X p1 ≤ X p2) ∧ (Y p1 ≤ Y p2).

Definition sameXY {A} (a:A) : Cart2D A :=
  {|X :=a ; Y:= a|}.

Global Instance hjfkhskajhfksh  `{Equiv A} : Proper
  (equiv ==> equiv ==> equiv) (@mkCart2D A).
Proof.
  intros ? ? Heq ? ? Hq.
  split; simpl; trivial.
Qed.

Global Instance ProperSameXY `{Equiv A}:
  Proper (equiv ==> equiv) (@sameXY A).
  intros a b Heq.
  split; auto.
Qed.

Lemma sameXYMult `{Ring A}: ∀ a b : A,
    sameXY a * sameXY b = sameXY (a * b).
Proof.
  intros. reflexivity.
Qed.

Lemma sameXYAdd `{Ring A}: ∀ a b : A,
     sameXY a + sameXY b = sameXY (a + b).
Proof.
  intros. reflexivity.
Qed.

Lemma sameXYNegate `{Ring A}: ∀ a : A,
  sameXY (-a) = - (sameXY a).
Proof.
  intros. reflexivity.
Qed.

Definition transpose {A:Type} (c: Cart2D A) :=
  {|X:= Y c; Y:= X c|}.

Lemma Cart2DEta `{Equiv A} `{Equivalence _ (@equiv A _)}  : forall c:Cart2D A,
   {| X:= X c; Y:=Y c |} = c.
Proof.
  intros. destruct c. simpl. reflexivity.
Qed.

Require Import MathClasses.interfaces.orders.

Global Instance LeCart2DPreorder `{l:Le A} `{PreOrder A l}
  : PreOrder (Cart2D_instance_le).
Proof.
  split; intros ?; unfold le, Cart2D_instance_le;
  eauto with relations.
  intros. repnd. eauto with relations.
Qed.

Global Instance LeCart2DPartialOrder `{Ring A}  `{Le A}
  `{@PartialOrder A _ _ }
  : PartialOrder (Cart2D_instance_le).
Proof.
  split; eauto with typeclass_instances.
  - split; eauto with typeclass_instances.
  - intros ? ? H1e ? ? H2e; unfold le, Cart2D_instance_le.
    rewrite H1e, H2e. tauto.
  - intros ? ?. unfold le, Cart2D_instance_le. intros ? ?.
    repnd. split; simpl; eapply  po_antisym; eauto.
Qed.

Global Instance OrderPreservingLePlusCart2D
  `{Ring A} `{Le A} `{@PartialOrder A _ _}
  {_:forall a:A, OrderPreserving (plus a)}
(z : Cart2D A):
  OrderPreserving (plus z).
Proof.
  split; eauto  with typeclass_instances.
  - split; eauto with typeclass_instances.
    split;  eauto with typeclass_instances;
    split;  eauto with typeclass_instances.
  - intros ? ?. unfold le, Cart2D_instance_le.
    intros. repnd;
    simpl.
    split;
    eauto with typeclass_instances.
Qed.

Global Instance MultLeSemiRingOrderCart2D
  `{Ring A} `{l:Le A}
  {Hm:∀ (x y :  A) , PropHolds (0 ≤ x) → PropHolds (0 ≤ y)
      → PropHolds (0 ≤ x * y) }:

  ∀ x y : (Cart2D A) , PropHolds (0 ≤ x) → PropHolds (0 ≤ y) → PropHolds (0 ≤ x * y) .
Proof.
    unfold le, Cart2D_instance_le, PropHolds.
    unfold  PropHolds in Hm.
    simpl.
    intros. repnd;
    simpl.
    split;
    eauto with typeclass_instances.
Qed.

Require Import MathClasses.orders.rings.
Global Instance ProperLeCart `{Ring A} `{Le A}
    `{@orders.SemiRingOrder A equiv plus mult zero one le}:
    `{orders.SemiRingOrder (@canonical_names.le (Cart2D A) _)}.
Proof.
  apply from_ring_order;
  eauto with typeclass_instances.
Qed.

  Lemma foldPlusCart `{Ring A} : forall xa xb ya yb:A,
   {| X:= xa + xb; Y:=ya + yb |} = {|X:=xa; Y:=ya|} + {|X:=xb; Y:=yb|}.
  Proof.
    intros. reflexivity.
  Qed.

    Require Import CoRN.logic.Stability.

   Global Instance StableEqCart2D `{Equiv A} :
    (forall x y : A, Stable (x=y))
    -> (forall a b : Cart2D A, Stable (a=b)).
   Proof.
     intros Hc a b.
     apply stable_conjunction; apply Hc.
   Qed.

   Global Instance StableLeCart2D `{Le A} :
    (forall x y : A, Stable (x≤y))
    -> (forall a b : Cart2D A, Stable (a≤b)).
   Proof.
     intros Hc a b.
     apply stable_conjunction; apply Hc.
   Qed.

Require Import MathClasses.interfaces.abstract_algebra.

Global Instance castCRCart2DCR (R:Type): Cast R (Cart2D R) := sameXY.

Instance srmSameXY `{Ring A} : SemiRing_Morphism (cast A (Cart2D A)).
Proof.
repeat (split; try apply _); reflexivity.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import div fintype tuple finfun bigop prime finset.
From mathcomp Require Import binomial.
Require Import ProofIrrelevance Reals Fourier.
Require Import ssrR.

(** * Additional lemmas about Coq Reals *)

Reserved Notation "T '->' 'R+' " (at level 10, format "'[' T  ->  R+ ']'").
Reserved Notation "+| r |" (at level 0, r at level 99, format "+| r |").
Reserved Notation "P '<<' Q" (at level 10, Q at next level).
Reserved Notation "P '<<b' Q" (at level 10).

Notation "'min(' x ',' y ')'" := (Rmin x y)
  (format "'min(' x ','  y ')'") : reals_ext_scope.
Notation "'max(' x ',' y ')'" := (Rmax x y)
  (format "'max(' x ','  y ')'") : reals_ext_scope.
Notation "+| r |" := (Rmax 0 r) : reals_ext_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Arguments INR : simpl never.

Lemma Rlt_1_2 : 1 < 2. Proof. by fourier. Qed.
Hint Resolve Rlt_1_2.

Record pos_fun (T : Type) := mkPosFun {
  pos_f :> T -> R ;
  pos_f_ge0 : forall a, 0 <= pos_f a }.

Notation "T '->' 'R+' " := (pos_fun T) : reals_ext_scope.

Local Open Scope reals_ext_scope.

Lemma pos_fun_eq {C : Type} (f g : C -> R+) : pos_f f = pos_f g -> f = g.
Proof.
destruct f as [f Hf].
destruct g as [g Hg].
move=> /= ?; subst.
suff : Hf = Hg by move=> ->.
by apply proof_irrelevance.
Qed.

Definition onem (r : R) := (1 - r)%R.
Notation "p '.~'" := (onem p)%R (format "p .~", at level 5) : R_scope.

Lemma onem_ge0 (r : R) : r <= 1 -> 0 <= r.~.
Proof. move=> r1; rewrite /onem; fourier. Qed.

Lemma onemKC (r : R) : (r + r.~ = 1)%R.
Proof. rewrite /onem; by field. Qed.

Lemma onemK p : p.~.~ = p.
Proof. by rewrite /onem subRBA addRC addRK. Qed.

Lemma iter_mulR x (n : nat) : ssrnat.iter n (Rmult x) 1 = x ^ n.
Proof. elim : n => // n Hn ; by rewrite iterS Hn. Qed.

Lemma iter_addR x (n : nat) : ssrnat.iter n (Rplus x) 0 = INR n * x.
Proof.
elim : n ; first by rewrite mul0R.
move=> n Hn; by rewrite iterS Hn -{1}(mul1R x) -mulRDl addRC -S_INR.
Qed.

(* TODO: rename; move? *)
Lemma Rlt_0_Rmult_inv a b : 0 < a * b -> 0 <= a -> 0 <= b -> 0 < a /\ 0 < b.
Proof.
move=> H Ha Hb.
split.
- apply/ltRNge => abs.
  have abs' : a = 0 by rewrite eqR_le.
  by move: H; rewrite abs' mul0R => /ltRR.
- apply/ltRNge => abs.
  have abs' : b = 0 by rewrite eqR_le.
  by move: H; rewrite abs' mulR0 => /ltRR.
Qed.

(* NB: see Rplus_lt_reg_pos_r in the standard library *)
Lemma Rplus_le_lt_reg_pos_r r1 r2 r3 : 0 < r2 -> r1 + r2 <= r3 -> r1 < r3.
Proof. move=> *. fourier. Qed.

Lemma INR_Zabs_nat x : (0 <= x)%Z -> INR (Z.abs_nat x) = IZR x.
Proof. move=> Hx. by rewrite INR_IZR_INZ Zabs2Nat.id_abs Z.abs_eq. Qed.

(** non-negative rationals: *)

Record Qplus := mkRrat { num : nat ; den : nat }.

Definition Q2R (q : Qplus) := INR (num q) / INR (den q).+1.

Coercion Q2R : Qplus >-> R.

(** Lemmas about division *)

Lemma neq_Rdiv a b : a <> 0 -> b <> 0 -> b <> 1 -> a <> a / b.
Proof.
move=> Ha Hb Hb' abs.
rewrite -{1}[X in X = _]mulR1 in abs.
move/(eqR_mul2l Ha) in abs.
apply Hb'.
apply (@eqR_mul2r (/ b)); first exact/eqP/invR_neq0/eqP.
rewrite mulRV ?mul1R //; exact/eqP.
Qed.

Lemma Rdiv_le a : 0 <= a -> forall r, 1 <= r -> a / r <= a.
Proof.
move=> Ha r Hr.
apply (@leR_pmul2l r); first by fourier.
rewrite /Rdiv mulRCA mulRV; last by apply/negP => /eqP ?; subst r; fourier.
rewrite -mulRC; exact: leR_wpmul2r.
Qed.

Lemma Rdiv_lt a : 0 < a -> forall r : R, 1 < r -> a / r < a.
Proof.
move=> Ha r0 Hr0.
rewrite -[X in _ < X]mulR1.
apply ltR_pmul2l => //.
rewrite -invR1.
apply ltR_inv => //; fourier.
Qed.

(** Lemmas about power *)

Section pow_sect.

Lemma powS x (n : nat) : x ^ n.+1 = x * x ^ n.
Proof. by rewrite tech_pow_Rmult. Qed.

Lemma pow_even_ge0 (n : nat) x : ~~ odd n -> 0 <= x ^ n.
Proof.
move=> Hn; rewrite -(odd_double_half n) (negbTE Hn) {Hn} add0n.
move Hm : (_./2) => m {Hm n}; elim: m => [|m ih]; first by rewrite pow_O.
rewrite doubleS 2!powS mulRA; apply/mulR_ge0 => //.
rewrite -{2}(pow_1 x) -powS; exact: pow2_ge_0.
Qed.

Lemma pow2_Rle_inv a b : 0 <= a -> 0 <= b -> a ^ 2 <= b ^ 2 -> a <= b.
Proof.
move=> Ha Hb H.
apply sqrt_le_1 in H; try exact: pow_even_ge0.
by rewrite /= !mulR1 !sqrt_square in H.
Qed.

Lemma pow2_Rlt_inv a b : 0 <= a -> 0 <= b -> a ^ 2 < b ^ 2 -> a < b.
Proof.
move=> ? ? H.
apply sqrt_lt_1 in H; try exact: pow_even_ge0.
by rewrite /= !mulR1 !sqrt_square in H.
Qed.

Lemma x_x2_eq q : q * (1 - q) = / 4 - / 4 * (2 * q - 1) ^ 2.
Proof. field. Qed.

Lemma x_x2_max q : q * (1 - q) <= / 4.
Proof.
rewrite x_x2_eq.
have : forall a b, 0 <= b -> a - b <= a. move=>  *; fourier.
apply; apply mulR_ge0; [fourier | exact: pow_even_ge0].
Qed.

Lemma pow0_inv : forall (n : nat) x, x ^ n = 0 -> x = 0.
Proof.
elim => [x /= H | n IH x /= /eqP].
fourier.
by rewrite mulR_eq0 => /orP[/eqP //|/eqP/IH].
Qed.

Lemma INR_pow_expn r : forall n : nat, INR r ^ n = INR (expn r n).
Proof.
elim => // n IH.
by rewrite (expnSr r n) mult_INR -addn1 pow_add /= mulR1 IH.
Qed.

Lemma pow_gt0 x : 0 < x -> forall n : nat, 0 < x ^ n.
Proof. move=> ?; elim => [/= | n IH] => //; exact: mulR_gt0. Qed.

Lemma pow_ge0 x : 0 <= x -> forall n : nat, 0 <= x ^ n.
Proof.
move=> x_pos.
elim => [/= | n IH] => //.
rewrite -(mulR0 0); apply leR_pmul => //; exact/leRR.
Qed.

End pow_sect.

(** Lemmas about up / Int_part / frac_part *)

Lemma up_pos r : 0 <= r -> (0 < up r)%Z.
Proof.
move=> Hr.
apply lt_IZR => /=.
move/Rgt_lt : (proj1 (archimed r)) => Hr'.
exact: (leR_ltR_trans Hr).
Qed.

Lemma Rle_up_pos r : 0 <= r -> r <= IZR (Z.abs (up r)).
Proof.
move=> Hr.
rewrite Z.abs_eq; last first.
  apply up_pos in Hr.
  by apply Z.lt_le_incl.
case: (base_Int_part r).
rewrite /Int_part minus_IZR => _ ?; fourier.
Qed.

Lemma Rle_up a : a <= IZR (Z.abs (up a)).
Proof.
case: (Rlt_le_dec a 0) => Ha; last by apply Rle_up_pos.
apply (@leR_trans  0); first by fourier.
exact/IZR_le/Zabs_pos.
Qed.

Lemma up_Int_part r : (up r = Int_part r + 1)%Z.
Proof.
case: (base_Int_part r) => H1 H2.
rewrite -(up_tech r (Int_part r)) // plus_IZR //; fourier.
Qed.

Lemma Int_part_pos a : 0 <= a -> (0 <= Int_part a)%Z.
Proof.
move/up_pos => ?.
rewrite /Int_part.
rewrite (_ : 0 = Z.succ 0 - 1)%Z //.
apply Z.sub_le_mono => //.
by apply Zlt_le_succ.
Qed.

Lemma frac_part_INR m : frac_part (INR m) = 0.
Proof.
rewrite /frac_part /Int_part -(up_tech _ (Z_of_nat m)).
rewrite minus_IZR plus_IZR /= -INR_IZR_INZ; by field.
rewrite -INR_IZR_INZ; exact/leRR.
rewrite {1}INR_IZR_INZ; apply IZR_lt.
by apply Z.lt_add_pos_r.
Qed.

Lemma frac_Int_part x : frac_part x = 0 -> IZR (Int_part x) = x.
Proof.
rewrite /frac_part.
set h := IZR _.
move=> H.
by rewrite -(addR0 h) -H Rplus_minus.
Qed.

Lemma frac_part_mult a b : frac_part a = 0 -> frac_part b = 0 ->
  frac_part (a * b) = 0.
Proof.
rewrite /frac_part /Int_part !minus_IZR //.
move=> Ha Hb.
have {Ha}Ha : IZR (up a) = a + 1.
  move: Ha.
  set x := IZR (up a).
  move=> Ha.
  rewrite -[X in X = _](add0R _) -Ha.
  by field.
have {Hb}Hb : IZR (up b) = b + 1.
  move: Hb.
  set x := IZR (up b).
  move=> Hb.
  rewrite -[X in X = _](add0R _) -Hb.
  by field.
rewrite -(tech_up _ ((up a - 1) * (up b - 1) + 1)).
  rewrite ?plus_IZR ?minus_IZR ?mult_IZR ?minus_IZR // Ha Hb.
  by field.
  rewrite ?plus_IZR ?minus_IZR ?mult_IZR ?minus_IZR // Ha Hb.
  rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field.
  rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field.
  fourier.
  rewrite ?plus_IZR ?minus_IZR ?mult_IZR ?minus_IZR // Ha Hb.
  rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field.
  rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field.
  exact/leRR.
Qed.

Lemma frac_part_pow a : frac_part a = 0 -> forall n : nat, frac_part (a ^ n) = 0.
Proof.
move=> Ha; elim=> /=.
by rewrite /frac_part (_ : 1 = INR 1) // Int_part_INR  subRR.
move=> n IH; exact: frac_part_mult.
Qed.

(** P is dominated by Q: *)
Section dominance.

Definition dom_by {A : Type} (P Q : A -> R) := forall a, Q a = 0 -> P a = 0.

Definition dom_byb {A : finType} (P Q : A -> R) := [forall b, (Q b == 0) ==> (P b == 0)].

End dominance.

Notation "P '<<' Q" := (dom_by P Q) : reals_ext_scope.
Notation "P '<<b' Q" := (dom_byb P Q) : reals_ext_scope.

Lemma ltR_Rabsl a b : `| a | <b b = (- b <b a <b b).
Proof.
apply/idP/idP => [/ltRP/Rabs_def2[? ?]|/andP[]/ltRP ? /ltRP ?].
apply/andP; split; exact/ltRP.
exact/ltRP/Rabs_def1.
Qed.

Lemma leR_Rabsl a b : `| a | <b= b = (- b <b= a <b= b).
Proof.
apply/idP/idP => [/leRP|]; last first.
  case/andP => /leRP H1 /leRP H2; exact/leRP/Rabs_le.
case: (Rlt_le_dec a 0) => h.
  rewrite ltR0_norm // => ?; apply/andP; split; apply/leRP; fourier.
rewrite geR0_norm // => ?; apply/andP; split; apply/leRP; fourier.
Qed.

(* TODO: rename *)
Lemma fact_Coq_SSR n0 : fact n0 = n0 `!.
Proof. elim: n0 => // n0 IH /=. by rewrite IH factS mulSn -multE. Qed.

Lemma combinaison_Coq_SSR n0 m0 : (m0 <= n0)%nat -> C n0 m0 = INR 'C(n0, m0).
Proof.
move=> ?.
rewrite /C.
apply (@eqR_mul2r (INR (fact m0) * INR (fact (n0 - m0)%coq_nat))).
  move/eqP; rewrite mulR_eq0 !INR_eq0' => /orP[|] /eqP; exact/fact_neq_0.
set tmp := INR (fact m0) * _.
rewrite -mulRA mulVR ?mulR1; last first.
  by rewrite /tmp mulR_eq0 negb_or !INR_eq0' !fact_Coq_SSR -!lt0n !fact_gt0.
by rewrite /tmp -!mult_INR !fact_Coq_SSR !multE !minusE bin_fact.
Qed.

Lemma normR_max a b c c' : 0 <= a <= c -> 0 <= b <= c' ->
  `| a - b | <= max(c, c').
Proof.
move=> [H1 H2] [H H3]; case: (Rtotal_order a b) => [H0|[H0|H0]].
- rewrite distRC gtR0_norm ?subR_gt0 //.
  apply: (@leR_trans b); [fourier | apply/(leR_trans H3)/leR_maxr; fourier].
- subst b; rewrite subRR normR0.
  exact/(leR_trans H1)/(leR_trans H2)/leR_maxl.
- rewrite geR0_norm; last by fourier.
  apply: (@leR_trans a); [fourier|exact/(leR_trans H2)/leR_maxl].
Qed.

Lemma Rplus_minus_assoc (r1 r2 r3 : R) : (r1 + r2 - r3 = r1 + (r2 - r3))%R.
Proof. by rewrite /Rminus Rplus_assoc. Qed.


(* General lemmas and definitions that don't belong anywhere *)

From mathcomp Require Import all_ssreflect.

Require Import FinMap.ordtype.

Set Implicit Arguments.
Unset Strict Implicit.
(* Import Prenex Implicits. *)
(* Unset Printing Implicit Defensive. *)

Lemma neqC {A : eqType} (x y : A) : x != y -> y != x.
Proof.
    by rewrite eq_sym.
Qed.

Lemma notin_cons {A : eqType} x y (L : seq A) : x \notin y :: L -> x != y /\ x \notin L.
Proof. by rewrite in_cons negb_or =>/andP. Qed.

(* TODO rename to notin_app or at least similarly to notin_cons (previous lemma) *)
Lemma not_in_app {A : eqType} (x : A) L L':
  x \notin L ++ L' -> x \notin L /\ x \notin L'.
Proof. by rewrite mem_cat negb_or => /andP. Qed.

(* Some lemmas about predicates (quite simple ones) *)

Lemma in_predU_l {T : eqType} (k : T) P Q : k \in P -> k \in predU P Q.
  do 2! rewrite/(_\in_).
  rewrite/predU.
  simpl=>->.
  by rewrite Bool.orb_true_l.
Qed.

Lemma in_predU_r {T : eqType}(k : T) P Q : k \in Q -> k \in predU P Q.
  do 2! rewrite/(_\in_).
  rewrite/predU.
  simpl=>->.
  by rewrite Bool.orb_true_r.
Qed.

Lemma notin_predU {T : eqType}(k : T) P Q : k \notin P -> k \notin Q -> k \notin predU P Q.
Proof.
  do !rewrite/(_\notin_)/predU/(_\in_) ; simpl.
  elim (P k)=>//.
Qed.


(*** Membership predicates ***)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Ring.
Require Import Ott.ott_list_base.
Require Import Ott.ott_list_core.
Require Import Ott.ott_list_nth.
Set Implicit Arguments.

(*** Membership predicate ***)

Section In.
Variable A : Type.
Implicit Types x : A.
Implicit Types xs l : list A.

(* Speed up proofs by providing trivial consequences of [List.in_or_app] that
   do not require eauto. *)
Lemma In_left_app :
  forall l l' a, In a l -> In a (l ++ l').
Proof. auto with datatypes. Qed.
Lemma In_right_app :
  forall l l' a, In a l -> In a (l ++ l').
Proof. auto with datatypes. Qed.

Lemma not_in_app_or :
  forall l l' a, ~In a (l ++ l') -> ~In a l /\ ~In a l'.
Proof. unfold not; auto with datatypes. Qed.
Lemma not_in_or_app :
  forall l l' a, ~In a l /\ ~In a l' -> ~In a (l ++ l').
Proof. unfold not; destruct 1; intros. pose (in_app_or _ _ _ H1). tauto. Qed.

Lemma nth_error_In :
  forall l n x, nth_error l n = Some x -> In x l.
Proof.
  intros; generalize dependent l; induction n; destruct l; intros;
    simpl in *; simplify_eq H; auto.
Qed.

Lemma nth_safe_In :
  forall l n H, In (nth_safe l n H) l.
Proof.
  intros. eapply nth_error_In. rewrite nth_safe_eq_nth_error. eauto.
Qed.

End In.

Hint Resolve In_left_app In_right_app : datatypes.
Hint Resolve not_in_app_or not_in_or_app : datatypes.
Hint Resolve nth_error_In nth_safe_In : datatypes.

(*** Membership predicate and map ***)

Lemma image_In_map :
  forall (A B:Type) x l (f:A->B),
    In x l -> In (f x) (map f l).
Proof.
  intros. induction l; simpl in * . tauto. destruct H; subst; tauto.
Qed.

Lemma In_map_exists :
  forall (A B:Type) l y (f:A->B),
    In y (map f l) -> exists x, y = f x /\ In x l.
Proof.
  intros. induction l; simpl in * . tauto. destruct H. eauto. firstorder.
Qed.

Ltac elim_In_map H x Eq Mem :=
  let tmp := fresh "tmp" in (
    try rename H into tmp;
    elim (In_map_exists _ _ _ tmp); intro x; destruct 1 as [Eq Mem];
    try clear tmp
  ).

Ltac elim_all_In_map :=
  repeat match goal with
           | H : In ?y (map ?f ?l) |- _ =>
             let Eq := fresh "Eq" with tmp := fresh "tmp" in (
               rename H into tmp;
               elim (In_map_exists _ _ _ tmp); intro; destruct 1 as [Eq Mem];
               clear tmp
             )
         end.

(*** Membership function ***)

Section list_mem.
Variable A : Type.
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).
Implicit Types x : A.
Implicit Types xs l : list A.

Ltac case_eq foo :=
  generalize (refl_equal foo);
  pattern foo at -1;
  case foo.

Notation list_mem := (list_mem eq_dec).

Lemma list_mem_implies_In :
  forall x l, Is_true (list_mem x l) -> In x l.
Proof.
  intros. induction l. assumption. simpl in *; destruct (eq_dec a x); tauto.
Qed.
Lemma list_mem_false_implies_not_In :
  forall x l, list_mem x l = false -> ~In x l.
Proof.
  intros. induction l; simpl in * . tauto.
  destruct (eq_dec a x). discriminate. tauto.
Qed.
Lemma case_list_mem_In :
  forall x l, if list_mem x l then In x l else ~In x l.
Proof.
  intros; induction l; simpl in * . tauto.
  destruct (eq_dec a x). tauto. destruct (list_mem x l); tauto.
Qed.
Lemma list_mem_eq_In_dec :
  forall x l, list_mem x l = if In_dec eq_dec x l then true else false.
Proof.
  intros. assert (If := case_list_mem_In x l).
  destruct (list_mem x l); destruct (In_dec eq_dec x l); tauto.
Qed.

Lemma In_implies_list_mem :
  forall x l, In x l -> Is_true (list_mem x l).
Proof.
  intros. induction l. assumption.
  simpl in *; destruct (eq_dec a x); simpl; tauto.
Qed.
Lemma not_In_implies_list_mem_false :
  forall x l, ~In x l -> list_mem x l = false.
Proof.
  intros. induction l; simpl in * . tauto. destruct (eq_dec a x); tauto.
Qed.

Lemma list_mem_app :
  forall x l l', list_mem x (l++l') = list_mem x l || list_mem x l'.
Proof.
  intros; repeat rewrite list_mem_eq_In_dec;
    repeat match goal with |- context C [In_dec ?eq_dec_ ?x_ ?l_] =>
             destruct (In_dec eq_dec_ x_ l_)
           end;
    intros; try ring; elimtype False;
    (let a := type of i in (generalize dependent i; fold (~a)));
    auto with datatypes.
Qed.

Lemma nth_error_mem :
  forall l n x, nth_error l n = Some x -> Is_true (list_mem x l).
Proof. intros; apply In_implies_list_mem. eapply nth_error_In; eauto. Qed.
Lemma nth_safe_mem :
  forall l n H, Is_true (list_mem (nth_safe l n H) l).
Proof. intros; apply In_implies_list_mem. apply nth_safe_In; auto. Qed.

End list_mem.

Hint Rewrite list_mem_app : lists.

(*** Removing an element ***)

Section list_minus.
Variable A : Type.
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).
Implicit Types x : A.
Implicit Types xs l : list A.

Notation list_minus := (list_minus eq_dec).

Lemma not_In_list_minus_self :
  forall l x, ~In x (list_minus l (x::nil)).
Proof.
  induction l; intros; simpl in * . tauto.
  destruct (eq_dec x a); simpl in *; firstorder.
Qed.

Lemma In_list_plus :
  forall x l l', In x (list_minus l l') -> In x l.
Proof.
  induction l; intros; simpl in * . assumption.
  destruct (list_mem eq_dec a l'); simpl in *; firstorder.
Qed.

Lemma In_list_minus_other :
  forall l x x', x' <> x -> In x l -> In x (list_minus l (x'::nil)).
Proof.
  induction l; intros; simpl in * . assumption.
  destruct (eq_dec x' a); subst; simpl in * .
  apply IHl; tauto.
  destruct H0. tauto. auto.
Qed.

End list_minus.

Hint Resolve In_list_plus : In_list_plus.
Hint Resolve In_list_minus_other : datatypes.


(** * Common facts about UIP and proof irrelevance *)
Require Import Coq.Logic.EqdepFacts.

Set Implicit Arguments.

Lemma Eq_rect_eq_UIP_helper {U x y} (p : x = y :> U)
: p = match p in (_ = y) return (x = y) with eq_refl => eq_refl end.
Proof.
  destruct p; reflexivity.
Defined.

Lemma Eq_rect_eq_UIP_ U : Eq_rect_eq U -> UIP_ U.
Proof.
  lazy; intro H.
  intros x y p1 p2.
  destruct p2.
  specialize (H x (fun y => x = y) eq_refl p1); simpl in *.
  rewrite <- Eq_rect_eq_UIP_helper in H.
  symmetry; assumption.
Qed.

Definition dec_eq_adjust' {U x} (p : forall y : U, {x = y} + {x <> y}) y
: {x = y} + {x <> y}
  := match p x, p y with
       | left pf, left pf' => left (eq_trans (eq_sym pf) pf')
       | right pf, _ => match pf eq_refl with end
       | _, right pf => right pf
     end.

Lemma concat_Vp {U x y} (p : x = y :> U)
: eq_trans (eq_sym p) p = eq_refl.
Proof.
  destruct p; reflexivity.
Defined.

Lemma dec_eq_uip' {U x y} (pf : x = y)
      (p : forall y : U, {x = y} + {x <> y})
: pf = match dec_eq_adjust' p y with
         | left pf' => pf'
         | right pf' => match pf' pf with end
       end.
Proof.
  destruct pf.
  unfold dec_eq_adjust'.
  destruct (p x) as [|n].
  { symmetry; apply concat_Vp. }
  { destruct (n eq_refl). }
Defined.

Lemma dec_eq_uip {U x}
      (dec : forall y : U, {x = y} + {x <> y})
      y
      (p q : x = y :> U)
: p = q.
Proof.
  etransitivity; [ | symmetry ].
  { apply (dec_eq_uip' _ dec). }
  { etransitivity; [ apply (dec_eq_uip' _ dec) | ].
    edestruct @dec_eq_adjust' as [|n]; try reflexivity.
    destruct (n p). }
Qed.


Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path Eqdep.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive type := Nat | Bool | Prod of type & type.

Fixpoint typeDenote t :=
  match t with
    Nat => nat
  | Bool => bool
  | Prod t1 t2 => prod (typeDenote t1) (typeDenote t2)
  end.

Inductive exp t :=
  NConst' of Nat = t & nat
| Plus' of Nat = t & exp Nat & exp Nat
| Eq' of  Bool = t & exp Nat & exp Nat
| BConst' of Bool = t & bool
| And' of Bool = t & exp Bool & exp Bool
| If of exp Bool & exp t & exp t
| Pair' t1 t2 of Prod t1 t2 = t & exp t1 & exp t2
| Fst t2 of exp (Prod t t2)
| Snd t1 of exp (Prod t1 t).

Notation NConst := (NConst' (erefl _)).
Notation Plus := (Plus' (erefl _)).
Notation Eq := (Eq' (erefl _)).
Notation BConst := (BConst' (erefl _)).
Notation And := (And' (erefl _)).
Notation Pair := (Pair' (erefl _)).

(* a better induction principle; gathers the like constructors *)
(* and removes unnecessary type equations *)

Definition cast T (t t' : type) (r : t = t') (e : T t) :=
  match r in (_ = t') return T t' with erefl => e end.

(* eliminating casts *)
Lemma eqc T t (r : t = t) (e : T t) : cast r e = e.
Proof. by move: r; apply: Streicher_K. Qed.

(*
(* One can recover the behavior of the family as follows *)

Inductive exp_spec : forall t', exp t' -> Type :=
  nconst_exp n : exp_spec (NConst n)
| plus_exp e1 e2 : exp_spec (Plus e1 e2)
| eq_exp e1 e2 : exp_spec (Eq e1 e2)
| bconst_exp b : exp_spec (BConst b)
| and_exp e1 e2 : exp_spec (And e1 e2)
| if_exp t b (e1 e2 : exp t) : exp_spec (If b e1 e2)
| pair_exp t1 t2 (e1 : exp t1) (e2 : exp t2) :
    exp_spec (Pair e1 e2)
| fst_exp t t2 (e : exp (Prod t t2)) : exp_spec (Fst e)
| snd_exp t t1 (e : exp (Prod t1 t)) : exp_spec (Snd e).

Lemma expP t (e : exp t) : exp_spec e.
Proof. by case: e=>*; try subst t; constructor. Qed.

(*
Given t : type, x : exp t, casing over (expP x) will rewrite
occurences of x in the goal by NConst n, Plus e1 e2, etc, and the
occurences of t by Nat, Nat, Bool, etc, as it corresponds.

Very often this results in ill-typed goals, so one needs to use
occurence selectors and patterns to prevent some occurence from being
changed.
*)

(* test goals *)
Lemma xx1 n (x : exp Nat) : x = NConst n.
Proof.
case: {-1}Nat x / (expP x) (erefl _).
(* the above works, because we protected the first occurence of pattern Nat
(which is what t is in this case, from being changed. But all the other occurences
are changed. Notice also that we had to first abstract erefl, as the first
occurence of Nat is precisely in the type of the erefl *)
Abort.

Lemma xx2 t (x : exp t) : t = Nat /\ x = x.
Proof.
case: {-1}t x / (expP x).
Abort.
*)

Fixpoint expDenote t (e : exp t) : typeDenote t :=
  match e with
    NConst' r n => cast r n
  | Plus' r e1 e2 => cast r (expDenote e1 + expDenote e2)
  | Eq' r e1 e2 => cast r (expDenote e1 == expDenote e2)
  | BConst' r b => cast r b
  | And' r e1 e2 => cast r (expDenote e1 && expDenote e2)
  | If e' e1 e2 => if expDenote e' then expDenote e1 else expDenote e2
  | Pair' _ _ r e1 e2 => cast r (expDenote e1, expDenote e2)
  | Fst _ e' => fst (expDenote e')
  | Snd _ e' => snd (expDenote e')
  end.

Lemma pair_out t1 t2 s1 s2 : Prod t1 t2 = Prod s1 s2 -> t1 = s1 /\ t2 = s2.
Proof. by case. Qed.

Fixpoint cfold t (e : exp t) : exp t :=
  match e with
    NConst' r n => NConst' r n
  | Plus' r e1 e2 =>
      let: (f1, f2) := (cfold e1, cfold e2) in
      if (f1, f2) is (NConst' _ n1, NConst' _ n2) then NConst' r (n1 + n2)
      else Plus' r f1 f2
  | Eq' r e1 e2 =>
      let: (f1, f2) := (cfold e1, cfold e2) in
      if (f1, f2) is (NConst' _ n1, NConst' _ n2) then BConst' r (n1 == n2)
      else Eq' r f1 f2
  | BConst' r b => BConst' r b
  | And' r e1 e2 =>
      let: (f1, f2) := (cfold e1, cfold e2) in
      if (f1, f2) is (BConst' _ b1, BConst' _ b2) then BConst' r (b1 && b2)
      else And' r f1 f2
  | If e e1 e2 =>
      let: f := cfold e in
      match f with
        BConst' _ true => cfold e1
      | BConst' _ false => cfold e2
      | _ => If f (cfold e1) (cfold e2)
      end
  | Pair' _ _ r e1 e2 => Pair' r (cfold e1) (cfold e2)
  | Fst _ e =>
      let: f := cfold e in
      if f is Pair' _ _ r e1 e2 then cast (proj1 (pair_out r)) e1 else Fst f
  | Snd _ e =>
      let f := cfold e in
      if f is Pair' _ _ r e1 e2 then cast (proj2 (pair_out r)) e2 else Snd f
  end.

Lemma exp_ind' (P : forall t : type, exp t -> Prop) :
        [/\ forall n, P Nat (NConst n) &
            forall b, P Bool (BConst b)] ->
        [/\ forall e1 e2, P Nat e1 -> P Nat e2 -> P Nat (Plus e1 e2),
            forall e1 e2, P Nat e1 -> P Nat e2 -> P Bool (Eq e1 e2) &
            forall e1 e2, P Bool e1 -> P Bool e2 -> P Bool (And e1 e2)] ->
        (forall t e e1 e2, P Bool e -> P t e1 -> P t e2 -> P t (If e e1 e2)) ->
        (forall t1 t2 e1 e2, P t1 e1 -> P t2 e2 -> P (Prod t1 t2) (Pair e1 e2)) ->
        [/\ forall t1 t2 e, P (Prod t1 t2) e -> P t1 (Fst e) &
            forall t1 t2 e, P (Prod t1 t2) e -> P t2 (Snd e)] ->
        forall t e, P t e.
Proof. by case=>?? [???] ?? [??] t; elim=>t' *; try subst t'; intuition. Qed.

Lemma cfold_correct t (e : exp t) : expDenote e = expDenote (cfold e).
Proof.
elim/exp_ind': e=>//=.
- by split=>?? ->->; do 2![case: (cfold _)=>//= *]; rewrite !eqc.
- by move=>???? ->->->; case: (cfold _)=>//= *; rewrite eqc; case: ifP.
- by move=>???? ->->.
by split=>??? ->; case: (cfold _)=>//= ?? r; case: r (r)=>->-> *; rewrite !eqc.
Qed.

(* Implementation using an indexed family *)

Inductive exp2 : type -> Type :=
  NConst2 of nat : exp2 Nat
| Plus2 of exp2 Nat & exp2 Nat : exp2 Nat
| Eq2 of exp2 Nat & exp2 Nat : exp2 Bool
| BConst2 of bool : exp2 Bool
| And2 of exp2 Bool & exp2 Bool : exp2 Bool
| If2 t of exp2 Bool & exp2 t & exp2 t : exp2 t
| Pair2 t1 t2 of exp2 t1 & exp2 t2 : exp2 (Prod t1 t2)
| Fst2 t1 t2 of exp2 (Prod t1 t2) : exp2 t1
| Snd2 t1 t2 of exp2 (Prod t1 t2) : exp2 t2.

Fixpoint expDenote2 t (e : exp2 t) : typeDenote t :=
  match e with
    NConst2 n => n
  | Plus2 e1 e2 => expDenote2 e1 + expDenote2 e2
  | Eq2 e1 e2 => expDenote2 e1 == expDenote2 e2
  | BConst2 b => b
  | And2 e1 e2 => expDenote2 e1 && expDenote2 e2
  | If2 _ e' e1 e2 => if expDenote2 e' then expDenote2 e1 else expDenote2 e2
  | Pair2 _ _ e1 e2 => (expDenote2 e1, expDenote2 e2)
  | Fst2 _ _ e' => fst (expDenote2 e')
  | Snd2 _ _ e' => snd (expDenote2 e')
  end.

Definition pairOutType t :=
  option (if t is Prod t1 t2 then exp2 t1 * exp2 t2 else unit).

Definition pair_out2 t (e : exp2 t) :=
  if e is Pair2 _ _ e1 e2 in exp2 t return pairOutType t
  then Some (e1, e2) else None.

Fixpoint cfold2 t (e : exp2 t) : exp2 t :=
  match e with
    NConst2 n => NConst2 n
  | Plus2 e1 e2 =>
      let: (f1, f2) := (cfold2 e1, cfold2 e2) in
      if (f1, f2) is (NConst2 n1, NConst2 n2) then NConst2 (n1 + n2)
      else Plus2 f1 f2
  | Eq2 e1 e2 =>
      let: (f1, f2) := (cfold2 e1, cfold2 e2) in
      if (f1, f2) is (NConst2 n1, NConst2 n2) then BConst2 (n1 == n2)
      else Eq2 f1 f2
  | BConst2 b => BConst2 b
  | And2 e1 e2 =>
      let: (f1, f2) := (cfold2 e1, cfold2 e2) in
      if (f1, f2) is (BConst2 b1, BConst2 b2) then BConst2 (b1 && b2)
      else And2 f1 f2
  | If2 _ e e1 e2 =>
      let: f := cfold2 e in
      match f with
        BConst2 true => cfold2 e1
      | BConst2 false => cfold2 e2
      | _ => If2 f (cfold2 e1) (cfold2 e2)
      end
  | Pair2 _ _ e1 e2 => Pair2 (cfold2 e1) (cfold2 e2)
  | Fst2 _ _ e =>
      let: f := cfold2 e in
      if pair_out2 f is Some p then fst p else Fst2 f
  | Snd2 t1 t2 e1 =>
      let: f := cfold2 e1 in
      if pair_out2 f is Some p then snd p else Snd2 f
end.

Lemma cfold_correct2 t (e : exp2 t) : expDenote2 e = expDenote2 (cfold2 e).
Proof.
elim: e=>//.
- move=>/= e1 -> e2 ->.
Set Printing All.
(* in this goal, it's really impossible to count the occurences *)
(* moreover, the casing will change Nat to other types, but I have *)
(* addition in the goal, which will thus always be ill-typed after casing *)
(* it's not clear that that can even be protected by an occurence selection *)
(* hence, i don't think the right first move here is to case *)
(* rather, one has to obtain some type equations first, maybe by *)
(* inversion, or some other tactic *)
(* in principle, this whole approach looks completely wrongheaded *)
try case: {-3}Nat / (cfold2 e1).
Unset Printing All.
Abort.