From HB Require Import structures.
Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import edone preliminaries setoid_bigop structures.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

(** * 2pdom algebra, tests, initial algebra of terms *)

(** ** 2pdom algebra (the top-free fragment of 2p algebra) *)

(** NOTE: we let Ops inherit from Setoid, to avoid having a
"criss-cross" inheritance pattern that is not (yet) supported by HB *)
HB.mixin Record Ops_of_Type A :=
  { dot: A -> A -> A;
    par: A -> A -> A;
    cnv: A -> A;
    dom: A -> A;
    one: A;
    top: A;         (* top is left uninterpreted in 2pdom *)
  }.
HB.structure Definition Ops := { A of Ops_of_Type A & }.

Arguments one {_}: simpl never.
Arguments top {_}: simpl never.
Arguments dot: simpl never.
Arguments par: simpl never.
Arguments cnv: simpl never.
Arguments dom: simpl never.

Declare Scope pttdom_ops.
Bind Scope pttdom_ops with Ops.type.
Delimit Scope pttdom_ops with ptt.
Open Scope pttdom_ops.
Notation "x ∥ y" := (par x y) (left associativity, at level 40, format "x ∥ y"): pttdom_ops.
Notation "x · y" := (dot x y) (left associativity, at level 25, format "x · y"): pttdom_ops.
Notation "x °"  := (cnv x) (left associativity, at level 5, format "x °"): pttdom_ops.
Notation "1"  := (one): pttdom_ops.

(* 2pdom axioms *)

HB.mixin Record Pttdom_of_Ops A of Ops_of_Type A & Setoid_of_Type A :=
  { dot_eqv: Proper (eqv ==> eqv ==> eqv) (dot : A -> A -> A);
    par_eqv: Proper (eqv ==> eqv ==> eqv) (par : A -> A -> A);
    cnv_eqv: Proper (eqv ==> eqv) (cnv : A -> A);
    dom_eqv: Proper (eqv ==> eqv) (dom : A -> A);
    parA: forall x y z: A, x ∥ (y ∥ z) ≡ (x ∥ y) ∥ z;
    parC: forall x y: A, x ∥ y ≡ y ∥ x;
    dotA: forall x y z: A, x · (y · z) ≡ (x · y) · z;
    dotx1: forall x: A, x · 1 ≡ x;
    cnvI: forall x: A, x°° ≡ x;
    cnvpar: forall x y: A, (x ∥ y)° ≡ x° ∥ y°;
    cnvdot: forall x y: A, (x · y)° ≡ y° · x°;
    par11: (1 : A) ∥ 1 ≡ 1;
    A10: forall x y: A, 1 ∥ x·y ≡ dom (x ∥ y°);
    A13: forall x y: A, dom(x·y) ≡ dom(x·dom y);
    A14: forall x y z: A, dom x·(y∥z) ≡ dom x·y ∥ z;
  }.
HB.structure Definition Pttdom := { A of Pttdom_of_Ops A & }.
Notation pttdom := Pttdom.type.
#[export] Existing Instances dot_eqv par_eqv cnv_eqv dom_eqv.

Class is_test (X : pttdom) (x : X) := { testE : dom x ≡ x }.

(* Coercion ops_of (X : pttdom) (x : Pttdom.sort X) : Ops.sort X := x. *)
(* Coercion setoid_of (X : Ops) (x : Pttdom.sort X) : Setoid.sort X := x. *)

(** ** basic derivable laws  *)
Section derived.

 Variable X: pttdom.
 Implicit Types u v x y z: X.

 Lemma cnv1: 1° ≡ @one X.
 Proof. rewrite -[1°]dotx1 -{2}[1]cnvI. by rewrite -cnvdot dotx1 cnvI. Qed.

 Lemma dot1x x: 1·x ≡ x.
 Proof. by rewrite -[1·x]cnvI cnvdot cnv1 dotx1 cnvI. Qed.

 Lemma cnv_inj x y: x° ≡ y° -> x ≡ y.
 Proof. intro. rewrite <-(cnvI x), <-(cnvI y). by apply cnv_eqv. Qed.

 Lemma dotcnv x y: x·y ≡ (y°·x°)°.
 Proof. apply cnv_inj. by rewrite cnvdot cnvI. Qed.

 (** ** tests *)
 (* Definition is_test x := dom x ≡ x. *)
 Record test := Test{ elem_of :> X ; testP : is_test elem_of }.

 Global Instance test_test (a : test) : is_test (elem_of a).
 Proof. exact: testP. Qed.

 Implicit Types a b c d : X.

 Lemma is_test_alt x: dom x ≡ x <-> x∥1 ≡ x.
 Proof.
   split=>E.
   - rewrite -{1}E -{1}(dotx1 (dom x)) -A14.
     by rewrite par11 dotx1.
   - by rewrite -E -{1}cnv1 -A10 dotx1 parC.
 Qed.

 Lemma domtst a of is_test a : dom a ≡ a.
 Proof. exact: testE. Qed.

 Lemma tstpar1 a of is_test a :  a ∥ 1 ≡ a.
 Proof. by apply/is_test_alt; rewrite domtst. Qed.

 Lemma one_test: is_test (1:X).
 Proof. constructor. by rewrite -{1}par11 -{2}cnv1 -A10 dotx1 par11. Qed.
 Global Existing Instance one_test.

 Lemma dom_test x: is_test (dom x).
 Proof. constructor. by rewrite -{1}[dom x]dot1x -A13 dot1x. Qed.
 Global Existing Instance dom_test.

 Lemma par_test a u of is_test a : is_test (a∥u).
 Proof.
   constructor; apply/is_test_alt.
   by rewrite -parA (parC u) parA tstpar1.
 Qed.
 Global Existing Instance par_test.

 Lemma cnvtst a of is_test a : a° ≡ a.
 Proof.
   rewrite -[a]tstpar1 cnvpar cnv1 -(dot1x (a°)) parC A10 cnvI parC.
   apply: domtst.
 Qed.

 Lemma cnv_test a of is_test a : is_test (a°).
 Proof. constructor. by rewrite is_test_alt cnvtst tstpar1. Qed.
 Global Existing Instance cnv_test.

 Lemma tstpar a x y of is_test a : a·(x∥y) ≡ a·x ∥ y.
 Proof. rewrite -[a]domtst. apply A14. Qed.

 Lemma tstpar_r a x y of is_test a : a·(x∥y) ≡ x ∥ a·y.
 Proof. by rewrite parC tstpar parC. Qed.

 Lemma pardot a b of is_test a & is_test b : a ∥ b ≡ a·b.
 Proof.
   by rewrite -{2}(@tstpar1 b) (parC _ 1) tstpar dotx1.
 Qed.

 Lemma dotC a b of is_test a & is_test b : a·b ≡ b·a.
 Proof. by rewrite -pardot parC pardot. Qed.

 Lemma dot_test a b of is_test a & is_test b : is_test (a·b).
 Proof. constructor. rewrite -pardot. apply: domtst. Qed.
 Global Existing Instance dot_test.

 (* (** automatised inference of tests *) *)
 (* Definition infer_test x b (e: elem_of b = x) := b. *)
 (* Notation "[ x ]" := (@infer_test x _ erefl). *)
 Notation "[ x ]" := (@Test x _).

 (** ** commutative monoid of  tests *)
 Definition eqv_test (a b : test) := elem_of a ≡ elem_of b.
 Arguments eqv_test _ _ /.
 Lemma eqv_test_equiv: Equivalence eqv_test.
 Proof.
   split => [x|x y|x y z]; rewrite /eqv_test /=.
   reflexivity. by symmetry. by transitivity (elem_of y).
 Qed.
 HB.instance Definition pttdom_test_setoid :=
   Setoid_of_Type.Build test eqv_test_equiv.

 Lemma infer_testE a of is_test a : elem_of [a] ≡ a.
 Proof. by []. Qed.
 Lemma eqv_testE a b of is_test a & is_test b : [a] ≡ [b] <-> a ≡ b.
 Proof. by []. Qed.

 Section M.
 Definition tst_dot (a b : test) : test := [elem_of a · elem_of b].
 Local Infix "·" := tst_dot.

 Lemma tst_dot_eqv: Proper (eqv ==> eqv ==> eqv) tst_dot.
 Proof. intros [a] [b] ? [c] [d] ?. by apply dot_eqv. Qed.
 Lemma tst_dotA: forall a b c : test, a·(b·c) ≡ (a·b)·c.
 Proof. intros [a] [b] [c]. apply dotA. Qed.
 Lemma tst_dotC: forall a b : test, a·b ≡ b·a.
 Proof. intros. by rewrite /tst_dot eqv_testE -pardot parC pardot. Qed.
 Lemma tst_dotU: forall a : test , a·[1] ≡ a.
 Proof. intros [a]. apply dotx1. Qed.

 Definition pttdom_monoid_laws :=
   mkComMonoidLaws tst_dot_eqv tst_dotA tst_dotC tst_dotU.
 HB.instance Definition pttdom_monoid :=
   ComMonoid_of_Setoid.Build test pttdom_monoid_laws.
 End M.

 (** ** label structure of a 2pdom algebra (Definition 4.3)  *)

 (* dualised equality (to get the [labels] structure below) *)
 Definition eqv' x y := x ≡ y°.
 Arguments eqv' _ _ /.
 Lemma eqv'_sym: Symmetric eqv'.
 Proof. move=> x y /= H. apply cnv_inj. by rewrite cnvI H. Qed.
 Lemma eqv01 x y z: x ≡ y -> eqv' y z -> eqv' x z.
 Proof. by move=> /= ->. Qed.
 Lemma eqv11 x y z: eqv' x y -> eqv' y z -> x ≡ z.
 Proof. move=> /= -> ->. apply cnvI. Qed.

 #[export,non_forgetful_inheritance]
 HB.instance Definition pttdom_elabel :=
   Elabel_of_Setoid.Build X eqv'_sym eqv01 eqv11.

 (* Lemmas to turn pttdom expressions into (projections of) tests *)
 Lemma par1tst u : 1 ∥ u = elem_of [1∥u]. by []. Qed.
 Lemma paratst (a : test) u : elem_of a ∥ u = elem_of [elem_of a∥u]. by []. Qed.
 Lemma dom_tst u : dom u = elem_of [dom u]. by []. Qed.

 (* this allows rewriting an equivalence between tests inside a pttdom expression *)
 Lemma rwT (a b: test) : a ≡ b -> elem_of a ≡ elem_of b. by []. Qed.

 (** ** other derivable laws used in the completeness proof *)

 Lemma partst u v a of is_test a : (u ∥ v)·a ≡ u ∥ v·a.
 Proof.
   apply cnv_inj. rewrite cnvdot 2!cnvpar cnvdot.
   by rewrite parC tstpar parC.
 Qed.

 Lemma par_tst_cnv a u of is_test a : a ∥ u° ≡ a ∥ u.
 Proof. by rewrite -[a∥u°]cnvtst cnvpar cnvtst cnvI. Qed.

 Lemma eqvb_par1 a u v (b : bool) of is_test a : u ≡[b] v -> a ∥ u ≡ a ∥ v.
 Proof. case: b => [->|-> //]. exact: par_tst_cnv. Qed.

 (* used twice in reduce in reduction.v *)
 Lemma reduce_shuffle v a c d of is_test a & is_test c & is_test d :
   c·(d·a)·(1∥v) ≡ a ∥ c·v·d.
 Proof.
   rewrite -!dotA -tstpar_r; apply: dot_eqv => //.
   by rewrite -partst tstpar dotx1 dotC.
 Qed.

 (* lemma for nt_correct *)
 Lemma par_nontest u v a b c d of is_test a & is_test b & is_test c & is_test d :
   a·u·b∥c·v·d ≡ (a·c)·(u∥v)·(b·d).
 Proof. by rewrite -partst -[a·u·b]dotA -tstpar parC -tstpar -partst !dotA parC. Qed.

 (* used in open.v *)
 Lemma eqvbN u v : u ≡[false] v -> u ≡ v. by []. Qed.
 Lemma eqvbT u v : u ≡[true] v -> u ≡ v°. by []. Qed.

 Lemma eqvE' u v : (u ≡' v) = (u ≡ v°).  by []. Qed.

 Lemma eqvb_neq u v (b : bool) : u ≡[~~b] v <-> u ≡[b] v°.
 Proof. by split; apply: eqvb_transL; rewrite ?(addbN,addNb) addbb /= ?eqvE' ?cnvI. Qed.

End derived.
(* Coercion pttdom_labels: pttdom >-> labels.  *)

 Notation "[ x ]" := (@Test _ x _).

(* Notation "[ x ]" := (@infer_test _ x%ptt _ erefl): pttdom_ops. *)

(** ** initial algebra of terms *)
Section terms.
 Variable A: Type.
 Inductive term :=
 | tm_dot: term -> term -> term
 | tm_par: term -> term -> term
 | tm_cnv: term -> term
 | tm_dom: term -> term
 | tm_one: term
 | tm_var: A -> term.
 Bind Scope pttdom_ops with term.
 Section e.
 Variable (X: Ops.type) (f: A -> X).
 Fixpoint eval (u: term): X :=
   match u with
   | tm_dot u v => eval u · eval v
   | tm_par u v => eval u ∥ eval v
   | tm_cnv u => (eval u) °
   | tm_dom u => dom (eval u)
   | tm_one => 1
   | tm_var a => f a
   end.
 End e.

 (* axiomatic equality on terms *)
 (* (via impredicative encoding to avoid repeating the axioms in an inductive definition)) *)
 Definition tm_eqv (u v: term): Prop :=
   forall (X: pttdom) (f: A -> X), eval f u ≡ eval f v.

 Hint Unfold tm_eqv : core.
 Lemma tm_eqv_equivalence: Equivalence tm_eqv.
 Proof.
   constructor.
     now intro.
     intros ?? H X f. specialize (H X f). by symmetry.
     intros ??? H H' X f. specialize (H X f). specialize (H' X f). etransitivity. apply H. apply H'.
 Qed.
 HB.instance Definition tm_setoid := Setoid_of_Type.Build term tm_eqv_equivalence.

 HB.instance Definition tm_ops := Ops_of_Type.Build term tm_dot tm_par tm_cnv tm_dom tm_one tm_one.

 (* Arguments eqv { _ } _ _ / . *)

 Lemma tm_eqv_eqv (u v: term) (X: pttdom) (f: A -> X) :
   u ≡ v -> eval f u ≡ eval f v.
 Proof. exact. Qed.

 Definition tm_pttdom : Pttdom_of_Ops.axioms_ term tm_ops tm_setoid.
 Proof.
   refine (Pttdom_of_Ops.Build term _ _ _ _ _ _ _ _ _ _ _ _ _ _ _).
   abstract (by repeat intro; simpl; apply dot_eqv; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply par_eqv; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply cnv_eqv; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply dom_eqv; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply parA; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply parC; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply dotA; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply dotx1; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply cnvI; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply cnvpar; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply cnvdot; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply par11; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply A10; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply A13; apply: tm_eqv_eqv).
   abstract (by repeat intro; simpl; apply A14; apply: tm_eqv_eqv).
 Defined.

 HB.instance Definition _ := tm_pttdom.
 HB.instance Definition _ := Elabel.copy term [the pttdom of term].

 Notation test := (test [the pttdom of term]).

 (** ** normal terms and normalisation function (Section 7)*)

 (* TOTHINK: might want to move normalisation to completeness related files
    also, the normal terms construction actually works in an arbitrary pttdom *)

 (* normal terms *)
 Inductive nterm :=
 | nt_test: test -> nterm
 | nt_conn: test -> term -> test -> nterm.

 (* reading back terms *)
 Definition term_of_nterm (t: nterm) :=
   match t with
   | nt_test alpha => elem_of alpha (* why do we need to insert the coercion??? *)
   | nt_conn alpha u gamma => elem_of alpha · u · elem_of gamma
   end.

 (* pttdom algebra on normal terms *)
 Definition nt_one := nt_test [1].
 Definition nt_var a := nt_conn [1] (tm_var a) [1].
 Definition nt_cnv u :=
   match u with
   | nt_test _ => u
   | nt_conn a u b => nt_conn b (u°) a
   end.
 Definition nt_dom u :=
   match u with
   | nt_test _ => u
   | nt_conn a u b => nt_test [elem_of a · dom (u·elem_of b)]
   end.
 Definition nt_dot u v :=
   match u,v with
   | nt_test a, nt_test b => nt_test [elem_of a·elem_of b]
   | nt_test a, nt_conn b u c => nt_conn [elem_of a·elem_of b] u c
   | nt_conn a u b, nt_test c => nt_conn a u [elem_of b·elem_of c]
   | nt_conn a u b, nt_conn c v d => nt_conn a (u·elem_of b·elem_of c·v) d
   end.
 Definition nt_par u v :=
   match u,v with
   | nt_test a, nt_test b => nt_test [elem_of a·elem_of b]
   | nt_test a, nt_conn b u c => nt_test [elem_of a ∥ elem_of b·u·elem_of c]
   | nt_conn a u b, nt_test c => nt_test [elem_of c ∥ elem_of a·u·elem_of b]
   | nt_conn a u b, nt_conn c v d => nt_conn [elem_of a·elem_of c] (u ∥ v) [elem_of b·elem_of d]
   end.

 (* normalisation function (Definition 7.1) *)
 (* TODO: define it as an [eval]) *)
 Fixpoint nt (u: term): nterm :=
   match u with
   | tm_dot u v => nt_dot (nt u) (nt v)
   | tm_par u v => nt_par (nt u) (nt v)
   | tm_cnv u => nt_cnv (nt u)
   | tm_var a => nt_var a
   | tm_dom u => nt_dom (nt u)
   | tm_one => nt_one
   end.

 (** Induction on terms exposes [tm_*] constructors. The [fold_ops]
 tactic recovers the notations for the term algebra *)
 Ltac fold_ops :=
   repeat match goal with
          | |- context[tm_par ?u ?v] => change (tm_par u v) with (u ∥ v)
          | |- context[tm_dot ?u ?v] => change (tm_dot u v) with (u · v)
          | |- context[tm_cnv ?u] => change (tm_cnv u) with (u°)
          | |- context[tm_dom ?u] => change (tm_dom u) with (dom u)
          | |- context[tm_one ?A] => change (tm_one A) with one
          | |- tm_eqv ?u ?v => change (u ≡ v)
         end.

 (* correctness of the normalisation function (Proposition 7.1)  *)
 Proposition nt_correct (u: term): u ≡ term_of_nterm (nt u).
 Proof.
   induction u=>//=; fold_ops.
   - (* rewrite {1}IHu1 {1}IHu2. - coq 8.12 regression *)
     rewrite (dot_eqv _ _ IHu1 _ _ IHu2).
     case (nt u1) =>[a|a u b];
     case (nt u2)=>[c|c v d] //=;
     rewrite !dotA//.
   - (* rewrite {1}IHu1 {1}IHu2. *)
     rewrite (par_eqv _ _ IHu1 _ _ IHu2).
     case (nt u1)=>[a|a u b];
     case (nt u2)=>[c|c v d]=>//=.
     exact: pardot.
     apply: parC.
     exact: par_nontest.
   - rewrite {1}IHu.
     case (nt u)=>[a|a v b]=>//=.
     exact: cnvtst.
     by rewrite 2!cnvdot dotA !cnvtst.
   - rewrite {1}IHu.
     case (nt u)=>[a|a v b]=>//=.
     exact: domtst.
     by rewrite -dotA A13 domtst.
   - by rewrite dotx1 dot1x.
 Qed.

End terms.


(* Simple let-patterns *)
Variable A B : Type.

Definition l1 (t : A * B * B) : A := let '(x, y, z) := t in x.
Print l1.
Definition l2 (t : (A * B) * B) : A := let '((x, y), z) := t in x.
Definition l3 (t : A * (B * B)) : A := let '(x, (y, z)) := t in x.
Print l3.

Record someT (A : Type) := mkT { a : nat; b: A }.

Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x.
Print l4.
Print sigT.

Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  let 'existT x y := t return B (projT1 t) in y.

Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  let 'existT x y as t' := t return B (projT1 t') in y.

Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  let 'existT x y as t' in sigT _ := t return B (projT1 t') in y.

Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  match t with
    existT x y => y
  end.

(** An example from algebra, using let' and inference of return clauses
   to deconstruct contexts. *)

Record a_category (A : Type) (hom : A -> A -> Type) := {  }.

Definition category := { A : Type & { hom : A -> A -> Type & a_category A hom } }.

Record a_functor (A : Type) (hom : A -> A -> Type) (C : a_category A hom) := {  }.

Notation " x :& y " := (@existT _ _ x y) (right associativity, at level 55) : core_scope.

Definition functor (c d : category) :=
  let ' A :& homA :& CA := c in
  let ' B :& homB :& CB := d in
    A -> B.

Definition identity_functor (c : category) : functor c c :=
  let 'A :& homA :& CA := c in
    fun x => x.

Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c :=
  let 'A :& homA :& CA := a in
  let 'B :& homB :& CB := b in
  let 'C :& homB :& CB := c in
    fun f g =>
      fun x => g (f x).


(*
 * mu-calculus for data words (of finite length)
 *)

Require Export Nat Arith.
Require Export List.

(* data words *)

Definition D := nat.
Definition At := nat.
Definition Sigma := At -> bool.
Definition data_word := list (Sigma * D)%type.

(* LTL syntax *)

Definition register := nat.
Definition V := nat.

Inductive ltl_atom :=
  | tt : ltl_atom
  | MATCH : register -> ltl_atom
  | p : At -> ltl_atom  (* an atomic proposition *)
  | END : ltl_atom
  .

Inductive ltl_phi :=
  | pos : ltl_atom -> ltl_phi  (* a positive literal *)
  | neg : ltl_atom -> ltl_phi  (* a negative literal *)
  | AND_phi : ltl_phi -> ltl_phi -> ltl_phi
  .

Inductive ltl :=
  | var : V -> ltl
  | OR  : ltl -> ltl -> ltl
  | AND : ltl -> ltl_phi -> ltl
  | STORE : register -> ltl -> ltl
  | X : ltl -> ltl
  | until : ltl_phi -> ltl -> ltl
  | PHI : ltl_phi -> ltl
  | G : ltl_phi -> ltl
  .

Notation "'↑' r" := (MATCH r) (at level 75).
Notation "a '.\/' b" := (OR   a b) (at level 85, right associativity).
Notation "a './\' b" := (AND  a b) (at level 75, right associativity).
Notation "a '../\' b" := (AND_phi a b) (at level 75, right associativity).
Notation  "'[' a ']'" := (pos a).
Notation "'~[' a ']'" := (neg a).
Notation "'φ' p" := (PHI p) (at level 78).
Notation "a 'U' b" := (until a b) (at level 73, right associativity).
Notation "'↓' r ',' psi" := (STORE r psi) (at level 200).

(*
Check (AND (STORE 1 (X (OR (PHI (neg (p 1))) (PHI (pos (p 2)))))) (pos (↑ 1))).
Check ((↓1, X ((φ ~[p 1]) .\/ (φ [p 2]))) ./\ [↑1]).
*)

(* utilities *)

(* Forall_suffix_until p "cd" "abcd" <-> p "abcd" /\ p "bcd" *)
Inductive Forall_suffix_until {A : Type} :
  (list A -> Prop) -> list A -> list A -> Prop :=
  | Forall_sfx_until_eq : forall p l, Forall_suffix_until p l l
  | Forall_sfx_until : forall p s x l,
      Forall_suffix_until p s l -> p (x::l) ->
      Forall_suffix_until p s (x::l)
  .
Definition Forall_nonnil_suffix {A : Type}
  (p : list A -> Prop) (l : list A) : Prop :=
  Forall_suffix_until p nil l.

(* LTL semantics *)

Definition Theta := register -> D.

Definition update
  (theta : Theta) (i : register) (d : D) : Theta :=
  fun (r : register) => if r =? i then d else theta r.

Definition theta_bot : Theta :=
  fun (r : register) => 0.

Definition Env := V -> Theta -> data_word -> Prop.

Definition empty_env : Env :=
  fun (v : V) (theta : Theta) (w : data_word) => False.

Definition models_atom
  (w : data_word) (theta : Theta) (atom : ltl_atom)
  : Prop :=
  match w, atom with
  | _, tt => True
  | h::t, p a => fst h a = true
  | h::t, ↑ r => snd h = theta r
  | nil, END => True
  | _, _ => False
  end.

Fixpoint models_phi
  (w : data_word) (theta : Theta) (phi : ltl_phi)
  : Prop :=
  match phi with
  | pos atom =>   models_atom w theta atom
  | neg atom => ~ models_atom w theta atom
  | AND_phi p1 p2 =>
      models_phi w theta p1 /\ models_phi w theta p2
  end.

(*
Fixpoint models
  (u : Env) (w : data_word) (theta : Theta) (psi : ltl)
  : Prop :=
  match psi, w with
  | φ phi, _ => models_phi w theta phi
  | (↓ r, psi'), h::t => models u w (update theta r (snd h)) psi'
  | X psi', h::t => models u t theta psi'
  | psi' ./\ phi,  _ => models u w theta psi' /\ models_phi w theta phi
  | psi1 .\/ psi2, _ => models u w theta psi1 \/ models u w theta psi2
  | G phi, _ => Forall_nonnil_suffix (fun t => models_phi t theta phi) w
  | phi U psi', _ => exists w',
        models u w' theta psi' /\
        Forall_mid_suffix (fun t => models_phi t theta phi) w' w
  | var v, _ => In (w, theta) (u v)
  | _, nil => False
  end.
*)

Inductive models :
  Env -> data_word -> Theta -> ltl -> Prop :=
  | models_PHI : forall w theta u phi,
      models_phi w theta phi ->
      models u w theta (φ phi)
  | models_STORE : forall h t theta u r psi,
      models u (h::t) (update theta r (snd h)) psi ->
      models u (h::t) theta (↓ r, psi)
  | models_X : forall h t theta u psi,
      models u t theta psi ->
      models u (h::t) theta (X psi)
  | models_AND : forall w theta u psi phi,
      models u w theta psi ->
      models_phi w theta phi ->
      models u w theta (AND psi phi)
  | models_OR : forall w theta u psi1 psi2,
      models u w theta psi1 \/
      models u w theta psi2 ->
      models u w theta (OR psi1 psi2)
  | models_G : forall w theta u phi,
      Forall_nonnil_suffix (fun t => models_phi t theta phi) w ->
      models u w theta (G phi)
  | models_U : forall w theta u phi psi,
      (exists w',
       models u w' theta psi /\
       Forall_suffix_until (fun t => models_phi t theta phi) w' w) ->
      models u w theta (phi U psi)
  | models_var : forall w theta (u : Env) v,
      u v theta w ->
      models u w theta (var v)
  .

Notation "'(' w ',' theta '|=' u ',' psi ')'"
  := (models u w theta psi).

(* Equality of two ltl formulas *)

Axiom ltl_extensionality :
  forall psi1 psi2 : ltl,
    (forall w theta u, (w, theta |= u, psi1) <-> (w, theta |= u, psi2))
    -> psi1 = psi2.

Axiom Theta_extensionality :
  forall theta1 theta2 : Theta,
    (forall r, theta1 r = theta2 r) -> theta1 = theta2.

(* distribution over OR *)

Lemma distr_X_over_OR :
  forall psi1 psi2,
    (X (psi1 .\/ psi2)) = (X psi1 .\/ X psi2).
Proof.
  intros psi1 psi2.
  apply ltl_extensionality.
  intros w theta.
  split.
  - intros H.
  apply models_OR.
  inversion H
  as [| | h t th u' psi Hor EQu' EQht EQth EQpsi | | | | |].
  clear th EQth u' EQu' psi EQpsi.
  inversion Hor
  as [| | | | w' th u' p1 p2 Hor' EQu' EQw' EQth [EQp1 EQp2] | | |].
  clear w' EQw' th EQth u' EQu' p1 EQp1 p2 EQp2.
  destruct Hor' as [Hor' | Hor'].
  + left. now apply models_X.
  + right. now apply models_X.
  - intros H.
  inversion H
  as [| | | | w' th u' p1 p2 Hor EQu' EQw' EQth [EQp1 EQp2] | | |].
  clear w' EQw' th EQth u' EQu' p1 EQp1 p2 EQp2.
  destruct Hor as [Hor | Hor];
  inversion Hor
  as [| | h t th u' psi Hor' EQu' EQht EQth EQpsi | | | | |];
  clear th EQth u' EQu' psi EQpsi;
  apply models_X;
  apply models_OR.
  + now left.
  + now right.
Qed.

Lemma G_equals_phi_U_end :
  forall phi,
    (G phi) = (phi U (φ [END])).
Proof.
  intros phi.
  apply ltl_extensionality.
  intros w theta.
  split.
  - intros H.
  inversion H
  as [| | | | | w' th u' p Hsuf EQu' EQw' EQth EQp | |].
  clear w' EQw' th EQth u' EQu' p EQp.
  apply models_U.
  exists nil.
  split.
  + apply models_PHI.
  unfold models_phi.
  now unfold models_atom.
  + apply Hsuf.
  - intros H.
  inversion H
  as [| | | | | | w' th u' p1 p2 Hu EQu' EQw' EQth [EQp1 EQp2]|].
  clear w' EQw' th EQth u' EQu' p1 EQp1 p2 EQp2.
  destruct Hu as [w' [Hw' Hsuf]].
  inversion Hw'
  as [w'' th u' p Hend EQu' EQw'' EQth EQp | | | | | | |].
  clear w'' EQw'' th EQth u' EQu' p EQp.
  unfold models_phi in Hend.
  unfold models_atom in Hend.
  destruct w'.
  + now apply models_G.
  + contradiction.
Qed.

Lemma U_equals_psi_or_phi_and_XU :
  forall phi psi,
    (phi U psi) = (psi .\/ X (phi U psi) ./\ phi).
Proof.
  intros phi psi.
  apply ltl_extensionality.
  intros w theta.
  split.
  - intros H.
  apply models_OR.
  inversion H
  as [| | | | | | w' th u' p1 p2 Hsuf EQu' EQw' EQth [EQp1 EQp2]|].
  clear H w' EQw' th EQth u' EQu' p1 EQp1 p2 EQp2.
  destruct Hsuf as [w' [Hw' Hsuf]].
  destruct w as [| h t].
  + inversion Hsuf as [p l EQp EQl EQw' |].
  rewrite EQw' in Hw'.
  now left.
  + inversion Hsuf
  as [p l EQp EQl EQw'| p s x l Hsuf' Hp EQp EQs [EQx EQl]].
  * rewrite EQw' in Hw'.
  now left.
  * clear p EQp s EQs x EQx l EQl.
  right.
  apply models_AND; auto.
  apply models_X.
  apply models_U.
  now exists w'.
  - intros H.
  inversion H
  as [| | | | w' th u' p1 p2 Hor EQu' EQw' EQth [EQp1 EQp2] | | |].
  clear H w' EQw' th u' EQu' EQth p1 EQp1 p2 EQp2.
  apply models_U.
  destruct Hor as [H | H].
  + exists w.
  split; auto.
  apply Forall_sfx_until_eq.
  + inversion H
  as [| | | w' th u' p1 p2 Hw Hp EQu' EQw' EQth [EQp1 EQp2]| | | |].
  clear w' EQw' th EQth u' EQu' p1 EQp1 p2 EQp2.
  inversion Hw
  as [| |h t th u' p1 Ht EQu' EQht EQth EQp1| | | | |].
  clear th EQth u' EQu' p1 EQp1.
  inversion Ht
  as [| | | | | | w' th u' p1 p2 Hsuf EQu' EQw' EQth [EQp1 EQp2]|].
  clear H w' EQw' th EQth u' EQu' p1 EQp1 p2 EQp2.
  destruct Hsuf as [w' [Hw' Hsuf]].
  exists w'.
  rewrite <- EQht in Hp.
  split; auto.
  apply Forall_sfx_until; auto.
Qed.

Section GandU.

Variable phi : ltl_phi.
Variable theta : Theta.
Variable u : Env.

Lemma nil_satisfies_U_end :
  (nil, theta |= u, phi U (φ [END])).
Proof.
  apply models_U.
  exists nil.
  split.
  - apply models_PHI.
  unfold models_phi.
  now unfold models_atom.
  - apply Forall_sfx_until_eq.
Qed.

Lemma nil_satisfies_G_any :
  (nil, theta |= u, G phi).
Proof.
  rewrite G_equals_phi_U_end.
  apply nil_satisfies_U_end.
Qed.

End GandU.

Section GandF.

Variable phi : ltl_atom.
Variable theta : Theta.
Variable u : Env.

Lemma F_equals_not_G_not_1 :
  ~ (nil, theta |= u, φ [phi]) ->
  forall w, (w, theta |= u, [tt] U (φ [phi])) -> ~ (w, theta |= u, G ~[phi]).
Proof.
  intros Hphi.
  intros w.

  intros Hf Hg.
  inversion Hf
  as [| | | | | | w' th u' phi' psi Hu EQu' EQw' EQth [EQphi' EQpsi]|].
  clear w' EQw' th EQth u' EQu' phi' EQphi' psi EQpsi.
  destruct Hu as [w' [Hf1 Hf2]].
  inversion Hg
  as [| | | | |w'' th u' phi' Hg' EQu' EQw'' EQth EQphi'| |].
  clear w'' EQw'' th EQth u' EQu' phi' EQphi'.
  destruct phi.
  + (* phi = tt -> ... *)
  apply Hphi.
  apply models_PHI.
  unfold models_phi.
  now unfold models_atom.
  + (* phi = ↑ r -> ... *)
  clear Hf Hg.
  unfold Forall_nonnil_suffix in Hg'.
  induction Hf2
  as [p l | p s x l Hf2 IH Hp].
  * destruct l as [| x l].
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi' EQphi'.
  unfold models_phi in Hm.
  now unfold models_atom in Hm.
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi' EQphi'.
  inversion Hg'
  as [| p' s x' l' Hsl Hml EQp' EQs [EQx' EQl']].
  clear p' EQp' s EQs x' EQx' l' EQl'.
  unfold models_phi in Hm.
  unfold models_phi in Hml.
  now apply Hml in Hm.
  * apply (IH Hf1).
  inversion Hg'
  as [| p' s' x' l' Hsl Hml EQp' EQs' [EQx' EQl']].
  clear p' EQp' s' EQs' x' EQx' l' EQl'.
  apply Hsl.
  + (* phi = p a -> ... *)
  clear Hf Hg.
  unfold Forall_nonnil_suffix in Hg'.
  induction Hf2
  as [p l | p s x l Hf2 IH Hp].
  * destruct l as [| x l].
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi' EQphi'.
  unfold models_phi in Hm.
  now unfold models_atom in Hm.
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi' EQphi'.
  inversion Hg'
  as [| p' s x' l' Hsl Hml EQp' EQs [EQx' EQl']].
  clear p' EQp' s EQs x' EQx' l' EQl'.
  unfold models_phi in Hm.
  unfold models_phi in Hml.
  now apply Hml in Hm.
  * apply (IH Hf1).
  inversion Hg'
  as [| p' s' x' l' Hsl Hml EQp' EQs' [EQx' EQl']].
  clear p' EQp' s' EQs' x' EQx' l' EQl'.
  apply Hsl.
  + (* phi = END -> ... *)
  apply Hphi.
  apply models_PHI.
  unfold models_phi.
  now unfold models_atom.
Qed.

Lemma F_equals_not_G_not_2 :
  ~ (nil, theta |= u, φ ~[phi]) ->
  forall w, (w, theta |= u, [tt] U (φ ~[phi])) -> ~ (w, theta |= u, G [phi]).
Proof.
  intros Hphi.
  intros w.

  intros Hf Hg.
  inversion Hf
  as [| | | | | | w' th u' phi' psi Hu EQu' EQw' EQth [EQphi' EQpsi]|].
  clear w' EQw' th EQth u' EQu' phi' EQphi' psi EQpsi.
  destruct Hu as [w' [Hf1 Hf2]].
  inversion Hg
  as [| | | | |w'' th u' phi' Hg' EQu' EQw'' EQth EQphi'| |].
  clear w'' EQw'' th EQth u' EQu' phi' EQphi'.
  destruct phi.
  + (* phi = tt -> ... *)
  clear Hf Hg.
  unfold Forall_nonnil_suffix in Hg'.
  induction Hf2
  as [p l | p s x l Hf2 IH Hp].
  * destruct l as [| x l].
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi' EQphi'.
  unfold models_phi in Hm.
  now unfold models_atom in Hm.
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi' EQphi'.
  inversion Hg'
  as [| p' s x' l' Hsl Hml EQp' EQs [EQx' EQl']].
  clear p' EQp' s EQs x' EQx' l' EQl'.
  unfold models_phi in Hm.
  apply Hm.
  now unfold models_atom.
  * apply (IH Hf1).
  inversion Hg'
  as [| p' s' x' l' Hsl Hml EQp' EQs' [EQx' EQl']].
  clear p' EQp' s' EQs' x' EQx' l' EQl'.
  apply Hsl.
  + (* phi = ↑ r -> ... *)
  apply Hphi.
  apply models_PHI.
  unfold models_phi.
  now unfold models_atom.
  + (* phi = p a -> ... *)
  apply Hphi.
  apply models_PHI.
  unfold models_phi.
  now unfold models_atom.
  + (* phi = END -> ... *)
  clear Hf Hg.
  unfold Forall_nonnil_suffix in Hg'.
  induction Hf2
  as [p l | p s x l Hf2 IH Hp].
  * destruct l as [| x l].
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi EQphi'.
  unfold models_phi in Hm.
  now unfold models_atom in Hm.
  -- inversion Hf1
  as [w1 th1 u1 phi' Hm EQu1 EQw1 EQth1 EQphi'| | | | | | |].
  clear w1 EQw1 th1 EQth1 u1 EQu1 phi EQphi'.
  inversion Hg'
  as [| p' s x' l' Hsl Hml EQp' EQs [EQx' EQl']].
  clear p' EQp' s EQs x' EQx' l' EQl'.
  unfold models_phi in Hm.
  unfold models_phi in Hml.
  now apply Hm in Hml.
  * apply (IH Hf1).
  inversion Hg'
  as [| p' s' x' l' Hsl Hml EQp' EQs' [EQx' EQl']].
  clear p' EQp' s' EQs' x' EQx' l' EQl'.
  apply Hsl.
Qed.

Lemma F_equals_not_G_not_3 :
  forall w, ~ (w, theta |= u, [tt] U (φ [phi])) -> (w, theta |= u, G ~[phi]).
Proof.
  intros w.
  intros Hnf.
  apply models_G.
  unfold Forall_nonnil_suffix.
  induction w as [| x l IH].
  - apply Forall_sfx_until_eq.
  - apply Forall_sfx_until.
  + apply IH.
  intros Hl.
  apply Hnf.
  inversion Hl
  as [| | | | | | w' th u' phi' psi Hu EQu' EQw' EQth [EQphi' EQpsi]|].
  clear w' EQw' th EQth u' EQu' phi' EQphi' psi EQpsi.
  destruct Hu as [w' [Hf1 Hf2]].
  apply models_U.
  exists w'.
  split; auto.
  apply Forall_sfx_until; auto.
  unfold models_phi.
  now unfold models_atom.
  + unfold models_phi.
  intros Hxl.
  apply Hnf.
  apply models_U.
  exists (x :: l).
  split.
  * apply models_PHI.
  apply Hxl.
  * apply Forall_sfx_until_eq.
Qed.

Hypothesis classic : forall P, ~~P -> P.

Lemma F_equals_not_G_not_4 :
  forall w, ~ (w, theta |= u, [tt] U (φ ~[phi])) -> (w, theta |= u, G [phi]).
Proof.
  intros w.
  intros Hnf.
  apply models_G.
  unfold Forall_nonnil_suffix.
  induction w as [| x l IH].
  - apply Forall_sfx_until_eq.
  - apply Forall_sfx_until.
  + apply IH.
  intros Hl.
  apply Hnf.
  inversion Hl
  as [| | | | | | w' th u' phi' psi Hu EQu' EQw' EQth [EQphi' EQpsi]|].
  clear w' EQw' th EQth u' EQu' phi' EQphi' psi EQpsi.
  destruct Hu as [w' [Hf1 Hf2]].
  apply models_U.
  exists w'.
  split; auto.
  apply Forall_sfx_until; auto.
  unfold models_phi.
  now unfold models_atom.
  + unfold models_phi.
  apply classic.
  intros Hnxl.
  apply Hnf.
  apply models_U.
  exists (x :: l).
  split.
  * apply models_PHI.
  apply Hnxl.
  * apply Forall_sfx_until_eq.
Qed.

End GandF.

Lemma ff_neq_end :
  (φ ~[tt]) <> φ [END].
Proof.
  intros H.
  assert (H1 : ~ (nil, theta_bot |= empty_env, φ ~[tt])).
  { intros Hff.
  inversion Hff as [w th u' phi Hphi EQu' EQw EQth EQphi| | | | | | |].
  unfold models_phi in Hphi.
  now unfold models_atom in Hphi. }
  assert (H2 : (nil, theta_bot |= empty_env, φ [END])).
  { apply models_PHI.
  unfold models_phi.
  now unfold models_atom. }
  rewrite <- H in H2.
  now apply H1 in H2.
Qed.


Require Import Coq.Lists.List.
Require Import Io.All.
Require Import Io.System.All.
Require Import ListString.All.

Import ListNotations.
Import C.Notations.
Require Import String.

(* Definition level (line:string) : nat := (fix count (str:string) : nat := *)
(*                                         match str with *)
(*                                           | EmptyString   => O *)
(*                                           | String "#" ss => S (count ss) *)
(*                                           | String _   _  => O *)
(*                                         end) ((fix drop (line':string) : string := *)
(*                                                  match line' with *)
(*                                                    | String " " s => drop s   *)
(*                                                    | String c   s => String c s *)
(*                                                    | EmptyString  => EmptyString *)
(*                                                  end) line). *)

Fixpoint dec (n : nat) (line : LString.t) : LString.t :=
  match (n, LString.to_string line) with
    | (O, str)    => LString.s str
    | (S n', str) =>
      dec n' (LString.s ((fix dec' line :=
                             match line with
                               | String " " s              => String " " (dec' s)
                               | String "#" (String "#" s) => String "#" s
                               | s                         => s
                             end) str))
  end.

Fixpoint inc (n:nat) (line : LString.t) : LString.t :=
  match (n, LString.to_string line) with
    | (O, str)    => LString.s str
    | (S n', str) =>
      inc n' (LString.s ((fix inc' st :=
                            match st with
                              | String " " s => String " " (inc' s)
                              | String "#" s => String "#" (String "#" s)
                              | s            => s
                            end) str))
  end.

Import Ascii.
Definition new_line : Ascii.ascii := "010".

Definition map_line f (code : LString.t) : LString.t :=
  (LString.join (LString.s (String new_line ""))) (map f (LString.split code new_line)).

Definition is_minus (num : LString.t) : bool :=
  match LString.to_string num with
    | String "-" _ => true
    | _            => false
  end.

Definition lstr2nat (num : LString.t) : option nat :=
  let abs_num := match LString.to_string num with
                  | String "-" n => LString.s n
                  | n            => LString.s n
                end in
  match (LString.to_N 10 abs_num) with
    | Some n => Some (BinNat.N.to_nat n)
    | None   => None
  end.

Definition shift (argv : list LString.t) : C.t System.effect unit :=
  match argv with
  | [_; num; file_name] =>
    let! content := System.read_file file_name in
    match content with
    | None         => System.log (LString.s "Cannot read the file.")
    | Some content =>
      let shifter := if is_minus num then dec else inc in
      match lstr2nat num with
        | Some n => System.log (map_line (shifter n) content)
        | None   => System.log (LString.s "Wrong number spec.")
      end
    end
  | _                   => System.log (LString.s "Expected two parameter.")
  end.

Definition main := Extraction.launch shift.
Extraction "./extraction/main" main.

(* (** Ask for the user name and answer hello. *) *)
(* Definition your_name (argv : list LString.t) : C.t System.effect unit := *)
(*   do! System.log (LString.s "What is your name?") in *)
(*   let! name := System.read_line in *)
(*   match name with *)
(*   | None => ret tt *)
(*   | Some name => System.log (LString.s "Hello " ++ name ++ LString.s "!") *)
(*   end. *)

(* Definition run_your_name_ok (argv : list LString.t) (name : LString.t) *)
(* : Run.t (your_name argv) tt. *)
(*   Show Proof. *)
(*   (* 1 subgoal, subgoal 1 (ID 47) *) *)

(* (*   argv : list LString.t *) *)
(* (*   name : LString.t *) *)
(* (*   ============================ *) *)
(* (*   Run.t (your_name argv) tt *) *)

(* (* (dependent evars:) *) *)

(*   eapply Run.Let. *)


(******************************************************************************)
(* Solutions of exercises : Type inference by canonical structures            *)
(******************************************************************************)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import choice fintype tuple finset.

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

(******************************************************************************)
(* Exercise 6.1.1                                                             *)
(******************************************************************************)

Lemma tuto_unit_enumP : Finite.axiom [:: tt]. Proof. by case. Qed.

Definition tuto_unit_finMixin := FinMixin tuto_unit_enumP.
Canonical Structure unit_finType := Eval hnf in FinType unit unit_finMixin.

(******************************************************************************)
(* Exercise 6.1.2                                                             *)
(******************************************************************************)

(* Here we use the multirule rewrite facility: the first rule in the *)
(*list which matches the goal is used. Note that this facility *)
(*complies with the ! and ? multiplicators. *)
Lemma tuto_option_enumP : forall T : finType, Finite.axiom (option_enum T).
Proof. by move=> T; case=> [x|]; rewrite /= count_map (count_pred0, enumP). Qed.

(******************************************************************************)
(* Exercise 6.1.3                                                             *)
(******************************************************************************)

Definition tuto_sum_enum (T1 T2 : finType) : seq (T1 + T2) :=
  map (@inl _ _) (Finite.enum T1) ++ map (@inr _ _) (Finite.enum T2).

(* We describe this script as a trace of the search for the proof.
   Note that the view mechanism used in apply/hasP complies with *)
(*negation. The first subgoal is trivial because of the equality
   between applied constructors inl and inr. (discriminate). For the
   two last subgoals, remember the [] casing intropattern perfroms an
   injection on equalities *)
Lemma tuto_sum_enum_uniq : forall T1 T2, uniq (sum_enum T1 T2).
Proof.
move=> T1 T2.
Search _ cat uniq.
rewrite cat_uniq.
Search _ uniq map.
rewrite !map_inj_uniq.
 Search _ uniq Finite.enum.
 Search _ Finite.enum.
 + rewrite -!enumT.
 Search _ (enum _) uniq.
 rewrite !enum_uniq /= andbT.
 apply/hasP => [[u]].
 case/mapP=> x hx -> /=.
 case/mapP.
 done.
 + by move=> x y [].
 + by move=> x y [].
Qed.

(* here is the clean script resulting from the proevious one *)

Lemma tuto_sum_enum_uniq_clean : forall T1 T2, uniq (sum_enum T1 T2).
Proof.
move=> T1 T2.
rewrite cat_uniq -!enumT !(enum_uniq, map_inj_uniq); try by move=> ? ? [].
by rewrite andbT; apply/hasP=> [[u]]; case/mapP=> x _ ->; case/mapP.
Qed.

(******************************************************************************)
(* Exercise 6.1.4                                                             *)
(******************************************************************************)

Check UniqFinMixin.

Definition tuto_prod_enum (T1 T2 : finType) : seq (T1 * T2) :=
  foldr (fun x1 => cat (map (pair x1) (enum T2))) [::] (enum T1).

Lemma prod_enum_uniq : forall T1 T2, uniq (tuto_prod_enum T1 T2).
Proof.
move=> T1 T2; rewrite /tuto_prod_enum; move: (enum_uniq T1) (enum_uniq T2).
elim: (enum T1) (enum T2)=> [|x1 l1 ihl1] l2 //=; case/andP=> hx1 uniq_l1 uniq_l2.
rewrite cat_uniq ihl1 // andbT map_inj_uniq; last by move=> x y [].
rewrite uniq_l2 /=; apply/hasP=> [[u]] /= h1; case/mapP=> y l2y e.
move: h1; rewrite e; elim: l1 hx1 {uniq_l1 ihl1} => [|x3 l3 ihl3 ] //=.
rewrite in_cons negb_or; case/andP=> h1 h2.
rewrite mem_cat; case/orP; last by apply: ihl3.
by case/mapP=> y' _ []; move/eqP; move/negPf: h1 => ->.
Qed.

(******************************************************************************)
(* Exercise 6.1.5                                                             *)
(******************************************************************************)

Section OpsTheory.

Variable T : finType.

Implicit Types A B C P Q : pred T.
Implicit Types x y : T.
Implicit Type s : seq T.

Lemma card0 : #|@pred0 T| = 0.
Proof. by rewrite cardE enum0. Qed.

Lemma cardT : #|T| = size (enum T).
Proof. by rewrite cardE. Qed.

Lemma card1 : forall x, #|pred1 x| = 1.
Proof. by move=> x; rewrite cardE enum1. Qed.

Lemma tuto_pred0P : forall P, reflect (P =1 pred0) (pred0b P).
Proof. move=> p; apply: (iffP eqP); [exact: card0_eq | exact: eq_card0]. Qed.

(******************************************************************************)
(* Exercise 6.1.6                                                             *)
(******************************************************************************)

Lemma tuto_cardUI : forall A B, #|[predU A & B]| + #|[predI A & B]| = #|A| + #|B|.
Proof. by move=> A B; rewrite !cardE /= !size_filter count_predUI. Qed.

Lemma tuto_eq_card : forall A B, A =i B -> #|A| = #|B|.
Proof. by move=> A B eqAB; rewrite !cardE (eq_enum eqAB). Qed.

(******************************************************************************)
(* Exercise 6.1.7                                                             *)
(******************************************************************************)

Lemma tuto_disjoint0 : forall A, [disjoint pred0 & A].
Proof. move=> A; exact/pred0P. Qed.

(* The congr tactic applies a congruence reasoning of the form *)
(* \overline{x} = \overline{y} -> f \overline{x} = f \overline{y}, *)
(* where f can be an n-ary function. It generates as many subgoals as *)
(* non-trivial pairwise equality between the arguments of f *)
Lemma tuto_disjoint_sym : forall A B, [disjoint A & B] = [disjoint B & A].
Proof. by move=> A B; congr eqn; apply: eq_card => x; apply: andbC. Qed.

(* This is a difficult proof...And we need to investigate how disjoint is *)
(* defined. We see that its is defined using pred0b. *)
Search _ disjoint.
Print disjoint.

(* We first start a case analysis on the fact that [predI A & C] is empty *)
(* or not. *)

(* Then, one of the main trick is to avoid using congruence with pred0b, but *)
(* with == 0. Indeed, using congruence with pred0b would amount to prove *)
(* that some characteristic functions are (Leibniz) equal when they are *)
(* only extentionaly equal... *)
(* In the first subgoal, we use the ssreflect syntax to replace a subterm by a *)
(*convertible one: rewrite -[t1]/t2, where t1 is the term (or the *)
(*pattern) present in the goal and t2 the convertible counterpart. *)
(* We also use a declarative step suff, together with the -> *)
(* intropattern, which rewrites the lemms instead of introducing it *)
(* Finally, we use the move/(_ x) tactic, which specializes a *)
(* universally quantified assumption to a particular value *)
(* In the second subgoal, we use the negative counterpart of pred0P, *)
(* namely pred0Pn. Again there is no specific lemma on [predU _ & _] *)
(* and [predI _ & _], since there are in fact only boolean disjunctions *)
(* and conjunctions. Some rewrite steps might make the collective \in *)
(*momentarily disappear, replaced by the generic mem applicative *)
(*membership predicate. In that case, a simplification \= should put *)
(*back everything in order.*)

Lemma tuto_disjointU : forall A B C,
  [disjoint predU A B & C] = [disjoint A & C] && [disjoint B & C].
Proof.
move=> A B C.
case dAC: ([disjoint A & C])=> /=.
  rewrite /disjoint /pred0b; congr (_ == 0); apply: eq_card=> x.
  rewrite -[x \in [predI _ & _]]/(((x \in A) || (x \in B)) && (x \in C)) andb_orl.
  suff -> :  (x \in A) && (x \in C) = false by done.
  by move/pred0P: dAC; move/(_ x).
apply/pred0P=> nABC; case/pred0Pn: dAC=> x; case/andP=> /= Ax Cx.
move: (nABC x)=> /=.
by rewrite Cx /= -[x \in [predU A & B]]/((x \in A) || (x \in B)) Ax.
Qed.

(******************************************************************************)
(* Exercise 6.1.8                                                             *)
(******************************************************************************)

(* It can be usefull to browse the ssrbool library and/or to use the *)
(*Search command to find the most convenient reflexion lemmas, like *)
(*negbFE in this case *)
Lemma tuto_subsetP : forall A B,
  reflect {subset A <= B} (A \subset B).
Proof.
rewrite unlock.
move=> A B; apply: (iffP idP).
  by move/pred0P=> h x Ax; move: (h x)=> /=; rewrite Ax andbT; move/negbFE.
by move=> h; apply/pred0P=> x /=; case Ax : (x \in A); rewrite ?andbF // h.
Qed.

Lemma tuto_subsetPn : forall A B,
  reflect (exists2 x, x \in A & x \notin B) (~~ (A \subset B)).
Proof.
rewrite unlock.
move=> A B; apply: (iffP idP).
  by move/pred0Pn=> [x] /=; case/andP=> nAx Bx; exists x.
by case=> x Ax nBx; apply/pred0Pn; exists x; rewrite /= nBx.
Qed.

Lemma tuto_subset_eqP : forall A B,
  reflect (A =i B) ((A \subset B) && (B \subset A)).
Proof.
move=> A B; apply: (iffP andP) => [[sAB sBA] x| eqAB].
  by apply/idP/idP; apply: subsetP.
by rewrite !eq_subxx.
Qed.

(* In this proof, the tactic case/idP: (ltnn #|A|) on a False goal *)
(* proves false from (ltnn #|A|) := #|A| < #|A| = false, and generates *)
(*a new subgoal to prove that the current context implies  #|A| < #|A| *)
Lemma tuto_subset_cardP : forall A B,
  #|A| = #|B| -> reflect (A =i B) (A \subset B).
Proof.
move=> A B eqcAB; case: (@subsetP _ A B) (@subset_eqP _ A B) => //= sAB.
case: (@subsetP _ B A) => [//|[]] x Bx; apply/idPn => Ax.
case/idP: (ltnn #|A|); rewrite {2}eqcAB (cardD1 x B) Bx /=.
apply: subset_leq_card; apply/subsetP=> y Ay; rewrite inE /= andbC.
by rewrite sAB //; apply/eqP => eqyx; rewrite -eqyx Ay in Ax.
Qed.

End OpsTheory.

(******************************************************************************)
(* Exercise 6.1.9                                                             *)
(******************************************************************************)

Section Quantifiers.

Variable T : finType.
Variable P : pred T.

Lemma tuto_existsP : reflect (exists x, P x) [exists x, P x].
Proof. by apply: (iffP pred0Pn); case=> x; exists x. Qed.

Lemma tuto_forallP : reflect (forall x, P x) [forall x, P x].
Proof.
by apply: (iffP pred0P) => P_ x /=; rewrite ?P_ ?(negbFE (P_ x)).
Qed.

Lemma tuto_negb_forall :  ~~ [forall x, P x] = [exists x, ~~ P x].
Proof.  by []. Qed.

Lemma tuto_negb_exists : ~~ [exists x, P x] = [forall x, ~~ P x].
Proof.
rewrite negbK; congr (_ == 0); apply: eq_card => x.
by rewrite !inE /= negbK.
Qed.

End Quantifiers.
(******************************************************************************)
(* Exercise 6.1.10                                                            *)
(******************************************************************************)

Section Extremas.

Variable T : finType.
Variable P : pred T.
Variable F : T -> nat.

(* P is non empty *)
Variable i0 : T.
Hypothesis Pi0 : P i0.

(* The small scale reflection methodology leads to defining boolean *)
(*predicates as often as possible *)

(* We hence first define a boolean predicate characterizing an *)
(*extremum of F for the arbirary boolean relation ord *)

(* We use here the ssreflect notation to define predicates :
[pred i | p i] defines the predicate (i => p i) *)

(* We also use the boolean implication ==> *)
Definition is_extremum ord :=
  [pred i | P i && [forall x, P x ==> ord (F i) (F x)]].

(* Now let's characterize the notion of extremum in a logical (Prop) *)
(*way *)
Inductive extremum_spec (ord : rel nat) : T -> Prop :=
  ExtremumSpec i of P i & (forall j, P j -> ord (F i) (F j))
  : extremum_spec ord i.

(* Being minimimum for F is being extremum for leq *)
Definition is_min := is_extremum leq.

(* Being maxmimum for F is being extremum for geq *)
Definition is_max := is_extremum geq.

(* Now the pick function extracts a witness for a given predicates, *)
(*under the form of an option type. The odflt operator lifts an *)
(*element of the option type (option T) back to T by assigning a *)
(*default value to None. Here the default value is i0, the *)
(*nonemptiness witness *)
Definition Fmin := odflt i0 [pick x | is_min x].

Definition Fmax := odflt i0 [pick x | is_max x].

(* Let us prove that Fmin is an extremum for leq *)
(* The specification of the pick operation is pickP *)
(* The specification of the ex_minn operation is ex_minnP. Applying it *)
(*to a proof that a nat predicates is non empty generates the value *)
(*and its minimality property *)
Lemma Fmin_correct : extremum_spec leq Fmin.
rewrite /Fmin; case: pickP => [i | no_i] /=.
  by case/andP=> Pi; move/forallP=> min_i; split=> // j; exact/implyP.
pose Fvals i := [exists x, P x && (F x == i)].
have exFval : exists n, Fvals n.
  by exists (F i0); rewrite /Fvals; apply/existsP; exists i0; rewrite Pi0 eqxx.
case/ex_minnP: exFval=> m; case/existsP=> j; case/andP=> Pj e m_is_min.
case/idP: (no_i j); rewrite /= Pj; apply/forallP=> x; apply/implyP=> Px.
by rewrite (eqP e); apply: m_is_min; apply/existsP; exists x; rewrite eqxx Px.
Qed.

(* here we need to show that F is bounded on T. In fact, the explicit *)
(* value of the maximum of F on the whole finType T can be computed by *)
(*iterating the binary  maximum operator maxn on the enumeration of *)
(*the elements of T. We show that it is a correct bound by induction *)
(*on the list enumerating the lements of T *)

Lemma Fmax_correct : extremum_spec geq Fmax.
Proof.
rewrite /Fmax; case: pickP => [i | no_i].
  by case/andP=> Pi; move/forallP=> max_i; split=> // j; exact/implyP.
pose Fvals i := [exists x, P x && (F x == i)].
have exFval : exists n, Fvals n.
  by exists (F i0); rewrite /Fvals; apply/existsP; exists i0; rewrite Pi0 eqxx.
have: forall n, Fvals n -> n <= foldr maxn 0 (map F (enum P)).
  move=> n; case/existsP=> i; rewrite -[P i]mem_enum andbC; case/andP.
  move/eqP <-; elim: (enum P) => //= j e IHe.
  rewrite inE => /orP[/eqP->|/IHe /leq_trans->//]; first by rewrite leq_maxl.
  exact: leq_maxr.
case/ex_maxnP=> // n ex_i max_i; case/pred0P: ex_i => i.
apply/andP=> [[Pi def_n]]; case/idP: (no_i i); rewrite /= Pi.
apply/forallP=> j; apply/implyP=> Pj; rewrite (eqP def_n) max_i //;apply/existsP.
by exists j; rewrite eqxx Pj.
Qed.

End Extremas.
(******************************************************************************)
(* Exercise 6.1.11 to 6.1.21                                                  *)
(******************************************************************************)

(* The solution is the begining of the path.v file. Copy and play... *)

(******************************************************************************)
(* Exercise 6.2.1                                                             *)
(******************************************************************************)

Section Def.

Variable n : nat.
Variable T : Type.
(* The coercion is defined on the fly by the :> mark *)
Structure tuto_tuple_of  : Type :=
  TutoTuple {tuto_tval :> seq T; _ : size tuto_tval == n}.

Canonical Structure tuple_subType :=
  Eval hnf in [subType for tuto_tval].

End Def.

Canonical Structure nil_tuto_tuple (T : Type) :=
   TutoTuple (erefl _ : @size T [::] == 0).

Canonical Structure cons_tuto_tuple n T x (t : tuto_tuple_of n T) :=
   TutoTuple (valP t : size (x :: t) == n.+1).

Lemma tuto_cat_tupleP : forall T n1 n2 (t1 : n1.-tuple T) (t2 : n2.-tuple T),
  size (t1 ++ t2) == n1 + n2.
Proof. by move=> T n1 n2 t1 t2; rewrite size_cat !size_tuple. Qed.
Canonical Structure cat_tuple T n1 n2 t1 t2 := Tuple (@cat_tupleP T n1 n2 t1 t2).

Lemma drop_tupleP : forall T n m (t : n.-tuple T), size (drop m t) == n - m.
Proof. by move=> T n m t; rewrite size_drop size_tuple. Qed.

Canonical Structure drop_tuple T n m t := Tuple (@drop_tupleP T n m t).

Lemma take_tupleP : forall T n m (t : n.-tuple T), size (take m t) == minn m n.
Proof. by move=> T n m t; rewrite size_take size_tuple eqxx. Qed.

Canonical Structure take_tuple T n m t := Tuple (@take_tupleP T n m t).

Lemma rot_tupleP : forall T n m (t : n.-tuple T), size (rot m t) == n.
Proof. by move=> T n m t; rewrite size_rot size_tuple. Qed.

Canonical Structure rot_tuple T n m t := Tuple (@rot_tupleP T n m t).

(******************************************************************************)
(* Exercise 6.2.1                                                             *)
(******************************************************************************)

Section TuplesExercises.

(* Note that this time we need a finType, so that cardinality is well *)
(*defined *)
Variables (T : finType)(n : nat).

Lemma tuto_size_tuple : forall (t : n.-tuple T), size t = n.
Proof. move=> f; exact: (eqP (valP f)). Qed.

Lemma leq_card_tuple : forall (t : n.-tuple T), #|t| <= n.
Proof. by move=> t; move: (card_size t); rewrite size_tuple. Qed.

Lemma uniq_card_tuple : forall (t : n.-tuple T), uniq t -> #|t| = n.
Proof. by move=> t; move/card_uniqP; rewrite size_tuple. Qed.

Search _"'I_ _".
Print ordinal.

(* The subtype is defined by:

Section OrdinalSub.

Variable n : nat.

Inductive ordinal : predArgType := Ordinal m of m < n.

Canonical Structure ordinal_subType :=
  [subType for nat_of_ord].

End OrdinalSub.
*)

Lemma tuto_tnth_nth : forall (x : T) (t : n.-tuple T) i, tnth t i = nth x t i.
Proof. by move=> x t i; apply: set_nth_default; rewrite size_tuple. Qed.

(******************************************************************************)
(* Exercise 6.2.3                                                             *)
(******************************************************************************)

(* A first possibility uses the constructor of the ordinal inductive *)
(* type *)

Definition two := Ordinal (ltnSn 2).
Check two.
Eval compute in (val two).

(* Orelse we can cast the definition with the expected type and use *)
(*the generic subType constructor Sub *)
Definition two' : [subType of 'I_3] := Sub 2 (ltnSn 3).
Check (two' : 'I_3).

(* But in fact we only need to claim that the boolean test will *)
(*evaluate to true, and let the system check that for us *)
Definition two'' : [subType of 'I_3] := Sub 2 (refl_equal true).
Check two''.
Eval compute in (val two'').

Inductive odds : Set := Odds x of (odd x).

(* As opposed to the tuple case, this time the function from odds to *)
(*the type it should be a subtype of has to be defined manually*)
Definition nat_of_odds i := let: Odds m _ := i in m.

(* And now the subType definition, which should declared as canonical *)
Canonical Structure odds_subType :=
  Eval hnf in [subType for nat_of_odds by odds_rect].

(* Check that this require a canonical structure by replacing above
Canonical Structure odds_subType := by Definition .... := *)
Definition three : odds := Sub 3 (refl_equal true).

(******************************************************************************)
(* Exercise 6.2.4                                                             *)
(******************************************************************************)

(* WARNING : to be effective when the library where they are defined *)
(*is loaded, canonical structures should be defined (or re-defined) *)
(*outside sections... *)
Definition odds_eqMixin := Eval hnf in [eqMixin of odds by <:].

Canonical Structure odds_eqType := Eval hnf in EqType odds odds_eqMixin.

Definition tuto_tuple_eqMixin := Eval hnf in [eqMixin of n.-tuple T by <:].

Canonical Structure tuto_tuple_eqType :=
  Eval hnf in EqType (n.-tuple T) tuto_tuple_eqMixin.

Lemma tuto_map_tnth_enum : forall (t : n.-tuple T),
   map (tnth t) (enum 'I_n) = t.
Proof.
move=> t; case def_t: {-}(val t) => [|x0 t'].
  by rewrite [enum _]size0nil // -cardE card_ord -(size_tuple t) def_t.
apply: (@eq_from_nth _ x0) => [|i]; rewrite size_map.
  by rewrite -cardE size_tuple card_ord.
move=> lt_i_e; have lt_i_n: i < n by rewrite -cardE card_ord in lt_i_e.
by rewrite (nth_map (Ordinal lt_i_n)) // (tnth_nth x0) nth_enum_ord.
Qed.

Lemma tuto_eq_from_tnth : forall (t1 t2 : n.-tuple T),
  tnth t1 =1 tnth t2 -> t1 = t2.
Proof.
move=> *; apply: val_inj; rewrite /= -2!map_tnth_enum; exact: eq_map.
Qed.

End TuplesExercises.

(******************************************************************************)
(* Exercise 6.3.1                                                             *)
(******************************************************************************)

Section setOpsExos.

Variable T : finType.

Implicit Types a x : T.
Implicit Types A B C D : {set T}.

Lemma tuto_eqEsubset : forall A B,
   (A == B) = (A \subset B) && (B \subset A).
Proof. by move=> A B; apply/eqP/subset_eqP; move/setP. Qed.

Lemma tuto_set1P : forall x a, reflect (x = a) (x \in [set a]).
Proof. move=> x a; rewrite inE; exact: eqP. Qed.

Lemma tuto_setD1P : forall x A b,
  reflect (x != b /\ x \in A) (x \in A :\ b).
Proof. move=> x A b; rewrite !inE; exact: andP. Qed.

Lemma tuto_setIA : forall A B C, A :&: (B :&: C) = A :&: B :&: C.
Proof. by move=> A B C; apply/setP=> x; rewrite !inE andbA. Qed.

Lemma tuto_setUIl : forall A B C,
   (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
Proof. by move=> A B C; apply/setP => x; rewrite !inE orb_andl. Qed.

Lemma tuto_setCU : forall A B, ~: (A :|: B) = ~: A :&: ~: B.
Proof. by move=> A B; apply/setP => x; rewrite !inE -negb_or. Qed.

End setOpsExos.

(******************************************************************************)
(* Exercise 6.3.2                                                             *)
(******************************************************************************)

Section MinSet.

Variable T : finType.
Notation sT := {set T}.

Implicit Types A B C : sT.
Implicit Type P : pred sT.

Definition tuto_minset P A :=
  [forall B : sT, (B \subset A) ==> ((B == A) == P B)].

Lemma tuto_minset_eq : forall P1 P2 A,
  P1 =1 P2 -> minset P1 A = minset P2 A.
Proof. by move=> P1 P2 A eP12; apply: eq_forallb => B; rewrite eP12. Qed.

Lemma tuto_minsetP : forall P A,
reflect ((P A) /\ (forall B, P B -> B \subset A -> B = A))
       (minset P A).
Proof.
move=> P A; apply: (iffP forallP) => [minA | [PA minA] B].
  split; first by have:= minA A; rewrite subxx eqxx /=; move/eqP.
  by move=> B PB sBA; have:= minA B; rewrite PB sBA /=; do 2!move/eqP.
apply/implyP=> sBA; apply/eqP; apply/eqP/idP=> [-> //|]; move/minA; exact.
Qed.

Lemma tuto_minsetp : forall P A, minset P A -> P A.
Proof.  by move=> P A; case/minsetP. Qed.

Lemma tuto_minsetinf : forall P A B,
  minset P A -> P B -> B \subset A -> B = A.
Proof. by move=> P A B; case/minsetP=> _; exact. Qed.

Lemma tuto_ex_minset : forall P, (exists A, P A) -> {A | minset P A}.
Proof.
move=> P exP; pose pS n := [pred B | P B && (#|B| == n)].
pose p n := ~~ pred0b (pS n); have{exP}: exists n, p n.
  by case: exP => A PA; exists #|A|; apply/existsP; exists A; rewrite PA /=.
case/ex_minnP=> n; move/pred0P; case: (pickP (pS n)) => // A.
case/andP=> PA; move/eqP=> <- {n} _ minA; exists A => //.
apply/minsetP; split=> // B PB sBA; apply/eqP; rewrite eqEcard sBA.
by apply: minA; apply/pred0Pn; exists B; rewrite /= PB /=.
Qed.

Lemma tuto_minset_exists : forall P C,
   P C -> {A | minset P A & A \subset C}.
Proof.
move=> P C PC; have{PC}: exists A, P A && (A \subset C).
  by exists C; rewrite PC /=.
case/ex_minset=> A; case/minsetP; case/andP=> PA sAC minA; exists A => //.
apply/minsetP; split=> // B PB sBA; apply: minA => //.
by rewrite PB (subset_trans sBA).
Qed.

End MinSet.


(* Name forms a nominal set *)
From Nominal Require Import Name Nominal Fresh.

#[export] Instance name_action: PermAction Name := perm_swap.
#[export] Instance name_equiv: Equiv Name := eq.
#[export] Instance name_support: Support Name := (singleton (A := Name) (B := NameSet)).

#[export] Instance name_perm: PermT Name.
Proof.
    split; unfold equiv,name_equiv,action,name_action in *; repeat intro.
    - typeclasses eauto.
    - subst; rewrite H; auto.
    - auto.
    - symmetry; apply perm_swap_app.
Qed.

#[export] Instance name_nominal: Nominal Name.
Proof.
    split; intros;
        [apply name_perm |
         apply swap_neither1; apply (not_elem_of_singleton (C := NameSet))];
    auto.
Qed.

(* Freshness properties for name *)
Lemma name_fresh_neq1 (a b: Name): a # b → a ≠ b.
Proof.
    intros [c [? cF]]; destruct (decide (a = c)); subst.
    - apply (not_elem_of_singleton (C := NameSet)); auto.
    - apply swap_neither2 in cF as [[] | []]; subst; auto.
Qed.

Lemma name_fresh_neq2 (a b: Name): a ≠ b → a # b.
Proof.
    intros; constructor 1 with a; split;
        [unfold support; apply not_elem_of_singleton | apply swap_neither1]; auto.
Qed.

Lemma name_neq_fresh_iff (a b: Name): a # b ↔ a ≠ b.
Proof. split; [apply name_fresh_neq1 | apply name_fresh_neq2]. Qed.

Lemma name_fresh_action p (a b: Name): b # a → b ∉ perm_dom p → b # (p • a).
Proof.
    intros HH ?; destruct (exist_fresh (support a ∪ support b ∪ perm_dom p ∪ support (p • a))) as [w ?];
    exists w; split; [set_solver |];
    rewrite gact_compat, <-perm_notin_dom_comm, <-gact_compat; [| set_solver | set_solver].
    apply some_any_iff in HH; cut (w ∉ support a); [intros HHH | set_solver];
    specialize (HH w HHH); rewrite HH; reflexivity.
Qed.

Lemma name_fresh_false (a: Name): not (a # a).
Proof.
    intros [? [H1 H2]]; unfold support, name_support in *; apply not_elem_of_singleton_1 in H1.
    rewrite perm_swap_left in H2; congruence.
Qed.


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedRefine.

Lemma annotated_reducible_refine:
  forall Θ Γ t A b x p,
    ~(p ∈ fv_context Γ) ->
    ~(p ∈ fv b) ->
    ~(p ∈ fv t) ->
    ~(p ∈ fv A) ->
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv b) ->
    ~(x ∈ fv t) ->
    ~(x ∈ fv A) ->
    ~(x = p) ->
    ~(x ∈ Θ) ->
    ~(p ∈ Θ) ->
    wf t 0 ->
    wf b 1 ->
    is_annotated_term b ->
    subset (fv t) (support Γ) ->
    subset (fv b) (support Γ) ->
    [[ Θ; Γ ⊨ t : A ]] ->
    [[ Θ; (x,A) :: Γ ⊨ open 0 b (fvar x term_var) : T_bool ]] ->
    [[ Θ; (p, T_equiv (fvar x term_var) t) :: (x,A) :: Γ ⊨ open 0 b (fvar x term_var) ≡ ttrue ]] ->
    [[ Θ; Γ ⊨ t : T_refine A b ]].
Proof.
  unfold open_equivalent;
    repeat step.
  apply open_reducible_refine with x p;
    repeat step || t_instantiate_sat3 || erase_open;
    side_conditions.
Qed.


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

Require Import Wf_nat.
Require Import BinInt.
Require Import Zcompare.
Require Import Zorder.
Require Import Bool.
Local Open Scope Z_scope.

(**********************************************************************)
(** Iterators *)

(** [n]th iteration of the function [f] *)

Notation iter := @Z.iter (only parsing).

Lemma iter_nat_of_Z : forall n A f x, 0 <= n ->
  Z.iter n f x = iter_nat (Z.abs_nat n) A f x.
Proof.
intros n A f x; case n; auto.
intros p _; unfold Z.iter, Z.abs_nat; apply Pos2Nat.inj_iter.
intros p abs; case abs; trivial.
Qed.


Require Import CSet Le Arith.Compare_dec Plus Util.

Class NaturalRepresentation X `{OrderedType X} :=
  {
    asNat : X -> nat;
    ofNat : nat -> X;
    ofNat_asNat : forall x, ofNat (asNat x) === x;
    asNat_ofNat : forall n, asNat (ofNat n) === n;
    order_respecting : forall x y, x < y <-> _lt (ofNat x) (ofNat y);
    asNat_proper :> Proper (_eq ==> eq) asNat
  }.

Arguments asNat : simpl never.
Arguments ofNat : simpl never.

Arguments NaturalRepresentation X {H}.

Lemma order_respecting' X `{NaturalRepresentation X}
  :  forall x y, asNat x < asNat y <-> _lt x y.
Proof.
  intros.
  rewrite <- ofNat_asNat at 2.
  rewrite <- (ofNat_asNat y) at 2.
  eapply order_respecting.
Qed.

Lemma inj_lt x y
  : (x < y)%positive
    <-> Pos.to_nat x < Pos.to_nat y.
Proof.
  rewrite <- (Pos2Nat.id y) at 1.
  rewrite <- (Pos2Nat.id x) at 1.
  unfold Pos.lt.
  rewrite <- Nat2Pos.inj_compare; eauto.
  - rewrite Nat.compare_lt_iff. reflexivity.
  - exploit (Pos2Nat.is_pos x). simpl in *. omega.
  - exploit (Pos2Nat.is_pos y). simpl in *. omega.
Qed.

Lemma inj_le x y
  : (x <= y)%positive
    <-> Pos.to_nat x <= Pos.to_nat y.
Proof.
  rewrite <- (Pos2Nat.id y) at 1.
  rewrite <- (Pos2Nat.id x) at 1.
  unfold Pos.le.
  rewrite <- Nat2Pos.inj_compare; eauto.
  - rewrite Nat.compare_le_iff. reflexivity.
  - exploit (Pos2Nat.is_pos x). simpl in *. omega.
  - exploit (Pos2Nat.is_pos y). simpl in *. omega.
Qed.

Instance NaturalRepresentationNat : NaturalRepresentation nat :=
  {
    asNat := fun x => x;
    ofNat := fun x => x;
  }.
Proof.
  - reflexivity.
  - reflexivity.
  - simpl. intros. omega.
Defined.

Instance NaturalRepresentationPositive : NaturalRepresentation positive :=
  {
    asNat := fun x => pred (Pos.to_nat x);
    ofNat := Pos.of_succ_nat;
  }.
Proof.
  - intros. eapply SuccNat2Pos.inv.
    erewrite Nat.lt_succ_pred. reflexivity.
    eapply Pos2Nat.is_pos.
  - intros. rewrite SuccNat2Pos.id_succ. reflexivity.
  - intros. rewrite inj_lt.
    rewrite !SuccNat2Pos.id_succ. omega.
Defined.

Class NaturalRepresentationSucc V `{NaturalRepresentation V} :=
  {
    succ : V -> V;
    succ_asNat : forall x, asNat (succ x) = S (asNat x);
    succ_ofNat : forall n:nat, succ (ofNat n) === ofNat (S n);
    respect_lt :> Proper (_lt ==> _lt) succ;
    respect_eq :> Proper (_eq ==> _eq) succ
  }.

Class NaturalRepresentationMax V `{NaturalRepresentation V} :=
  {
    max : V -> V -> V;
    max_asNat : forall x y, max x y === ofNat (Init.Nat.max (asNat x) (asNat y));
    max_proper :> Proper (_eq ==> _eq ==> _eq) max
  }.

Arguments NaturalRepresentationMax V {H} {H0}.

Ltac norevert_NaturalRepresentation H :=
  match type of H with
  | @NaturalRepresentation _ _ => idtac
  | @NaturalRepresentationSucc _ _ _ => idtac
  | @NaturalRepresentation _ _ _ => idtac
  end.

Smpl Add norevert_NaturalRepresentation : norevert.

Smpl Create nr.

Smpl Add
     match goal with
     | [ LT : context [ @_lt ?V _ _ _ ], NR:NaturalRepresentation ?V |- _ ] =>
       setoid_rewrite <- (@order_respecting' V _ NR) in LT
     | [ NR:NaturalRepresentation ?V |-  context [ @_lt ?V _ _ _ ] ] =>
       setoid_rewrite <- (@order_respecting' V _ NR)
     | [ LT : context [ (_ < _)%positive ] |- _ ] =>
       setoid_rewrite inj_lt in LT
     | [ |- context [ (_ < _)%positive ] ] =>
       setoid_rewrite inj_lt
     end : nr.

Smpl Add
     match goal with
     | [ H: context [ @asNat ?V _ _ (@max ?V _ _ ?NRM _ _) ] |- _ ] =>
       setoid_rewrite (@max_asNat V _ _ NRM) in H
     | [ |- context [ @asNat ?V _ _ (@max ?V _ _ ?NRM _ _) ] ] =>
       setoid_rewrite (@max_asNat V _ _ NRM)
     | [ H: context [ Pos.to_nat (Pos.max _ _) ] |- _ ] =>
       setoid_rewrite (Pos2Nat.inj_max) in H
     | [ |- context [ Pos.to_nat (Pos.max _ _) ] ] =>
       setoid_rewrite (Pos2Nat.inj_max)
     end : nr.

Smpl Add
     match goal with
     | [ LT : context [ @asNat ?V _ _ (@succ ?V _ _ ?NRS _) ] |- _ ] =>
       setoid_rewrite (@succ_asNat V _ _ NRS) in LT
     | [ |- context [ @asNat ?V _ _ (@succ ?V _ _ ?NRS _) ] ] =>
       setoid_rewrite (@succ_asNat V _ _ NRS)
     | [ LT : context [  Pos.to_nat (Pos.succ _) ] |- _ ] =>
       rewrite Pos2Nat.inj_succ in LT
     | [ |- context [  Pos.to_nat (Pos.succ _) ] ] =>
       rewrite Pos2Nat.inj_succ
     end : nr.

Smpl Add
     match goal with
     | [ LT : context [ @asNat ?V _ ?NR (@ofNat ?V _ _ _) ] |- _ ] =>
       setoid_rewrite (@asNat_ofNat V _ NR) in LT
     | [ |- context [ @asNat ?V _ ?NR (@ofNat ?V _ _ _) ] ] =>
       setoid_rewrite (@asNat_ofNat V _ NR)
     end : nr.

Smpl Add
     match goal with
     | [ LT : context [ @ofNat ?V _ ?NR (@asNat ?V _ _ _) ] |- _ ] =>
       setoid_rewrite (@ofNat_asNat V _ NR) in LT
     | [ |- context [ @ofNat ?V _ ?NR (@asNat ?V _ _ _) ] ] =>
       setoid_rewrite (@ofNat_asNat V _ NR)
     end : nr.

Ltac nr := repeat smpl nr.

Instance NaturalRepresentationSuccNat : NaturalRepresentationSucc nat :=
  {
    succ := S
  }.
Proof.
  - reflexivity.
  - reflexivity.
  - unfold Proper, respectful; cbn. intros; omega.
Defined.

Instance NaturalRepresentationMaxNat : NaturalRepresentationMax nat :=
  {
    max := Max.max
  }.
Proof.
  - reflexivity.
Defined.

Instance NaturalRepresentationSuccPositive : NaturalRepresentationSucc positive :=
  {
    succ := Pos.succ
  }.
Proof.
  - unfold asNat; simpl.
    intros. rewrite Pos2Nat.inj_succ. simpl.
    erewrite <- S_pred. reflexivity.
    eapply Pos2Nat.is_pos.
  - unfold ofNat. unfold NaturalRepresentationPositive.
    intros. rewrite SuccNat2Pos.inj_succ. reflexivity.
  - unfold Proper, respectful; cbn.
    intros. rewrite <- Pos.succ_lt_mono. eauto.
Defined.

Lemma Posmax_asNat x y
  : Pos.max x y === ofNat (Init.Nat.max (asNat x) (asNat y)).
Proof.
  pose proof (Pos.compare_spec x y).
  unfold Pos.max. inv H.
  - rewrite max_r; try omega. rewrite ofNat_asNat; eauto.
  - rewrite max_r; try omega. rewrite ofNat_asNat; eauto.
    edestruct (order_respecting' _ x y); eauto. simpl in *.
    exploit H3. hnf. eauto. omega.
  - rewrite Max.max_comm.
    rewrite max_r; try omega. rewrite ofNat_asNat; eauto.
    edestruct (order_respecting' _ y x); eauto. simpl in *.
    exploit H3. eauto. omega.
Defined.

Instance NaturalRepresentationMaxPositive : NaturalRepresentationMax positive :=
  {
    max := Pos.max
  }.
Proof.
  - intros. eapply Posmax_asNat.
Defined.

Lemma asNat_ofNat_swap N `{NaturalRepresentation N} k m
  : k = asNat m <-> ofNat k === m.
Proof.
  split; intros; subst.
  - rewrite ofNat_asNat. reflexivity.
  - rewrite <- H1. rewrite asNat_ofNat. reflexivity.
Qed.

Lemma asNat_inj N `{NaturalRepresentation N} m n
  : asNat m = asNat n -> m === n.
Proof.
  intros.
  decide (_lt m n); eauto.
  - nr. omega.
  - decide (_lt n m); eauto.
    + nr. omega.
    + eapply lt_trans_eq; eauto.
Qed.

Lemma asNat_iff N `{NaturalRepresentation N} m n
  : asNat m = asNat n <-> m === n.
Proof.
  split; eauto using asNat_inj, asNat_proper.
Qed.

Smpl Add match goal with
         | [ EQ : context [ @equiv ?V (@_eq ?V ?H) _ _ _ ],
                  NR : @NaturalRepresentation ?V ?H |- _ ] =>
           rewrite <- (@asNat_iff V H NR) in EQ
         | [ NR : @NaturalRepresentation ?V ?H |- context [ @equiv ?V (@_eq ?V ?H) _ _ _ ] ] =>
           rewrite <- (@asNat_iff V H NR)
         end : nr.

Lemma asNat_iter_plus N `{NaturalRepresentationSucc N} n i
  : asNat (iter n i succ) = n + asNat i.
Proof.
  general induction n; simpl; eauto.
  rewrite IHn. nr. omega.
Qed.

Smpl Add
     match goal with
     | [ H : context [iter _ _ (@succ ?V ?H ?NR ?NRS)] |- _ ] =>
       setoid_rewrite (@asNat_iter_plus V H NR NRS) in H
     | [ |- context [iter _ _ (@succ ?V ?H ?NR ?NRS)] ] =>
       setoid_rewrite (@asNat_iter_plus V H NR NRS)
     end : nr.

Lemma succ_inj V `{NaturalRepresentationSucc V} (x y:V)
  : succ x === succ y
    -> x === y.
Proof.
  intros.
  nr. omega.
Qed.

Smpl Add
     match goal with
     | [ |- context [ Pos.to_nat (Pos.of_succ_nat _) ] ] =>
       setoid_rewrite SuccNat2Pos.id_succ
     end : nr.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_lea_add2_example : code :=
  Plea (EDI) (Addrmode (Some EDX) (Some (EDI, one)) (inl zero)) :: nil.

Section LEA_ADD2.

  Variable concrete : code.

  Variable r1 : ireg.
  Variable r2 : ireg.

  Hypothesis neq : r1 <> r2.

  Definition peep_lea_add2_defs : rewrite_defs :=
    {|
      fnd :=
        Plea r2 (Addrmode (Some r1) (Some (r2, one)) (inl zero))
             :: nil
      ; rpl :=
          Padd_rr r2 r1
                  :: nil
      ; lv_in := IR r1 :: IR r2 :: PC :: nil
      ; lv_out := IR r1 :: IR r2 :: PC :: nil
      ; clobbered := flags
    |}.

  Lemma peep_lea_add2_selr :
    StepEquiv.step_through_equiv_live (fnd peep_lea_add2_defs) (rpl peep_lea_add2_defs) (lv_in peep_lea_add2_defs) (lv_out peep_lea_add2_defs).
  Proof.
    prep_l.
    step_l.
    prep_r.
    step_r.
    finish_r.
    prep_eq.
    split.
    2: eq_mem_tac.
    intros.
    simpl_and_clear.

    (*r1*)
    break_or'.
    subst reg.
    preg_simpl.
    assumption.
    (*r2*)
    break_or'.
    subst reg.
    preg_simpl.
    rewrite Val.add_commut.
    eapply val_eq_add.
    rewrite Val.add_commut.
    simpl.
    replace zero with Int.zero by auto.
    break_match;
      try rewrite Int.add_zero;
      try rewrite Int.add_zero_l;
      simpl in H4;
      simpl;
      try congruence;
      try inv_false.
    assumption.
    (*PC*)
    break_or'.
    subst reg.
    preg_simpl.
    repeat find_rewrite_goal.
    simpl.
    reflexivity.
    inv_false.
    clear -Heqb0. exfalso.
    apply PtrEquiv.int_eq_false in Heqb0.
    unfold one in *.
    unfold Int.one in *.
    congruence.
  Qed.

  Definition peep_lea_add2_proofs : rewrite_proofs :=
    {|
      defs := peep_lea_add2_defs
      ; selr := peep_lea_add2_selr
    |}.

  Definition peep_lea_add2 :
    concrete = fnd peep_lea_add2_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_lea_add2_defs peep_lea_add2_proofs.
  Qed.

End LEA_ADD2.

Definition peep_lea_add2_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_lea_add2 p.
  unfold peep_lea_add2_defs in p.
  simpl in p.
  specialize (p c).
  set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_lea_add2_example.
  destruct a.
  destruct base; [ | exact None].
  destruct ofs; [ | exact None].
  destruct const; [ | exact None].
  destruct p0.
  specialize (p i i1).
  set_ireg_neq i i1.
  set_ireg_eq rd i1.
  specialize (p n).
  set_int_eq i2 one.
  set_int_eq i0 zero.
  exact (Some (p eq_refl)).
Defined.

Definition lea_add2 (c : code) : list StepEquiv.rewrite :=
  collect (map peep_lea_add2_rewrite (ParamSplit.matched_pat peep_lea_add2_example c)).


Require Import FP.CoreData.
Require Import FP.Classes.
Require Import FP.Data.Identity.

Import CoreDataNotation.
Import ClassesNotation.

Inductive susp_t (w:Type -> Type) (A:Type) : Type := SuspT
  { un_susp_t : unit -> w A }.
Arguments SuspT {w A} _.
Arguments un_susp_t {w A} _ _.

Section susp_t.
  Context {m:Type->Type}.

  Definition run_susp_t {A} : susp_t m A -> m A := apply_to tt '.' un_susp_t.
  Definition force_t {A} : susp_t m A -> m A := run_susp_t.
End susp_t.

Definition susp := susp_t identity.
Definition run_susp {A} : susp A -> A := run_identity '.' run_susp_t.
Definition force {A} : susp A -> A := run_susp.

Module SuspNotation.
  Notation "'delay_t' | e" := (SuspT (fun _ => e)) (at level 105).
  Notation "'delay' | e" := (SuspT (fun _ => Identity e)) (at level 105).
End SuspNotation.
Import SuspNotation.

Section Monad.
  Context {m} `{! Monad m }.

  Definition susp_t_mret {A} (a:A) : susp_t m A := delay_t | mret a.
  Definition susp_t_mbind {A B} (aM:susp_t m A) (f:A -> susp_t m B) : susp_t m B :=
    delay_t | a <- force_t aM ;; force_t $ f a.
  Global Instance susp_t_Monad : Monad (susp_t m) :=
    { mret := @susp_t_mret
    ; mbind := @susp_t_mbind
    }.
End Monad.

Section Comonad.
  Context {w} `{! Comonad w }.

  Definition susp_t_coret {A} : susp_t w A -> A := coret '.' run_susp_t.
  Definition susp_t_cobind {A B} (aMM:susp_t w A) (f:susp_t w A -> B) : susp_t w B :=
    delay_t | codo aM -< force_t aMM => f (delay_t | aM).
  Global Instance susp_t_Cobind : Comonad (susp_t w) :=
    { coret := @susp_t_coret
    ; cobind := @susp_t_cobind
    }.
End Comonad.