Require Import decidability.
Require Import Heyting_projective_plane_axioms.
Require Import Classical.
Require Import forth.
Require Import basic_facts_plane.

Module ProjectivePlane2HeytingProjectivePlane (M:ProjectivePlane) <: HeytingProjectivePlane
 with Definition Point := M.Point
 with Definition Line := M.Line
 with Definition Incid := M.Incid.

Definition Point := M.Point.
Definition Line := M.Line.
Definition Incid := M.Incid.

Module Export uniq := uniqueness_axioms M.

Definition Apart : Point -> Point -> Prop := fun A B => A <> B.

Notation "x # y" := (Apart x y) (at level 20).
Notation "x @ y" := (Incid x y) (at level 20).

Definition out (A : Point) (l : Line) : Prop := forall B, B @ l -> B # A.
Definition apart_l  (l m : Line) : Prop := exists A, A @ l /\ out A m.

Notation "x ## y" := (apart_l x y) (at level 20).

(** %\textbf{% Apartness axioms. %}% *)

Lemma S1 : forall A B, A # B -> B # A.
Proof.
intros.
unfold Apart in *.
auto.
Qed.

Lemma S2 : forall A B, ~ A # B <-> A=B.
Proof.
intros.
unfold Apart.
intuition.
apply NNPP.
tauto.
Qed.

Hint Extern 4 (?X1 = ?X2) => subst.

Lemma S3 : forall A B, A # B -> forall C, C # A \/ C # B.
Proof.
intros.
unfold Apart in *.
classical_left.
intuition.
Qed.

(** %\textbf{% Geometric axioms. %}% *)

Lemma P1 : forall A B,  A # B -> exists l, A @ l /\ B @ l.
Proof.
intros.
elim (M.a1_exist A B); intro l; intro H2.
exists l;auto.
Qed.

Lemma P2 : forall A B l m, A # B /\ A @ l /\ A @ m /\ B @ l /\ B @ m -> l=m.
Proof.
intros.
apply (a1_unique A B l m);intuition.
Qed.

Hint Unfold out.

Lemma P3 : forall l m, l ## m -> exists A, A @ l /\ A @ m.
Proof.
intros.
unfold apart_l in *.
elim H; intro A; clear H; intro H.
assert (l<>m).
  unfold not;intro;intuition.
  subst l.
  unfold out in *.
  apply H2 in H1.
  auto.
elim (M.a2_exist l m); intros x Hx.
exists x;auto.
Qed.

Lemma P4 : forall A B C l m, A # B /\ A @ l /\ B @ l /\
       out C l /\ A @ m /\ C @ m -> out B m.
Proof.
intros.
unfold out.
intros.
unfold not;intro.
subst B.
intuition.
unfold out in *.
assert (l=m).
eapply P2;eauto.
subst.
apply H3 in H6.
auto.
Qed.

Lemma P5i :exists A, exists B, A # B.
Proof.
assert (T:=M.a3).
destruct T as [A [B [C [D T]]]].
elim (M.a1_exist A B); intros l H.
assert (U:=T l);clear T.
decompose [and] U; clear U.
unfold dist4 in H0.
exists A; exists B;intuition.
Qed.

(** This axiom is our a3_1 so we can use our forth functor *)

Module M' := forth.forth M.

Lemma P5ii: forall l, exists A, exists B, exists C,
        A @ l /\ B @ l /\ C @  l /\ A # B /\ A # C /\ B # C.
Proof.
intro l.
assert (T:=M'.a3_1 l).
destruct T as [A [ B [ C [H1 H2]]]].
exists A.
exists B.
exists C.
unfold Apart, dist3 in *.
intuition.
Qed.

Module Export Facts := decidability.decidability M.

Lemma P5iii: forall l, exists A, out A l.
Proof.
intros.
elim (Facts.outsider l l); intros P H.
exists P.
unfold out.
intros.
unfold Apart.
intuition.
Qed.

End ProjectivePlane2HeytingProjectivePlane.


(* Lazy Rose Trees *)

Require Import List mathcomp.ssreflect.ssreflect.
Set Implicit Arguments.

Record Lazy (T : Type) := lazy { force : T }.

Inductive Rose (A : Type) : Type :=
  MkRose : A -> Lazy (list (Rose A)) -> Rose A.

Definition returnRose {A : Type} (x : A) := MkRose x (lazy nil).

Fixpoint joinRose {A : Type} (r : Rose (Rose A)) : Rose A :=
  match r with
    | MkRose (MkRose a ts) tts =>
      MkRose a (lazy ((List.map joinRose (force tts)) ++ (force ts)))
  end.

Definition repeatRose {A : Type} (n : nat) (r : Rose A) :=
  match r with
  | MkRose a ts => MkRose a (lazy (concat (repeat (force ts) n)))
  end.

Fixpoint fmapRose {A B : Type} (f : A -> B) (r : Rose A) : Rose B :=
  match r with
    | MkRose x rs => MkRose (f x) (lazy (List.map (fmapRose f) (force rs)))
  end.

Definition bindRose {A B : Type} (m : Rose A) (k : A -> Rose B) : Rose B :=
  joinRose (fmapRose k m).

(*
(* CH: these seem unused now *)
Lemma joinRoseFmapRose :
  forall {A B} (f: A -> B) (x : Rose A),
    fmapRose f x = joinRose (fmapRose (fun x0 : A => returnRose (f x0)) x).
Proof.
  fix 4.
  move=> A B f x.
  destruct x as [a l]. destruct l as [lst]. induction lst as [|x lst IHlst].
  - reflexivity.
  - inversion IHlst as [Heq]. simpl.
    rewrite Heq. repeat apply f_equal. apply f_equal2.
    apply joinRoseFmapRose. reflexivity.
Qed.

Lemma monadFunctorLaw :
  (forall A B (f : A -> B) a,
     fmapRose f a = bindRose a (fun x => returnRose (f x))).
Proof.
  move => A B f a.
  destruct a. destruct l as [lst]. induction lst as [|x lst Hlst].
  + reflexivity.
  + simpl in Hlst. rewrite /bindRose /= in Hlst.
    inversion Hlst as [Heq].
    simpl. rewrite Heq /bindRose /= app_nil_r.
    repeat apply f_equal. apply f_equal2. apply joinRoseFmapRose. reflexivity.
Qed.

(* CH: TODO: need a proper induction principle for rose trees *)
Lemma fmapRose_id : forall a (rose : Rose a) f,
  (forall x : a, f x = x) ->
  fmapRose f rose = rose.
Proof.
  fix 2. (* <-- nasty *)
  move => a [r [xs]] f H. induction xs as [|x xs]; simpl in *.
  - by rewrite H.
  - inversion IHxs. f_equal. by repeat apply H1. f_equal. f_equal.
    + by apply fmapRose_id.
    + by do 2 rewrite H2.
Qed.
*)


(** This file is based on the paper "Infinite sets that satisfy the principle
    of omniscience in any variety of constructive mathematics" by
    Martin Escardó. *)

Definition omniscient (X : Type) : Prop :=
  forall p : X -> bool,
    (exists x : X, p x = false) \/ forall x : X, p x = true.

(*
Inductive leb_bool : bool -> bool -> Prop :=
| leb_bool_refl : forall b : bool, leb_bool b b
| leb_bool_ft : leb_bool false true.
*)

Definition leb_bool (x y : bool) : Prop :=
  x = false \/ y = true.

Definition selection_function {X : Type} (e : (X -> bool) -> X) : Prop :=
  forall p : X -> bool, p (e p) = true -> forall x : X, p x = true.

Definition searchable (X : Type) : Prop :=
  exists e : (X -> bool) -> X, selection_function e.

(** Lemma 2.2 *)
Lemma searchable_omniscient :
  forall X : Type,
    searchable X -> omniscient X.
Proof.
  unfold searchable, selection_function, omniscient.
  intros X [e H] p.
  specialize (H p). case_eq (p (e p)); intros.
    right. apply H. assumption.
    left. exists (e p). assumption.
Qed.

(** Lemma 2.3 *)
Lemma lemma_2_3 :
  forall (X : Type) (e : (X -> bool) -> X) (p : X -> bool),
    selection_function e ->
      (exists x : X, p x = false) <-> p (e p) = false.
Proof.
  unfold selection_function.
  intros X e p H.
  split.
    intros [x H']. case_eq (p (e p)); intros.
      specialize (H _ H0 x). congruence.
      reflexivity.
    intro. exists (e p). assumption.
Qed.

Require Import Setoid.

(** Proposition 2.4 *)
Proposition prop_2_4 :
  forall (X Y : Type) (a : X -> Y -> bool),
    searchable Y ->
      (forall x : X, exists y : Y, a x y = false) ->
        exists f : X -> Y, forall x : X, a x (f x) = false.
Proof.
  unfold searchable, selection_function.
  intros X Y a [e He] H.
  exists (fun x : X => e (a x)). intro.
  rewrite <- (lemma_2_3 _ _ _ He). apply H.
Qed.

Fixpoint r (a : nat -> bool) (n : nat) : bool :=
match n with
| 0 => a 0
| S n' => andb (r a n') (a n)
end.

(** Conatural numbers using decreasing boolean sequences. *)

Require Import Nat.
Require Import Arith.

Definition seq_eq (a b : nat -> bool) : Prop :=
  forall i : nat, a i = b i.

Definition seq_neq (a b : nat -> bool) : Prop :=
  exists i : nat, a i <> b i.

Notation "a == b" := (seq_eq a b) (at level 50).
Notation "a # b" := (seq_neq a b) (at level 50).

Definition is_decr (a : nat -> bool) : Prop :=
  forall n : nat, leb_bool (a (S n)) (a n).

Record conat : Type :=
{
  seq :> nat -> bool;
  is_decr_seq : is_decr seq;
}.

Definition finite (n : nat) : conat.
Proof.
  exists (fun k : nat => if k <=? S n then true else false).
  do 2 red. cbn. intro.
  destruct (Nat.leb_spec0 n0 n).
    right. destruct (Nat.leb_spec0 n0 (S n)).
      reflexivity.
      contradict l. intro. apply n1. apply le_S. assumption.
    left. reflexivity.
Defined.

Definition omega : conat.
Proof.
  esplit with (fun n : nat => true).
  do 2 red. right. reflexivity.
Defined.

(** Proposition 3.1 *)

Require Import FunctionalExtensionality.

Lemma r_idempotent :
  forall a : nat -> bool,
    r (r a) = r a.
Proof.
  intro a. extensionality n.
  induction n as [| n']; cbn.
    reflexivity.
    rewrite IHn'. destruct (r a n'); cbn; reflexivity.
Qed.

Lemma r_is_decr :
  forall a : nat -> bool,
    is_decr (r a).
Proof.
  unfold is_decr, leb_bool.
  induction n as [| n']; cbn.
    destruct (a 0), (a 1); cbn; auto.
    destruct IHn'; cbn in *.
      rewrite H. cbn. auto.
      rewrite H. cbn. destruct (a (S n')); cbn; auto.
Qed.

Definition r_conat (a : nat -> bool) : conat :=
{|
  seq := r a;
  is_decr_seq := r_is_decr a;
|}.

Definition LPO : Prop :=
  forall a : nat -> bool,
    (exists n : nat, a n = false) \/
    (forall n : nat, a n = true).

Definition WLPO : Prop :=
  forall a : nat -> bool,
    (forall n : nat, a n = true) \/
    ~ (forall n : nat, a n = true).

Definition MP : Prop :=
  forall a : nat -> bool,
    ~ (forall n : nat, a n = true) -> exists n : nat, a n = false.

Lemma LPO_is_WLPO_and_MP :
  LPO <-> WLPO /\ MP.
Proof.
  unfold LPO, WLPO, MP. split.
    intro LPO. split.
      intro a. destruct (LPO a) as [[n H] | H].
        right. intro. specialize (H0 n). congruence.
        left. assumption.
      intros a H. destruct (LPO a) as [[n H'] | H'].
        exists n. assumption.
        contradiction.
    intros [WLPO MP] a. destruct (WLPO a).
      right. assumption.
      left. apply MP. assumption.
Qed.

Lemma LPO_equiv :
  LPO <-> forall a : conat, a # seq omega \/ a == omega.
Proof.
  unfold LPO.
  split.
    intros LPO a. destruct (LPO a) as [[n H] | H].
      left. red. cbn. exists n. intro. congruence.
      right. red. cbn. apply H.
    intros H a. destruct (H (r_conat a)).
      left. destruct H0 as [i H0]. cbn in H0.
        induction i as [| i']; cbn in H0.
          exists 0. destruct (a 0); congruence.
          case_eq (r a i'); intro.
            exists (S i'). case_eq (a (S i')); intro.
              rewrite H1 in H0. rewrite H2 in H0. cbn in H0. congruence.
              reflexivity.
            apply IHi'. intro. congruence.
      right. red in H0. cbn in H0.
        induction n as [| n'].
          specialize (H0 0). cbn in H0. assumption.
          specialize (H0 (S n')). cbn in H0. destruct (a (S n')).
            reflexivity.
            rewrite Bool.andb_false_r in H0. congruence.
Qed.

Lemma WLPO_equiv :
  WLPO <-> forall a : conat, a <> omega \/ a == omega.
Proof.
  unfold WLPO.
  split.
    intros WLPO a. destruct (WLPO a).
      right. red. cbn. assumption.
      left. intro. apply H. intro. rewrite H0. cbn. reflexivity.
    intros H a. destruct (H (r_conat a)).
      right. intro. red in H0. apply H0. admit.
      left. intro. red in H0. cbn in H0. admit.
Admitted.

Lemma MP_equiv :
  MP <-> forall a : conat, a <> omega -> a # omega.
Proof.
  unfold MP.
  split.
    intros MP a H. red. cbn. destruct (MP a) as [n Hn].
      intro. apply H. admit.
      exists n. intro. congruence.
    intros H a H'. red in H. cbn in H. destruct (H (r_conat a)).
      intro. apply H'. intro. apply (f_equal seq) in H0. cbn in H0.
Admitted.


From Hammer Require Import Hammer.

Require Coq.Lists.List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.

Inductive fin : nat -> Type :=
| F0 : forall {n}, fin (S n)
| FS : forall {n}, fin n -> fin (S n).

Fixpoint fin_all (n : nat) : list (fin n) :=
match n as n return list (fin n) with
| 0 => nil
| S n => @F0 n :: List.map (@FS _) (fin_all n)
end%list.

Theorem fin_all_In : forall {n} (f : fin n),
List.In f (fin_all n).
Proof. hammer_hook "Fin" "Fin.fin_all_In".
induction n; intros.
inversion f.
remember (S n). destruct f.
simpl; firstorder.
inversion Heqn0. subst.
simpl. right. apply List.in_map. auto.
Qed.

Theorem fin_case : forall n (f : fin (S n)),
f = F0 \/ exists f', f = FS f'.
Proof. hammer_hook "Fin" "Fin.fin_case".
intros. generalize (fin_all_In f). intros.
destruct H; auto.
eapply List.in_map_iff in H. right. destruct H.
exists x. intuition.
Qed.

Definition fin0_elim (f : fin 0) : forall T, T :=
match f in fin n return match n with
| 0 => forall T, T
| _ => unit
end with
| F0 _ => tt
| FS _ _ => tt
end.

Fixpoint pf_lt (n m : nat) : Prop :=
match n , m with
| 0 , S _ => True
| S n , S m => pf_lt n m
| _ , _ => False
end.

Fixpoint make (m n : nat) {struct m} : pf_lt n m -> fin m :=
match n as n , m as m return pf_lt n m -> fin m with
| 0 , 0 => @False_rect _
| 0 , S n => fun _ => F0
| S n , 0 => @False_rect _
| S n , S m => fun pf => FS (make m n pf)
end.

Notation "'##' n" := (@make _ n I) (at level 0).

Global Instance Injective_FS {n : nat} (a b : fin n)
: Injective (FS a = FS b).
refine {| result := a = b |}.
abstract (intro ; inversion H ; eapply inj_pair2 in H1 ; assumption).
Defined.

Fixpoint fin_eq_dec {n} (x : fin n) {struct x} : fin n -> bool :=
match x in fin n' return fin n' -> bool with
| F0 _ => fun y => match y with
| F0 _ => true
| _ => false
end
| FS n' x' => fun y : fin (S n') =>
match y in fin n'' return (match n'' with
| 0 => unit
| S n'' => fin n''
end -> bool) -> bool with
| F0 _ => fun _ => false
| FS _ y' => fun f => f y'
end (fun y => fin_eq_dec x' y)
end.

Global Instance RelDec_fin_eq (n : nat) : RelDec (@eq (fin n)) :=
{ rel_dec := fin_eq_dec }.

Global Instance RelDec_Correct_fin_eq (n : nat)
: RelDec_Correct (RelDec_fin_eq n).
Proof. hammer_hook "Fin" "Fin.RelDec_Correct_fin_eq".
constructor.
induction x. simpl.
intro. destruct (fin_case y) ; subst.
intuition.
destruct H ; subst.
intuition ; try congruence.

intro ; destruct (fin_case y) ; subst ; simpl.
intuition ; try congruence.
inversion H.
destruct H ; subst.
split ; intro.
f_equal ; eauto.
eapply IHx.
eapply H.
inv_all ; subst.
apply IHx. reflexivity.
Qed.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_comm.
Require Export XR_Rmult_eq_reg_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> R0 -> r1 = r2.
Proof.
  intros x y z heq hneq.
  apply Rmult_eq_reg_l with x.
  {
    repeat rewrite (Rmult_comm x).
    exact heq.
  }
  { exact hneq. }
Qed.


(* Narjes Jomaa and David Nowak,
   Pip code refactored by Mohamed Sami Cherif *)
Require Import List NPeano Omega Coq.Logic.Classical_Prop Bool.
Import List.ListNotations.

(** * Summary
    This file contains required functions to manipulate an association list *)

Fixpoint eqList {A : Type} (l1 l2 : list A) (eq : A -> A -> bool) : bool :=
 match l1, l2 with
 |nil,nil => true
 |a::l1' , b::l2' => if  eq a b then eqList l1' l2' eq else false
 |_ , _ => false
end.

Definition beqPairs {A B: Type} (a : (A*B)) (b : (A*B)) (eqA : A -> A -> bool) (eqB : B -> B -> bool) :=
if (eqA (fst a) (fst b)) && (eqB (snd a) (snd b))  then true else false.

Fixpoint lookup {A B C: Type} (k : A) (i : B)  (assoc : list ((A * B)*C))  (eqA : A -> A -> bool) (eqB : B -> B -> bool) :=
  match assoc with
    | nil => None
    | (a, b) :: assoc' => if beqPairs a (k,i) eqA eqB then Some b else lookup k i assoc' eqA eqB
  end.

Fixpoint removeDup {A B C: Type} (k : A) (i : B) (assoc : list ((A * B)*C) )(eqA : A -> A -> bool) (eqB : B -> B -> bool)   :=
  match assoc with
    | nil => nil
    | (a, b) :: assoc' => if beqPairs a (k,i) eqA eqB then removeDup k i assoc' eqA eqB else (a, b) :: (removeDup k i assoc' eqA eqB)
  end.

Definition add {A B C: Type} (k : A) (i : B) (v : C) (assoc : list ((A * B)*C) ) (eqA : A -> A -> bool) (eqB : B -> B -> bool)  :=
  (k,i,v) :: removeDup k i assoc eqA eqB.

Lemma NoDupSplit (A: Type) :
forall l l': list A ,
NoDup (l++l') -> NoDup l /\ NoDup l'.
Proof.
intros.
split.
 + induction l'.
   rewrite app_nil_r in H.
   assumption.
   apply IHl'.
   apply NoDup_remove_1 in H.
   assumption.
 + induction l'.
   apply NoDup_nil.
   assert (NoDup (l ++ a :: l')). assumption.
   apply NoDup_remove_2 in H.
   constructor 2.
   unfold not in *. intro. apply H.
   apply in_or_app.
   right. assumption.
   apply IHl'.
   apply NoDup_remove_1 in H0.
   assumption.
Qed.

Definition disjoint {A : Type} (l1 l2 : list A) : Prop :=
forall x : A,  In x l1  -> ~ In x l2 .

Lemma NoDupSplitInclIff (A: Type) :
forall l l': list A ,
NoDup (l++l') <-> (NoDup l /\ NoDup l') /\ disjoint l l'.
Proof.
intros.
split.
 + intros. split.
   -  apply NoDupSplit; trivial.
   - unfold disjoint. intros.
     revert x l H H0.
     induction l'; intros.
     unfold not. intros. now contradict H1.
     simpl.
     apply and_not_or.
     split.
     unfold not. intros. subst.
     unfold not in *.
     apply NoDup_remove in H.
     destruct H.
     contradict H1.
     apply in_or_app.
     left; trivial.
     apply NoDup_remove in H.
     destruct H.
     apply IHl' with l; trivial.
 + intros.
   revert l' H.
   induction l.
   - intros; simpl in *.
     intuition.
   - simpl.
     intros.
     constructor.
     intuition.
     apply in_app_iff in H0.
     destruct H0.
     apply NoDup_cons_iff in H.
     destruct H.
     now contradict H0.
     unfold disjoint in *.
     apply NoDup_cons_iff in H.

     destruct H.
     contradict H0.
     apply H2.
     simpl;left;trivial.
     apply IHl.
     intuition.
     apply NoDup_cons_iff in H; destruct H; trivial.
     unfold disjoint in *.
     intros.
     apply H1.
     simpl; right; trivial.
Qed.
Lemma inclDisjoint (A : Type) (l l' l1 l2 : list A):
disjoint l l'  -> incl l1 l -> incl l2 l' -> disjoint l1 l2.
Proof.
intros.
unfold disjoint in *.
intros.
unfold incl in *.
unfold not.
intros.
apply H1 in H3.
contradict H3.
apply H.
apply H0; trivial.
Qed.

Lemma removeNotIn (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall l a, ~ In a l -> remove eq_dec a l =l.
Proof.
induction l; intros; simpl;trivial.
apply Classical_Prop.not_or_and in H.
destruct H.
case_eq (eq_dec a0 a);intros.
subst.
now contradict H.
f_equal.
apply IHl;trivial.
Qed.

Lemma removeIncl (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall l a, incl (remove eq_dec a l) l.
Proof.
induction l;simpl;intros;trivial.
unfold incl.
intros.
trivial.
case_eq (eq_dec a0 a);intros.
subst.
assert(~ In a ((remove eq_dec a l) )).
apply remove_In.
unfold incl.
intros.
simpl .
right.
unfold incl in IHl.
apply IHl with a;trivial.
unfold incl.
intros.
simpl.
unfold incl in *.
assert(a = a1 \/ a <> a1).
{ destruct eq_dec with a a1.
  left;trivial.
  right;trivial. }
destruct H1.
left;trivial.
right.
apply IHl with a0.
simpl in H0.
destruct H0.
subst.
assert(a1 = a1).
auto.
contradiction.
trivial.
Qed.

Lemma removeNoDup
(A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall l a,NoDup l ->  NoDup (remove eq_dec a l).
Proof.
induction l;simpl;intros.
+ constructor.
+ apply NoDup_cons_iff  in H.
  destruct H.
  case_eq (eq_dec a0 a);intros.
  subst.
  apply IHl;trivial.
  constructor.
  assert(incl (remove eq_dec a0 l) l).
  { apply removeIncl. }
  unfold incl in H2.
  unfold not;intros.
  contradict H.
  apply H2;trivial.
  apply IHl;trivial.
Qed.

Lemma removeLength (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall l a, NoDup l -> In a l -> S (length (remove eq_dec a l)) = length l.
Proof.
induction l;simpl;intros.
+ contradiction.
+ f_equal.
  destruct H0.
  subst.
  destruct (eq_dec a0 a0);intros.
  assert(~ In a0 l).
   apply NoDup_cons_iff  in H.
  destruct H;trivial.
  f_equal.
  apply removeNotIn;trivial.
  auto.
  assert(a0 = a0).
  auto.
  contradiction.
  case_eq (eq_dec a0 a);intros.
  subst.
  apply NoDup_cons_iff  in H.
  destruct H;trivial.
  contradiction.
  simpl.
  apply NoDup_cons_iff  in H.
  destruct H;trivial.
  apply IHl;trivial.
Qed.

Lemma removeCons (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall l a b, a <> b -> remove eq_dec a (b ::l) = b :: (remove eq_dec a l) .
Proof.
induction l;simpl;intros.
+ case_eq (eq_dec a b);intros.
  contradiction.
  trivial.
+ case_eq (eq_dec  a0 b);intros.
  contradiction.
  f_equal.
Qed.

Lemma removeConsEq (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall l a , remove eq_dec a (a ::l) =remove eq_dec a l .
Proof.
induction l;simpl;intros.
+ case_eq (eq_dec a a);intros;trivial.
assert(a=a) by auto.
  contradiction.
+ case_eq (eq_dec  a0 a0);intros;trivial.
  assert(a0=a0) by auto.
  contradiction.
Qed.

Lemma removeStillIn (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall a b : A, forall l' l: list A ,
a <> b -> remove eq_dec a l' = l  -> In b l' -> In b l.
Proof.
induction l';simpl;trivial.
intros.
now contradict H1.
intros.
destruct H1.
subst.
case_eq(eq_dec a b);intros.
contradiction.
simpl;left;trivial.
case_eq(eq_dec a a0 );intros.
subst.
rewrite H2.
apply IHl';trivial.
rewrite H2 in H0.
subst.
simpl.
right.
apply IHl';trivial.
Qed.

Lemma  removeStillInIncl (A :Type) (eq_dec : forall x y : A, {x = y} + {x <> y}):
forall v a : A , forall l l1 l' : list A, v <> a -> remove eq_dec a l' = l ->
incl l1 l' -> In v l1 -> In v l.
Proof.
intros.
apply removeStillIn with eq_dec a l';trivial.
intuition.
unfold incl in H1.
apply H1;trivial.
Qed.

Lemma addLengthIn (A : Type) (eq_dec : forall x y : A, {x = y} + {x <> y}) :
forall l' l, forall x b : A,
length l' = S (length l)  ->
incl l l' ->
x <> b ->
In x l' ->
~ In x l ->
In b l' ->
NoDup l ->
NoDup l' ->
In b l.
Proof.
induction l';simpl;intros.
+ omega.
+ destruct H2;subst;destruct H4;subst.
  - now contradict H1.
  - destruct l. simpl in *.
    * assert(length l' = 0).
      omega.
      apply length_zero_iff_nil in H4.
      subst.
      now contradict H2.
    * assert( incl (a :: l) l').
      { apply incl_cons.
        unfold incl in H0.
        simpl in *.
        apply Classical_Prop.not_or_and in H3.
        destruct H3.
        assert(x = a \/ In a l').
        apply H0;clear H0.
        left;trivial.
        destruct H7.
        subst.
        now contradict H3.
        trivial.
        simpl in H3.
        apply Classical_Prop.not_or_and in H3.
        destruct H3.
        unfold incl in H0.
        simpl in *.
        unfold incl.
        intros.
        assert(a0 <> x).
        unfold not;intros.
        subst.
        now contradict H4.
        assert(x = a0 \/ In a0 l').
        apply H0;trivial.
        right;trivial.
        destruct H9;subst.
        now contradict H7.
        trivial. }
      subst.
      simpl.
      assert(a=b \/ a <> b).
      { destruct eq_dec with a b.
        left;trivial.
        right;trivial. }
      destruct H7.
      left;trivial.
      right.
      simpl in *.
      inversion H.
      apply Classical_Prop.not_or_and in H3.
      destruct H3.
      assert (incl l l').
      { unfold incl in H4.
        unfold incl.
        intros.
        apply H4.
        simpl.
        right;trivial. }
      apply IHl' with a;trivial.
      unfold incl in H4.
      apply H4;simpl;left;trivial.
      apply NoDup_cons_iff  in H5.
      destruct H5;trivial.
      apply NoDup_cons_iff  in H5.
      destruct H5;trivial.
      apply NoDup_cons_iff  in H6.
      destruct H6;trivial.
  - inversion H.
    assert(In b l \/ ~ In b l).
    { clear H5 H3 H7 H H0.
      induction l.
      right.
      auto.
      simpl.
      assert(a=b \/ a <> b).
      { destruct eq_dec with a b.
        left;trivial.
        right;trivial. }
      destruct H.
      subst.
      do 2 left;trivial.
      destruct IHl.
      left;right;trivial.
      right.
      intuition. }
    destruct H4 ;trivial.
    contradict H3.
    assert(incl l l').
    unfold incl in H0.
    unfold incl.
    intros.
    simpl in *.
    assert( b = a \/ In a l').
    { apply H0; trivial. }
    destruct H8.
    subst.
    now contradict H4.
    trivial.
    apply Classical_Prop.NNPP.
    unfold not at 1.
    intros.
    contradict H4.
    clear H0.
    destruct l.
    { simpl in *.
      assert(length l' = 0).
      omega.
      apply length_zero_iff_nil in H0.
      subst.
      now contradict H2. }
    assert( incl ( a :: l) l').
    { apply incl_cons.
      unfold incl in H3.
      simpl in *.
      apply Classical_Prop.not_or_and in H8.
      destruct H8.
      apply H3.
      left;trivial.
      unfold incl.
      intros.
      unfold incl in H3.
      apply H3.
      simpl;right;trivial. }
    subst.
    simpl.
    assert(a=b \/ a <> b).
    { destruct eq_dec with a b.
      left;trivial.
      right;trivial. }
    destruct H4.
    left;trivial.
    right.
    simpl in *.
    inversion H.
    apply Classical_Prop.not_or_and in H8.
    destruct H8.
    assert (incl l l').
    { unfold incl in H0.
      unfold incl.
      intros.
      apply H0.
      simpl.
      right;trivial. }
    assert(  ~ In x l) by trivial.
    apply Classical_Prop.NNPP.
    unfold not at 1;intros.
    contradict H9.
    apply IHl' with a;trivial.
    unfold incl in H0.
    apply H0;simpl;left;trivial.
    apply NoDup_cons_iff  in H5.
    destruct H5;trivial.
    apply NoDup_cons_iff  in H5.
    destruct H5;trivial.
    apply NoDup_cons_iff  in H6.
    destruct H6;trivial.
  - inversion H.
    simpl in *.
    subst.
    assert(In a l \/ ~ In a l).
    { clear H5 H3 H0 H H8.
      induction l.
      right.
      auto.
      simpl.
      assert(a0=a \/ a0 <> a).
      { destruct eq_dec with a0 a.
        left;trivial.
        right;trivial. }
      destruct H.
      subst.
      do 2 left;trivial.
      destruct IHl.
      left;right;trivial.
      right.
      intuition. }
    destruct H7.
    * assert(exists li, li = remove eq_dec a l).
      eexists.
      reflexivity.
      destruct H9 as (newL &HnewL).
      assert (a <> b).
      apply NoDup_cons_iff  in H6.
      destruct H6;trivial.
      unfold not;intros.
      subst.
      now contradict H6.
      assert(In b  newL).
      apply IHl' with x;trivial.
      subst.
      inversion H.
      rewrite H11.
      symmetry.
      apply removeLength;trivial.
      subst.
      assert (~ In a (remove eq_dec a l) ).
      apply remove_In.
      assert(incl (remove eq_dec a l) l).
      { apply removeIncl. }
      unfold incl.
      intros.
      unfold incl in *.
      simpl in *.
      assert( a = a0 \/ In a0 l').
      apply H0.
      apply H11;trivial.
      destruct H13.
      subst.
      contradict H12.
      apply remove_In.
      trivial.
      subst.
      assert(incl (remove eq_dec a l) l).
      { apply removeIncl. }
      unfold incl in H10.
      unfold not; intros.
      apply H10 in H11.
      contradiction.
      assert(incl (remove eq_dec a l) l).
      { apply removeIncl. }
      subst.
      apply removeNoDup;trivial.
      apply NoDup_cons_iff  in H6.
      destruct H6;trivial.
      assert(incl (remove eq_dec a l) l).
      { apply removeIncl. }
      subst.
      unfold incl in H11.
      apply H11;trivial.
    * destruct l.
      simpl in *.
      assert(length l' = 0).
      omega.
      apply length_zero_iff_nil in H9.
      subst.
      now contradict H2.
      simpl in *.
      apply Classical_Prop.not_or_and in H3.
      destruct H3.
      apply Classical_Prop.not_or_and in H7.
      destruct H7.
      right.
      assert(incl l l').
      unfold incl.
      intros.
      unfold incl in H0.
      simpl in *.
      assert(a = a1 \/ In a1 l').
      apply H0.
      right.
      trivial.
      destruct H12.
      subst.
      now contradict H10.
      trivial.
      apply IHl' with x;trivial.
      apply NoDup_cons_iff  in H5.
      destruct H5;trivial.
      apply NoDup_cons_iff  in H6.
      destruct H6;trivial.
Qed.

Lemma flat_map_app_cons (A : Type) (f : A ->  list A ):
forall l1 p l2 ,
flat_map f (l1 ++ p :: l2) =
flat_map f l1 ++
flat_map f [p] ++
flat_map f l2.
Proof.
intros.
do 4 rewrite flat_map_concat_map.
rewrite <- concat_app.
rewrite <- concat_app.
f_equal.
rewrite map_app.
f_equal.
Qed.

Lemma flat_map_app (A : Type) (f : A ->  list A ):
forall l1 l2 ,
flat_map f (l1 ++ l2) =
flat_map f l1 ++
flat_map f l2.
Proof.
intros.
do 3 rewrite flat_map_concat_map.
rewrite map_app.
rewrite concat_app.
f_equal.
Qed.

Lemma disjointPermut(A : Type) :
forall l1 l2 : list A,
disjoint l1 l2 -> disjoint l2 l1.
Proof.
unfold disjoint.
induction l1.
simpl.
intros.
auto.
intros.
simpl.
simpl in  H.
apply Classical_Prop.and_not_or.
split.
assert(~ In  a l2).
apply H.
left;trivial.
unfold not;intros.
subst.
now contradict H1.
apply IHl1 with l2;trivial.
intros.
apply H.
right;trivial.
Qed.

 Lemma length_diff (A : Type):
 forall (l1 l2 :list A), length l1 <> length l2 -> l1 <> l2.
 Proof.
 induction l1; simpl.
 intros.
 contradict H.
 symmetry.
 apply length_zero_iff_nil.
 rewrite H. trivial.
 intros.
 unfold not;intros.
 rewrite <- H0 in H.
 simpl in *.
 omega.
 Qed.

Lemma app_cons_not (A : Type) :
forall (l1 : list A) l2 a, l1 ++ a :: l2 <> l1 ++ l2.
Proof.
 intros. unfold not;intros.
 assert(l1 ++ [a] ++ l2 = l1 ++ l2).
 simpl. trivial.
 clear H.
 assert(length ( l1 ++ [a] ++ l2) =1+ length (l1 ++ l2)).
 do 3 rewrite app_length.
 simpl.
 omega.
 contradict H0.
 apply length_diff.
 omega.
Qed.


From Tealeaves Require Export
  Classes.Monad
  Classes.Listable.Functor
  Classes.Setlike.Monad.

Import Sets.Notations.
#[local] Generalizable Variable T A.

(** * Listable monads *)
(******************************************************************************)
Section ListableMonad.

  Context
    (T : Type -> Type)
    `{Fmap T} `{Return T} `{Join T} `{Tolist T}.

  Class ListableMonad :=
    { lmon_monad :> Monad T;
      lmon_functor :> ListableFunctor T;
      lmon_ret :
        `(tolist T ∘ ret T = ret list (A:=A));
      lmon_join :
        `(tolist T ∘ join T = join list ∘ tolist T ∘ fmap T (tolist T (A:=A)));
    }.

End ListableMonad.

(** ** Instance for [list] *)
(******************************************************************************)
Section Listable_list.

  #[program] Instance: ListableMonad list :=
    {| lmon_functor := ListableFunctor_instance_0; |}.

  Next Obligation.
    ext t. unfold compose. unfold_ops @Tolist_list.
    now rewrite (fun_fmap_id list).
  Qed.

End Listable_list.

(** * Characterizations of listable monad compatibility conditions *)
(******************************************************************************)
Section listable_monad_compatibility_conditions.

  Generalizable All Variables.

  Context
    `{Monad T}
    `{Tolist T}
    `{! ListableFunctor T}.

  (** The left-hand condition states that the natural transformation
      <<ret T>> commutes with taking <<tolist>>, i.e. that <<ret T>> is a
      list-preserving natural transformation. The right-hand condition
      is one half of the statement that <<tolist>> forms a monad
      homomorphism. *)
  Lemma tolist_ret_iff {A} :
    (tolist T ∘ ret T = tolist (fun x => x) (A:=A)) <->
    (tolist T ∘ ret T = ret list (A:=A)).
  Proof with auto.
    split...
  Qed.

  (** The left-hand condition states that the natural transformation
      <<join T>> is <<tolist>>-preserving. The right-hand condition is
      one half of the statement that <<tolist>> forms a monad
      homomorphism. *)
  Lemma tolist_join_iff {A} :
    `(tolist T ∘ join T (A:=A) = tolist (T ∘ T)) <->
    `(tolist T ∘ join T (A:=A) = join list ∘ tolist T ∘ fmap T (tolist T)).
  Proof with auto.
    split...
  Qed.

  Theorem listable_monad_compatibility_spec :
    Monad_Hom T list (@tolist T _) <->
    ListPreservingTransformation (@ret T _) /\
    ListPreservingTransformation (@join T _).
  Proof with auto.
    split.
    - introv mhom. inverts mhom. inverts mhom_domain. split.
      + constructor...
        introv. symmetry. rewrite tolist_ret_iff...
      + constructor...
        introv. symmetry. apply tolist_join_iff...
    - intros [h1 h2]. inverts h1. inverts h2.
      constructor; try typeclasses eauto.
      + introv. rewrite <- tolist_ret_iff...
      + introv. rewrite <- tolist_join_iff...
  Qed.

  Theorem listable_monad_compatibility_spec2 :
    Monad_Hom T list (@tolist T _) <->
    ListableMonad T.
  Proof.
    rewrite listable_monad_compatibility_spec.
    split.
    - intros [[] []]. constructor; try typeclasses eauto; eauto.
    - intros []. split.
      + constructor; try typeclasses eauto; eauto.
      + constructor; try typeclasses eauto; eauto.
  Qed.

End listable_monad_compatibility_conditions.

(** * Listable monads *)
(******************************************************************************)

(** * Properties of listable monads *)
(******************************************************************************)
Section ListableMonad_theory.

  Context
    `{ListableMonad T}.

  Corollary tolist_ret A (a : A) :
    tolist T (ret T a) = ret list a.
  Proof.
    intros. compose near a on left.
    now rewrite (lmon_ret T).
  Qed.

  Corollary tolist_join A (t : T (T A)) :
    tolist T (join T t) = join list (tolist T (fmap T (tolist T) t)).
  Proof.
    intros. compose near t on left.
    now rewrite (lmon_join T).
  Qed.

  Theorem return_injective : forall A (a b : A),
      ret T a = ret T b -> a = b.
  Proof.
    introv. intro heq.
    assert (lemma : tolist T (ret T a) = tolist T (ret T b)).
    { now rewrite heq. }
    rewrite 2(tolist_ret) in lemma. now inverts lemma.
  Qed.

End ListableMonad_theory.

(** ** Listable monads are set-like *)
(******************************************************************************)
Section ListableMonad_setlike.

  Context
    `{ListableMonad T}.

  Theorem toset_ret_Listable :
    `(toset T ∘ ret T (A:=A) = ret set).
  Proof.
    intros. unfold toset, Toset_Tolist, compose. ext a.
    rewrite tolist_ret.
    compose near a on left.

    rewrite toset_ret_list.
    reflexivity.
  Qed.

  Theorem toset_join_Listable :
    `(toset T ∘ join T = join set ∘ toset T ∘ fmap T (toset T (A:=A))).
  Proof.
    intros. unfold toset, Toset_Tolist.
    rewrite <- (fun_fmap_fmap T).
    reassociate -> on right.
    change_right (join (A:=A) set ∘ toset list ∘ (tolist T
                       ∘ fmap T (toset list)) ∘ fmap T (tolist T)).
    rewrite <- natural.
    reassociate <- on right.
    rewrite <- toset_join_list.
    reassociate -> on left.
    now rewrite (lmon_join T).
  Qed.

  #[export] Instance SetlikeMonad_Listable : SetlikeMonad T :=
    {| xmon_ret := toset_ret_Listable;
       xmon_join := toset_join_Listable;
       xmon_ret_injective := return_injective;
    |}.

End ListableMonad_setlike.

(*
This needs the Kleisli-style presentation available

(** * A counter-example of a respectfulness property. *)
(******************************************************************************)

(** [list] is a counterexample to the strong respectfulness condition for <<bind>>. *)
Example f1 : nat -> list nat :=
  fun n => match n with
        | 0 => [4 ; 5]
        | 1 => [ 6 ]
        | _ => [ 42 ]
        end.

Example f2 : nat -> list nat :=
  fun n => match n with
        | 0 => [ 4 ]
        | 1 => [ 5 ; 6 ]
        | _ => [ 42 ]
        end.

Definition l := [ 0 ; 1 ].

Import Monad.ToKleisli.
Import Monad.ToKleisli.Operation.

Lemma bind_f1_f2_equal : bind list f1 l = bind list f2 l.
  reflexivity.
Qed.

Lemma f1_f2_not_equal : ~(forall x, x ∈ l -> f1 x = f2 x).
Proof.
  intro hyp.
  assert (0 ∈ l) by (cbn; now left).
  specialize (hyp 0 ltac:(auto)).
  cbv in hyp.
  now inverts hyp.
Qed.

Lemma list_not_free :
  ~ (forall (l : list nat), bind list f1 l = bind list f2 l -> (forall x, x ∈ l -> f1 x = f2 x)).
Proof.
  intro H. specialize (H l bind_f1_f2_equal).
  apply f1_f2_not_equal. apply H.
Qed.
*)


(*|
###############################################
How to prove equality from equality of ``Some``
###############################################

:Link: https://stackoverflow.com/q/60304522
|*)

(*|
Question
********

I want to prove equality of two ``nat`` numbers in Coq:
|*)

Goal forall (a b : nat), Some a = Some b -> a = b.
Proof. intros. (* .unfold *)
Abort. (* .none *)

(*|
Answer (Théo Winterhalter)
**************************

When you have an equality such as this, usually, the quickest way to
go is by using the ``inversion`` tactic which will more or less
exploit injectivity of constructors.
|*)

Lemma foo : forall (a b : nat), Some a = Some b -> a = b.
Proof.
  intros a b e. inversion e. reflexivity.
Qed.

(*|
The case of ``Some`` however is special enough that you might want to
write it differently (especially if you want to be able to read the
proof that's generated). You can write some *get* function for
``option`` using a default value:
|*)

Definition get_opt_default {A : Type} (x : A) (o : option A) :=
  match o with
  | Some a => a
  | None => x
  end.

(*|
So that ``get_opt_default x (Some a) = a``. Now using ``f_equal
(get_opt_default a)`` on equality ``Some a = Some b`` you get

.. code-block:: coq

    get_opt_default a (Some a) = get_opt_default a (Some b)

which simplifies to

.. code-block:: coq

    a = b

.. coq::
|*)

Lemma Some_inj : forall A (a b : A), Some a = Some b -> a = b.
Proof.
  intros A a b e. apply (f_equal (get_opt_default a)) in e.
  cbn in e. exact e.
Qed.

(*|
This is something that can be done in general. Basically you write an
extractor for your value as a function and you apply it to both sides
of the equality. By computation it will yield the expected result.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

The ``congruence`` tactic is powerful enough to solve this goal by
itself. More generally, there are situations where you would like to
derive ``a = b`` as an additional hypothesis starting from an equality
``H : x = y`` of terms that begin with the same constructor. In this
case, you can call

.. code-block:: coq

    injection H.

to extract the equalities implied by this hypothesis.
|*)

(*|
Answer (ejgallego)
******************

I think it is instructive to write the basic lemma down:
|*)

Definition some_inj A (x y : A) (h_eq : Some x = Some y) : x = y :=
  match h_eq with
  | eq_refl _ => eq_refl
  end.

(*|
Actually, that seems surprising; indeed Coq is elaborating the match
to help the user, and the reality is a bit more ugly, as witnessed by
the term:
|*)

Print some_inj. (* .unfold *)

(*|
So indeed the return type of the match is doing quite a bit of work to
tell Coq that the constructor is injective.
|*)


Require Import ZArith.
Require Import List.
Require Import FMapPositive.
Require Import String.
Open Scope string_scope.

Require Import domains.
Require Import kstyle.
Require Import steps.

Set Implicit Arguments.

(* Test the transitivity stuff.
   We'll want to automate this *)
CoFixpoint mult :
  forall (x y z k t : Z) erest env heap labels,
    (0 <= x)%Z ->
    (0 <= y)%Z ->
    z = (x * y + k)%Z ->
    env ~= ("i" |-> x :* "j" |-> y :* "k" |-> k :* "t" |-> t :* erest) ->
  tsteps
    (KCfg (kra (SWhile (BLe (ECon 1%Z) (EVar "i"))
                       (Seq (SAssign "t" (EVar "j"))
                       (Seq (SAssign "i" (EPlus (EVar "i") (ECon (-1)%Z)))
                            (SWhile (BLe (ECon 1%Z) (EVar "t"))
                                    (Seq (SAssign "k" (EPlus (EVar "k") (ECon 1%Z)))
                                         (SAssign "t" (EPlus (EVar "t") (ECon (-1)%Z))))))))
               (kra (SAssign "t" (ECon 0%Z))
                    kdot))
                env heap labels)
    (KCfg kdot
          ("i" |-> 0%Z :* "j" |-> y%Z :* "k" |-> z :* "t" |-> 0%Z :* erest) heap labels)
with mult_sum :
  forall (x y z : Z) krest erest env heap labels,
    (0 <= y)%Z ->
    z = (x + y)%Z ->
    env ~= ("k" |-> x :* "t" |-> y :* erest) ->
  tsteps
    (KCfg (kra
             (SWhile (BLe (ECon 1%Z) (EVar "t"))
                     (Seq (SAssign "k" (EPlus (EVar "k") (ECon 1%Z)))
                          (SAssign "t" (EPlus (EVar "t") (ECon (-1)%Z)))))
             krest)
          env heap labels)
    (KCfg krest
          ("k" |-> z :* "t" |-> 0%Z :* erest) heap labels).
Proof.
(* Outer *)
* intros;repeat tstep. tsplit_if.
(* harder true case *)
+
simpl in H1; subst z.
do 14 tstep.
eapply Delay. eapply ittrans.
  - eapply itstep;[solve[econstructor(reflexivity||equate_maps)]|].
    eapply mult_sum; clear mult mult_sum.
      Focus 3.
      instantiate (3:=k).
      instantiate (2:=y).
      instantiate (1:="j" |-> y :* "i" |-> (x + -1)%Z :* erest).
      equate_maps.
      assumption.
      simpl. reflexivity.
  - eapply mult; clear mult mult_sum.
    Focus 4.
    instantiate (3:=(x + -1)%Z).
    instantiate (2:=(k + y)%Z).
    instantiate (1:=0%Z).
    equate_maps.
    omega.
    omega.
    ring.

(* easy false case *)
+ clear mult mult_sum.
  repeat tstep.
  apply Done.
  replace x with 0%Z in * |- * by omega.
  solve[repeat split;try solve[equate_maps]].

(* Inner *)
* clear mult.
  intros.
  repeat tstep. tsplit_if.
  -
  do 17 tstep.
  eapply mult_sum; clear mult_sum; try solve[equate_maps]; omega.
  - clear mult_sum.
  repeat tstep.
  apply Done.
  replace y with 0%Z by omega.
  replace x with z by omega.
  (* now they are equivalent, but ksteps was currently
     defined in terms of eq rather than kequiv.
    So, assert kequiv to prove we can, and then admit the eq *)
  solve[repeat split;try solve[equate_maps]].
Qed.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : list bool }.
Definition format :=
  format_nat 8 ◦ length ◦ data ++
  format_list format_bool ◦ data.
Definition invariant (m : msg) :=
  length (m.(data)) < pow2 8 /\ length (m.(data)) mod 8 = 0.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Check String.eqb_refl :
  forall x : string, (x =? x)%string = true.

Check String.eqb_eq :
  forall n m : string, (n =? m)%string = true <-> n = m.
Check String.eqb_neq :
  forall n m : string, (n =? m)%string = false <-> n <> m.
Check String.eqb_spec :
  forall x y : string, reflect (x = y) (String.eqb x y).

Definition total_map (A: Type) := string -> A.

Definition t_empty {A: Type} (v: A): total_map A :=
  (fun _ => v).

Definition t_update {A: Type} (m: total_map A) (x: string) (v: A) :=
  fun x' => if String.eqb x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true) "bar" true.

Notation "'_' '!->' v" := (t_empty v) (at level 100, right associativity).

Example example_empty := (_ !-> false).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition examplemap' := (
  "bar" !-> true;
  "foo" !-> true;
  _ !-> false
).

Lemma t_apply_empty: forall (A: Type) (x: string) (v: A),
  (_ !-> v) x = v.
Proof.
  intros. reflexivity.
Qed.

Lemma t_update_eq: forall (A: Type) (m: total_map A) x v,
  (x !-> v; m) x = v.
Proof.
  intros. unfold t_update. rewrite String.eqb_refl. reflexivity.
Qed.

Theorem t_update_neq: forall (A: Type) (m: total_map A) x1 x2 v,
  x1 <> x2 -> (x1 !-> v; m) x2 = m x2.
Proof.
  intros. unfold t_update. apply String.eqb_neq in H. rewrite H. reflexivity.
Qed.

Theorem t_update_shadow: forall (A: Type) (m: total_map A) x v1 v2,
  (x !-> v2; x !-> v1; m) = (x !-> v2; m).
Proof.
  intros. apply functional_extensionality. intros y. destruct (x =?
  y)%string as [] eqn:E.
  - unfold t_update. rewrite E. reflexivity.
  - unfold t_update. rewrite E. reflexivity.
Qed.

Theorem t_updaet_same: forall (A: Type) (m: total_map A) x,
  (x !-> m x; m) = m.
Proof.
  intros. apply functional_extensionality. intros y. unfold t_update. destruct (String.eqb_spec x
  y).
  - rewrite e. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_same: forall (A: Type) (m: total_map A) x,
  (x !-> m x; m) = m.
Proof.
  intros. apply functional_extensionality. intros y. unfold t_update. destruct
  (String.eqb_spec x y).
  - rewrite e. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute: forall (A: Type) (m: total_map A) v1 v2 x1 x2,
  x2 <> x1 -> (x1 !-> v1; x2 !-> v2; m) = (x2 !-> v2; x1 !-> v1; m).
Proof.
  intros. apply functional_extensionality. intros y. unfold t_update. destruct
  (String.eqb_spec x1 y); destruct (String.eqb_spec x2 y).
  - rewrite <- e in e0. destruct (H e0).
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(* Partial maps *)
Definition partial_map (A: Type) := total_map (option A).

Definition empty {A: Type}: partial_map A := t_empty None.

Definition update {A: Type} (m: partial_map A) (x: string) (v: A) :=
  (x !-> Some v; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v)
  (at level 100).

Definition examplemap'' := ("C" |-> true; "T" |-> false).

Lemma apply_empty: forall (A: Type) (x: string), @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty. reflexivity.
Qed.

Lemma update_eq: forall (A: Type) (m: partial_map A) x v,
  (x |-> v; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq. reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
  x2 <> x1 ->
  (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
  (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
  m x = Some v ->
  (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
  x2 <> x1 ->
  (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

Definition includedin {A: Type} (m m': partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

Lemma includedin_update: forall (A: Type) (m m': partial_map A) (x: string) (vx:
A),
  includedin m m' -> includedin (x |-> vx; m) (x |-> vx; m').
Proof.
  unfold includedin. intros A n m' x vx H y vy. destruct (eqb_spec x y).
  - rewrite e. rewrite update_eq. rewrite update_eq. intros. apply H0.
  - rewrite update_neq. rewrite update_neq. apply H. apply n0. apply n0.
Qed.


From stdpp Require Import gmultiset gmap.
From Coq.ssr Require Import ssreflect.

Section lemmas.
  Context `{!EqDecision A} `{!Countable A}.

  Implicit Types M N : gmultiset A.
  Implicit Types X Y : gset A.
  Implicit Types x y : A.

  Definition gset_of_gmultiset (M : gmultiset A) : gset A := dom M.

  Lemma elem_of_gset_of_gmultiset M x : x ∈ gset_of_gmultiset M ↔ (0 < multiplicity x M).
  Proof. rewrite /gset_of_gmultiset gmultiset_elem_of_dom. apply elem_of_multiplicity. Qed.

  Lemma gset_of_gmultiset_empty : gset_of_gmultiset ∅ = ∅.
  Proof. eapply @dom_empty_L; apply _. Qed.

  Lemma gset_of_gmultiset_singleton x : gset_of_gmultiset {[+ x +]} = {[ x ]}.
  Proof. apply dom_singleton_L. Qed.

  Lemma gmultiset_difference_subseteq M N : M ∖ N ⊆ M.
  Proof. intros x; rewrite multiplicity_difference; lia. Qed.

  Lemma gmultiset_difference_after_disj_union M N : (M ⊎ N) ∖ N = M.
  Proof.
    apply gmultiset_eq; intros x.
    rewrite multiplicity_difference multiplicity_disj_union.
    lia.
  Qed.

  Lemma gset_of_gmultiset_disj_union M N :
    gset_of_gmultiset (M ⊎ N) = (gset_of_gmultiset M) ∪ (gset_of_gmultiset N).
  Proof.
    apply set_eq=> x.
    rewrite elem_of_union !elem_of_gset_of_gmultiset multiplicity_disj_union.
    lia.
  Qed.

  Lemma gset_of_gmultiset_subseteq_mono M N :
    N ⊆ M → gset_of_gmultiset N ⊆ gset_of_gmultiset M.
  Proof.
    intros Hle x. rewrite !elem_of_gset_of_gmultiset.
    intros Hin. specialize (Hle x). lia.
  Qed.

  Lemma gset_of_gmultiset_disj_union_subseteq M N :
    N ⊆ M → gset_of_gmultiset (M ⊎ N) = gset_of_gmultiset M.
  Proof.
    intros Hle. rewrite gset_of_gmultiset_disj_union.
    apply gset_of_gmultiset_subseteq_mono in Hle. set_solver.
  Qed.

End lemmas.


Require Import Utf8 Basics Setoid FunctionalExtensionality.

Import EqNotations.

Add LoadPath "Category".
Require Import Category SpecialMorphismsAndObjects.

Generalizable Variables obj hom objA homA objB homB objC homC.

Class Product `{Category obj hom} (A B C : obj) (prA : C --> A) (prB : C --> B) := {
  product_prop: forall (D : obj) (f : D --> A) (g : D --> B),
    exists ! (h : D --> C), prA • h = f /\ prB • h = g
}.

Class Coproduct `{Category obj hom} (A B C : obj) (inA : A --> C) (inB : B --> C) := {
  coproduct_prop: forall (D : obj) (f : A --> D) (g : B --> D),
    exists ! (h : C --> D), h • inA = f /\ h • inB = g
}.

Lemma product_dual_coproduct `{Cat : Category obj hom}:
  forall A B C f g,
  @Product _ _ _ _ Cat A B C f g <-> @Coproduct _ _ _ _ (Dual Cat) A B C f g.
Proof.
  intros. split; intros P; destruct P; constructor; auto.
Qed.

(* TODO DO I NEED TO REMOVE THIS DUALITY FROM TYPECLASS INFERENCE? *)

Lemma product_unique_iso1 `{Category obj hom} : forall A B C1 C2 f1 f2 g1 g2,
  Product A B C1 f1 g1 -> Product A B C2 f2 g2 -> C1 == C2.
Proof.
  intros.
  pose proof (product_prop C1 f1 g1).
  pose proof (product_prop C2 f2 g2).
  pose proof (@product_prop _ _ _ _ _ _ _ C1 _ _ H0 C2 f2 g2).
  pose proof (@product_prop _ _ _ _ _ _ _ C1 _ _ H0 C1 f1 g1).
  destruct H2 as [i [Ui1 Ui2]], H4 as [j [Uj1 Uj2]].
  exists i. exists j.
  destruct H3 as [ic2 [Uc21 Uc22]], H5 as [ic1 [Uc11 Uc12]].
  assert (ic1 = (cid C1)) as E1. { apply Uc12. split; apply idRight. }
  assert (ic2 = (cid C2)) as E2. { apply Uc22. split; apply idRight. }
  clear Uc21. clear Uc11.
  subst. destruct Ui1, Uj1.
  split.
  - symmetry. unfold "1". apply Uc22. split.
    + rewrite compAssoc. rewrite H2. apply H4.
    + rewrite compAssoc. rewrite H3. apply H5.
  - symmetry. unfold "1". apply Uc12. split; rewrite compAssoc.
    + rewrite H4. apply H2.
    + rewrite H5. apply H3.
Qed.

Lemma product_unique_iso2 `{Category obj hom} : forall A B C1 C2 f1 g1,
  Product A B C1 f1 g1 -> C1 == C2 -> exists f2 g2, Product A B C2 f2 g2.
Proof.
  intros. destruct H1 as [i [j [L R]]]. exists (f1 • j), (g1 • j).
  constructor. intros.
  pose proof (product_prop D f g). destruct H1 as [h [[E1 E2] U2]].
  exists (i • h). split; try split.
  - replace ((f1 • j) • (i • h)) with ((f1 • (j • i) • h)).
    unfold "•" in *. rewrite R. unfold "1". rewrite idRight. apply E1.
    repeat (rewrite compAssoc); reflexivity.
  - replace ((g1 • j) • (i • h)) with ((g1 • (j • i) • h)).
    unfold "•" in *. rewrite R. unfold "1". rewrite idRight. apply E2.
    repeat (rewrite compAssoc); reflexivity.
  - intros h' [H'1 H'2]. assert (h = (j • h')).
    { apply U2. split; rewrite compAssoc; auto. }
    subst. rewrite compAssoc. unfold "•" in *. rewrite L. apply idLeft.
Qed.

Instance idProduct `{Category} A T (HT : isTerminal T) : Product A T A 1 (bang T HT A).
  constructor.
  intros. exists f. split; try split.
  - apply idLeft.
  - pose proof (bang_unique T HT D).
    assert (bang _ HT A • f = bang _ HT D). apply H0.
    rewrite H1. symmetry. apply bang_unique.
  - intros. destruct H0. rewrite <- H0. apply idLeft.
Defined.

Lemma product_commutative `{Category} A B C pr1 pr2 :
  Product A B C pr1 pr2 -> Product B A C pr2 pr1.
Proof.
  intros. constructor. intros.
  pose proof (product_prop D g f). destruct H1. exists x.
  destruct H1 as [[H2 H3] H1]. split.
  - split; auto.
  - intros x' [L R]. apply H1; split; auto.
Qed.

Lemma product_commutative_iso `{Category} A B C1 C2 prA1 prA2 prB1 prB2:
  Product A B C1 prA1 prB1 -> Product B A C2 prB2 prA2 -> C1 == C2.
Proof.
  intros. eapply product_unique_iso1.
  apply H0. apply product_commutative. apply H1.
Qed.

(** EXAMPLES **)

Open Scope type_scope.

Instance Product_Set (A B : Set) : Product A B (A * B) fst snd.
  constructor.
  intros. exists (fun d => ((f d), (g d))). split.
  - split.
    + extensionality d. reflexivity.
    + extensionality d. reflexivity.
  - intros. destruct H. rewrite <- H. rewrite <- H0. extensionality d.
    compute. destruct (x' d). reflexivity.
Defined.


(** Copyright (c) 2015 Bill White **)
(** Distributed under the MIT/X11 software license **)
(** See http://www.opensource.org/licenses/mit-license.php **)

(** Addrs : Representation of addresses as 160 bit sequences. **)

Require Export Prelude.

Fixpoint bitseq (n:nat) : Type :=
match n with
| 0 => unit
| S n' => (bool * bitseq n')%type
end.

Definition bitseq_eq_dec {n} (bs1 bs2:bitseq n) : { bs1 = bs2 } + { bs1 <> bs2 }.
induction n as [|n IHn].
- destruct bs1, bs2. decide equality.
- destruct bs1 as [b1 bs1], bs2 as [b2 bs2]. repeat decide equality.
Defined.

Fixpoint listbool_bitseq (bl:list bool) : bitseq (length bl) :=
match bl with
| nil => tt
| b::br => (b,listbool_bitseq br)
end.

Fixpoint bitseq_listbool {n} (bs:bitseq n) : list bool :=
match n as n' return bitseq n' -> list bool with
| O => fun _ => nil
| S n => fun bs => let (b,br) := bs in (b::bitseq_listbool br)
end bs.

Lemma listbool_bitseq_listbool bl : bitseq_listbool (listbool_bitseq bl) = bl.
induction bl as [|b bl IH].
- reflexivity.
- simpl. congruence.
Qed.

Lemma bitseq_listbool_length {n} (bs:bitseq n) : length (bitseq_listbool bs) = n.
induction n as [|n IH].
- reflexivity.
- destruct bs as [b bs]. simpl. rewrite IH. reflexivity.
Qed.

Fixpoint strip_bitseq_false {n:nat} {X:Type} (l:list (bitseq (S n) * X)%type) : list (bitseq n * X)%type :=
match l with
| nil => nil
| cons ((false,bs),x) l' => cons (bs,x) (strip_bitseq_false l')
| cons ((true,bs),x) l' => strip_bitseq_false l'
end.

Fixpoint strip_bitseq_true {n:nat} {X:Type} (l:list (bitseq (S n) * X)%type) : list (bitseq n * X)%type :=
match l with
| nil => nil
| cons ((true,bs),x) l' => cons (bs,x) (strip_bitseq_true l')
| cons ((false,bs),x) l' => strip_bitseq_true l'
end.

Lemma strip_bitseq_false_iff {n} {X} (alpha:bitseq n) (x:X) (l:list (bitseq (S n) * X)%type) :
  In (alpha,x) (strip_bitseq_false l) <-> In ((false,alpha),x) l.
induction l as [|[[[|] beta] y] l IH].
- simpl. tauto.
- simpl. split.
  + intros H1. right. now apply IH.
  + intros [H1|H1].
    * inversion H1.
    * now apply IH.
- simpl. split.
  + intros [H1|H1].
    * left. inversion H1. reflexivity.
    * right. now apply IH.
  + intros [H1|H1].
    * inversion H1. now left.
    * right. now apply IH.
Qed.

Lemma strip_bitseq_true_iff {n} {X} (alpha:bitseq n) (x:X) (l:list (bitseq (S n) * X)%type) :
  In (alpha,x) (strip_bitseq_true l) <-> In ((true,alpha),x) l.
induction l as [|[[[|] beta] y] l IH].
- simpl. tauto.
- simpl. split.
  + intros [H1|H1].
    * left. inversion H1. reflexivity.
    * right. now apply IH.
  + intros [H1|H1].
    * inversion H1. now left.
    * right. now apply IH.
- simpl. split.
  + intros H1. right. now apply IH.
  + intros [H1|H1].
    * inversion H1.
    * now apply IH.
Qed.

Fixpoint bitseq_concat {n} (bs:bitseq n) {m} (br:bitseq m) : bitseq (n+m) :=
match n as n' return bitseq n' -> bitseq (n'+m) with
| O => fun _ => br
| S n => fun bs => let (b,bs') := bs in (b,bitseq_concat bs' br)
end bs.

Definition termaddr := bitseq 160.

Definition termaddr_eq_dec (a1 a2: termaddr) : { a1 = a2 } + { a1 <> a2 }.
apply bitseq_eq_dec.
Defined.

Definition pubaddr := bitseq 160.

Definition pubaddr_eq_dec (a1 a2: pubaddr) : { a1 = a2 } + { a1 <> a2 }.
apply bitseq_eq_dec.
Defined.

Definition payaddr := bitseq 161.

Definition payaddr_eq_dec (a1 a2: payaddr) : { a1 = a2 } + { a1 <> a2 }.
apply bitseq_eq_dec.
Defined.

Definition addr := bitseq 162.

Definition addr_eq_dec (a1 a2: addr) : { a1 = a2 } + { a1 <> a2 }.
apply bitseq_eq_dec.
Defined.

Definition payaddr_addr (alpha:payaddr) : addr := (false,alpha).

Definition termaddr_addr (a:termaddr) : addr := (true,(false,a)).

Definition pubaddr_addr (a:termaddr) : addr := (true,(true,a)).

Lemma payaddr_addr_inj a b : payaddr_addr a = payaddr_addr b -> a = b.
intros H1. destruct a as [[|] a]; destruct b as [[|] b]; try discriminate H1.
- inversion H1. congruence.
- inversion H1. congruence.
Qed.

Lemma termaddr_addr_inj a b : termaddr_addr a = termaddr_addr b -> a = b.
intros H1. destruct a as [[|] [[|] a]]; destruct b as [[|] [[|] b]]; try discriminate H1.
- inversion H1. congruence.
- inversion H1. congruence.
- inversion H1. congruence.
- inversion H1. congruence.
Qed.

Lemma pubaddr_addr_inj a b : pubaddr_addr a = pubaddr_addr b -> a = b.
intros H1. destruct a as [[|] [[|] a]]; destruct b as [[|] [[|] b]]; try discriminate H1.
- inversion H1. congruence.
- inversion H1. congruence.
- inversion H1. congruence.
- inversion H1. congruence.
Qed.

Definition p2pkh_payaddr_p (alpha:payaddr) : Prop :=
  match alpha with
    | (false,_) => True
    | _ => False
  end.

Definition p2sh_payaddr_p (alpha:payaddr) : Prop :=
  match alpha with
    | (true,_) => True
    | _ => False
  end.

Definition p2pkh_addr_p (alpha:addr) : Prop :=
  match alpha with
    | (false,(false,_)) => True
    | _ => False
  end.

Definition p2sh_addr_p (alpha:addr) : Prop :=
  match alpha with
    | (false,(true,_)) => True
    | _ => False
  end.

Definition pay_addr_p (alpha:addr) : Prop :=
  match alpha with
    | (false,_) => True
    | _ => False
  end.

Definition term_addr_p (alpha:addr) : Prop :=
  match alpha with
    | (true,(false,_)) => True
    | _ => False
  end.

Definition publication_addr_p (alpha:addr) : Prop :=
  match alpha with
    | (true,(true,_)) => True
    | _ => False
  end.


Require Import HoTT.Basics HoTT.Types HoTT.Fibrations.
Require Import MyTacs.
Generalizable All Variables.

Lemma ap_apply_truc {A B: Type} {P: A -> Type} {f g: forall a: A, P a -> B} (p: f = g) (a: A) (x: P a)
: ap (λ F, F a x) p = ap10 (apD10 p a) x.
  destruct p; reflexivity.
Defined.

Lemma ap_apply_truc_2 {A B D: Type} {C: B -> Type} (M: A -> forall b:B, C b -> D) {a a': A} (p: a = a') (b: B) (c: C b)
: ap (λ F, M F b c) p = ap10 (apD10 (ap M p) b) c.
  destruct p; reflexivity.
Defined.

Lemma ap_path_sigma_1 {A B: Type} {P: A -> Type} (F: forall a: A, P a -> B) (a: A) {x y: P a} (p: x = y)
: ap (λ w, F w.1 w.2) (path_sigma' P 1 p) = ap (λ z, F a z) p.
  destruct p; reflexivity.
Defined.

Lemma apD_pp `{P: A -> Type} (f: forall a, P a) {x y z: A} (p: x = y) (q: y = z)
: apD f (p @ q) = (transport_pp P p q (f x)) @ (ap _ (apD f p)) @ (apD f q).
    by path_induction.
Qed.

Definition transport_const_transportD {A B: Type} (C: A -> B -> Type) {x1 x2: A} (p: x1 = x2) `(u: C x1 y)
: transport (λ y, C x2 y) (transport_const p y)
            (transportD (λ _ : A, B) C p y u) = transport (λ x, C x y) p u.
  destruct p. reflexivity.
Defined.

Lemma path_sig_hfiber `{f: A -> B} (x y : sig (hfiber f)) (q : x.2.1 = y.2.1) : x = y.
  destruct x as [b [a e]].
  destruct y as [b' [a' e']].
  simpl in q.
  simple refine (path_sigma' _ _ _). exact (e^ @ (ap f q) @ e').
  etransitivity. exact (transport_sigma _ _). simpl.
  simple refine (path_sigma' _ _ _).
  etransitivity. apply transport_const. exact q.
  path_induction. reflexivity.
Defined.

Lemma equiv_paths {A: Type} {a a' b: A} (p: a = a') : a = b <~> a' = b.
  simple refine (equiv_adjointify (concat p^) (concat p) _ _); intro; abstract hott_simpl.
Defined.

Definition transport_hfiber `(f: A -> B) `(e: b = b') `(p: f a = b)
: transport (λ b, hfiber f b) e (a; p) = (a; p @ e).
  path_induction. reflexivity.
Defined.

Definition functor_fibration_replacement `{f: X -> Y} `{f': X' -> Y} (g: X -> X')
           (e: f' o g == f)
: sig (hfiber f) → sig (hfiber f')
  := λ x, (x.1; (g x.2.1; (e x.2.1) @ x.2.2)).

Definition fibration_replacement_commute `(g: X -> X') `(f: X -> Y) (f': X' -> Y) (e: f' o g == f)
: (functor_fibration_replacement g e) o (equiv_fibration_replacement f) == (equiv_fibration_replacement f') o g.
  intros x; simpl.
  simple refine (path_sig_hfiber (f:=f') _ _ _). reflexivity.
Defined.

Set Implicit Arguments.
Lemma moveR_E_compose `{HF:Funext} {A B C: Type} (f:B -> C) (g : A -> B) (h : A -> C) (IsEq_g : IsEquiv g)
: (f = h o g^-1) -> (f o g = h).
  intro H.
  symmetry in H.
  destruct H. apply path_forall; intro x. rewrite eissect. reflexivity.
Qed.

Lemma ap_ap_path_forall `{HF:Funext} {X:Type} {Y:X -> Type} (g h:forall x:X, Y x) eq x
: ap (λ f:forall x:X, Y x, f x)
     (path_forall g h eq)
  = eq x.
  apply (apD10 (f := ((ap (x:=g) (y:=h) (λ f : ∀ x0 : X, Y x0, f x)) o apD10^-1)) (g:= λ eq, eq x)).
  simple refine (moveR_E_compose _ _).
  simpl. apply path_forall; intro u.
  destruct u; reflexivity.
Qed.

Lemma ap_ap2_path_forall `{HF:Funext} (X:Type) (Y : X -> Type) (Z:forall x:X, Y x -> Type) (g h : forall x:X, forall y:Y x, Z x y) eq x y
: ap (λ f:forall x:X, forall y:Y x, Z x y, f x y) (path_forall g h (λ x, path_forall (g x) (h x) (eq x)))
  = eq x y.
  rewrite (ap_compose (λ f : ∀ (x0 : X) (y0 : Y x0), Z x0 y0, f x) (λ f, f y) (path_forall g h (λ x0 : X, path_forall (g x0) (h x0) (eq x0)))).
  pose (rew := ap_ap_path_forall (λ x0 : X, path_forall (g x0) (h x0) (eq x0))); simpl in rew. rewrite rew; clear rew.
  apply ap_ap_path_forall.
Qed.

Lemma concat_ap_Fpq (A B:Type) (a b:A) (c d e:B) (f: a = b -> c = d)
      (v:d = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => f u @ v) p = whiskerR (ap f p) v.
Proof.
  destruct p; reflexivity.
Defined.

Lemma concat_ap_pFq (A B:Type) (a b:A) (d e c:B) (f: a = b -> e = c)
      (v:d = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => v @ f u) p = whiskerL v (ap f p).
Proof.
  destruct p; reflexivity.
Defined.

Lemma whiskerL_LV (A : Type) (x y z: A) (p : x = y) (q q' : y = z)
      (r : q = q')
  : whiskerL p r^ = (whiskerL p r)^.
Proof.
  destruct r, q, p; reflexivity.
Qed.

Lemma whiskerR_RV (A : Type) (x y z: A) (p : y = z) (q q' : x = y)
      (r : q = q')
  : whiskerR r^ p = (whiskerR r p)^.
Proof.
  destruct r, q, p; reflexivity.
Defined.

Lemma ap02_is_ap (A B : Type) (f : A -> B) (x y : A) (p q : x = y) (r:p=q)
  : ap02 f r = ap (ap f) r.
Proof.
  destruct r; reflexivity.
Defined.

Lemma ap02_compose (A B C : Type) (f : A -> B) (g : B -> C) (x y : A) (p p': x = y) (q:p=p')
  : ap02 (g o f) q = ap_compose f g p @ (ap02 g (ap02 f q) @ (ap_compose f g p')^).
Proof.
  destruct q, p; reflexivity.
Defined.

Lemma ap02_V (A B : Type) (f : A -> B) (x y : A) (p q : x = y) (r:p=q)
  : ap02 f r^ = (ap02 f r)^.
Proof.
  destruct r; reflexivity.
Defined.

Lemma transport2_is_ap  (A : Type) (Q : A -> Type) (x y : A) (p q : x = y)
      (r : p = q) (z : Q x)
  : transport2 Q r z = ap (fun U => transport Q U z) r.
Proof.
  destruct r. reflexivity.
Defined.

Lemma ap_FG {A B:Type} {a b:A} {d e f:B} (F: a = b -> e = f) (G: a = b -> f = d)
      {u v:a = b} (p: u = v)
  : ap (λ x, F x @ G x) p = ap F p @@ ap G p.
Proof.
  destruct p.
  reflexivity.
Defined.

Lemma concat2_inv (A : Type) (x y z : A) (p p' : x = y) (q q' : y = z)
      (r:p=p') (s:q=q')
  : (r @@ s)^ = (r^ @@ s^).
Proof.
  destruct r, s. reflexivity.
Defined.

Unset Implicit Arguments.


Require Import String.
Open Scope string_scope.

Require Import List.
Import ListNotations.

Inductive var: Type :=
  | Named_var: string -> var.

Inductive functional_symbol : Type :=
  | Func: string -> functional_symbol.

Inductive predicative_symbol : Type :=
  | Predicate: string -> predicative_symbol.

Inductive term : Type :=
  | Tconst : functional_symbol -> term
  | Tvar : var -> term
  | Tfunc : functional_symbol -> list term -> term.

Inductive assignment_pair : Type :=
  | Apair: var -> term -> assignment_pair.

Inductive assignment : Type :=
  | Apairs: list assignment_pair -> assignment.

Inductive term_pair : Type :=
  | Tpair (t1 t2 : term) : term_pair.

Inductive maybe_term_pair : Type :=
  | TError
  | TP (tp : term_pair).

Inductive unification_problem : Type :=
  | Ubottom
  | Uset (l : list term_pair) : unification_problem.

Inductive maybe_unification_problem : Type :=
  | UError
  | UP (u_p :unification_problem).

Definition a := Named_var "a".
Definition b := Named_var "b".
Definition x := Named_var "x".
Definition y := Named_var "y".
Definition z := Named_var "z".
Definition x1 := Named_var "x1".
Definition x2 := Named_var "x2".
Definition x3 := Named_var "x3".
Definition f := Func "f".
Definition g := Func "g".

Definition P := Predicate "P".

Definition sigma1 := Apairs [Apair y (Tvar x); Apair x (Tvar y)].

Definition t1 := Tfunc (Func "f") [Tvar x; Tvar y; Tvar x; Tfunc (Func "g") [Tvar x; Tvar y]].
Definition t2 := Tfunc (Func "f") [Tvar x; Tvar y; Tvar x].

Definition decomposition_term_pair := Tpair (Tfunc (Func "f") [Tvar x; Tvar y]) (Tfunc (Func "f") [Tvar a; Tvar b]).
Definition orientation_term_pair := Tpair t2 (Tvar a).
Definition conflict_term := Tpair (Tfunc (Func "f") [Tvar x; Tvar y]) (Tfunc (Func "g") [Tvar a; Tvar b]).
Definition occurs_check_term_pair := (Tpair (Tvar a) (Tfunc (Func "g") [Tvar a; Tvar b])).
Definition unif_probl1 := Uset [ Tpair t1 t1; decomposition_term_pair; orientation_term_pair].
Definition unif_probl2 := Uset [ conflict_term ].
Definition elimination_tpair := Tpair (Tvar x2) (Tvar a).
Definition unif_probl4 := Uset [Tpair (Tfunc f [Tfunc g [Tvar x1; Tvar a]; Tvar x2]) (Tvar x3); Tpair (Tfunc f [Tvar x2; Tvar x2]) (Tfunc f [Tvar a; Tvar x1])].
Definition unif_probl4' := Uset [Tpair (Tfunc f [Tfunc g [Tvar x1; Tvar a]; Tvar x2]) (Tvar x3); Tpair (Tvar x2) (Tvar a); Tpair (Tvar x2) (Tvar x1)].
Definition unif_probl4'' := Uset [Tpair (Tfunc f [Tfunc g [Tvar x1; Tvar a]; Tvar a]) (Tvar x3); Tpair (Tvar x2) (Tvar a); Tpair (Tvar a) (Tvar x1)].
Definition unif_probl4''' := Uset [Tpair (Tfunc f [Tfunc g [Tvar x1; Tvar a]; Tvar a]) (Tvar x3); Tpair (Tvar x2) (Tvar a); Tpair (Tvar x1) (Tvar a)].
Definition unif_probl4'''' := Uset [Tpair (Tfunc f [Tfunc g [Tvar a; Tvar a]; Tvar a]) (Tvar x3); Tpair (Tvar x2) (Tvar a); Tpair (Tvar x1) (Tvar a)].
Definition unif_probl4''''' := Uset [Tpair (Tvar x3) (Tfunc f [Tfunc g [Tvar a; Tvar a]; Tvar a]); Tpair (Tvar x2) (Tvar a); Tpair (Tvar x1) (Tvar a)].
Definition elimination_example := Uset [Tpair (Tfunc f [Tfunc g [Tvar x1; Tvar a]; Tvar x2]) (Tvar x3); Tpair (Tfunc f [Tvar x2; Tvar x2]) (Tfunc f [Tvar a; Tvar x1]); elimination_tpair].
Definition delete_term_pair := Tpair t1 t1.
Definition elimination_example' := Uset [Tpair (Tfunc f [Tfunc g [Tvar x1; Tvar a]; Tvar x2]) (Tvar x3); elimination_tpair; Tpair (Tfunc f [Tvar x2; Tvar x2]) (Tfunc f [Tvar a; Tvar x1])].
Definition orientation_term_pair' := Tpair t2 (Tvar x2).
Definition unification_problem1' := Uset [ Tpair t1 t1; decomposition_term_pair; orientation_term_pair'].

Definition unif_probl1' := Uset [decomposition_term_pair; orientation_term_pair].

Definition unif_probl1'' := Uset [orientation_term_pair].

Check (Apair x (Tvar y)).
Check (Apairs [Apair x (Tvar y); Apair z (Tfunc (Func "f") [Tvar x; Tvar y])]).

(*DEPRECATED*)
Inductive atomic_formulae : Type :=
  | Afpred: predicative_symbol -> list term -> atomic_formulae.

Inductive first_order_formulae : Type :=
  | Aformulae (phi : atomic_formulae)
  | Anot (phi : first_order_formulae)
  | Aand (phi1 phi2 : first_order_formulae)
  | Aor (phi1 phi2 : first_order_formulae)
  | Aimplies (phi1 phi2 : first_order_formulae)
  | Adoubleimplies (phi1 phi2 : first_order_formulae)
  | Aforall (x : var) (phi : first_order_formulae)
  | Aexists (x : var) (phi : first_order_formulae).

Inductive unif_solver_rule (tp : term_pair) (u_p : unification_problem) : Type:=
  | Rdelete
  | Rdecompose
  | Rorientation
  | Relimination
  | Rconflict
  | Roccurs_check .

(* First try :
Inductive solver : unification_problem -> Prop :=
  | Sbottom : solver Ubottom
  | Ssolved (u_p : unification_problem) (H : (unification_problem_in_solved_form u_p) = true) : solver u_p
  | Sdelete (u_p u_p' : unification_problem)(H : ((term_in_unification_problem u_p term_eq) = true)) (H' : (remove_first_appearance_term_unification_problem u_p term_eq) = u_p')(H'' : solver u_p'): solver u_p
  | Sdecompose (u_p u_p' : unification_problem)(tp : term_pair)(H : ((term_in_unification_problem u_p is_decomposition_term_pair) = true)) (H' : (remove_and_replace_decomposition_unif_problem tp u_p) = u_p')(H'' : solver u_p'): solver u_p
  | Sorientation (u_p u_p' : unification_problem) (tp : term_pair) (H : ((term_in_unification_problem u_p is_orientation_term_pair) = true)) (H' : (apply_orientation tp u_p) = u_p') (H'' : solver u_p'): solver u_p
  | Selimination (u_p u_p' : unification_problem) (tp : term_pair) (H : ((term_in_unification_problem u_p is_elimination_term_pair) = true)) (H' : (elimination tp u_p) = u_p') (H'' : solver u_p'): solver u_p
  | Sconflict (u_p u_p' : unification_problem) (tp : term_pair) (H : ((term_in_unification_problem u_p is_conflict_term_pair) = true)) (H' : (remove_conflict_term_pair tp u_p) = u_p') (H'' : solver u_p'): solver u_p
  | Soccurs_check (u_p u_p' : unification_problem) (tp : term_pair) (H : ((term_in_unification_problem u_p is_occurs_check_term_pair) = true)) (H' : (occurs_check tp u_p) = u_p') (H'' : solver u_p'): solver u_p.
*)

(* Second try :
Inductive solver : maybe_unification_problem -> Prop :=
  | Serror : solver UError
  | Sbottom (u_p : maybe_unification_problem) (H : maybe_is_bottom u_p = true): solver u_p
  | Ssolved (u_p : maybe_unification_problem) (H : (maybe_unification_problem_in_solved_form u_p) = true) : solver u_p
  | Sapply (u_p : maybe_unification_problem) (H: solver (maybe_apply_one_step u_p)) : solver u_p.
*)

Definition phi := Afpred P.

Definition phi1 := ( Aand ( Aforall x ( Aand ( Aformulae ( phi [Tvar x; Tvar y] ) ) ( Aexists y ( Aand ( Aformulae (phi [Tvar z; Tfunc ( Func "f" ) [Tvar x; Tvar y]]) ) ( Aformulae ( phi [Tvar x; Tvar y] ) )
  ) ) ) ) ( Aformulae ( phi [Tvar x; Tvar x] ) )).

Check (Afpred (Predicate "P") [Tvar a]).


Require Import List.
Require Import FMapFacts.
Require Import Omega.
Require Import ListUtils.
Require Import OrderedTypeEx.
Require Import Arith.
Import ListNotations.
Set Implicit Arguments.

Module MapDefs (OT : UsualOrderedType) (M : S with Module E := OT).

  Module Map := M.
  Module MapFacts := WFacts_fun OT Map.
  Module MapProperties := WProperties_fun OT Map.
  Module MapOrdProperties := OrdProperties Map.

  Section MapUtilsFacts.

  Variable V : Type.

  Definition KIn := InA (@Map.eq_key V).
  Definition KNoDup := NoDupA (@Map.eq_key V).
  Definition map0 := Map.empty V.
  Definition map_keys (m : Map.t V) := map fst (Map.elements m).

  Lemma KNoDup_map_elements : forall (m : Map.t V) ,
     KNoDup (Map.elements m).
  Proof.
    intros; apply Map.elements_3w.
  Qed.
  Hint Resolve KNoDup_map_elements.

  Lemma mapsto_add : forall a v v' (m : Map.t V),
    Map.MapsTo a v (Map.add a v' m) -> v' = v.
  Proof.
    intros.
    apply Map.find_1 in H.
    erewrite Map.find_1 in H by (apply Map.add_1; hnf; auto).
    congruence.
  Qed.

  Lemma map_remove_cardinal : forall (m : Map.t V) k,
    (exists v, Map.MapsTo k v m) ->
    Map.cardinal (Map.remove k m) = Map.cardinal m - 1.
  Proof.
    intros. destruct H as [v].
    erewrite MapProperties.cardinal_2 with (m:=Map.remove k m) (m':=m) (x:=k) (e:=v).
    omega.
    apply Map.remove_1; hnf; auto.
    intro.
    destruct (OT.eq_dec k y); unfold OT.eq in *; subst.
    - rewrite MapFacts.add_eq_o; auto.
      erewrite Map.find_1; eauto.
    - rewrite MapFacts.add_neq_o; auto.
      rewrite MapFacts.remove_neq_o; auto.
  Qed.

  Lemma map_add_cardinal : forall (m : Map.t V) k v, ~ (exists v, Map.MapsTo k v m) ->
    Map.cardinal (Map.add k v m) = Map.cardinal m + 1.
  Proof.
    intros.
    erewrite MapProperties.cardinal_2 with (m:=m).
    omega.
    eauto.
    intro.
    reflexivity.
  Qed.

  Lemma map_add_dup_cardinal' : forall (m : Map.t V) k v, (exists v, Map.MapsTo k v m) ->
    Map.cardinal (Map.add k v m) = Map.cardinal (Map.remove k m) + 1.
  Proof.
    intros. destruct H.
    erewrite MapProperties.cardinal_2 with (m:=Map.remove k m).
    omega.
    apply Map.remove_1; hnf; auto.
    intro.
    destruct (OT.eq_dec k y); unfold OT.eq in *; subst.
    - rewrite MapFacts.add_eq_o; auto.
      rewrite MapFacts.add_eq_o; auto.
    - rewrite MapFacts.add_neq_o; auto.
      rewrite MapFacts.add_neq_o; try omega; auto.
      rewrite MapFacts.remove_neq_o; auto.
  Qed.

  Lemma map_add_dup_cardinal : forall (m : Map.t V) k v, (exists v, Map.MapsTo k v m) ->
    Map.cardinal (Map.add k v m) = Map.cardinal m.
  Proof.
    intros.
    replace (Map.cardinal m) with ((Map.cardinal m - 1) + 1).
    erewrite <- map_remove_cardinal; eauto.
    apply map_add_dup_cardinal'; auto.
    destruct H.
    assert (Map.cardinal m <> 0); try omega.
    erewrite MapProperties.cardinal_2 with (m:=Map.remove k m).
    omega.
    apply Map.remove_1; reflexivity.
    intro.
    destruct (OT.eq_dec k y); unfold OT.eq in *; subst.
    - rewrite MapFacts.add_eq_o; auto.
      erewrite Map.find_1; eauto.
    - rewrite MapFacts.add_neq_o; auto.
      rewrite MapFacts.remove_neq_o; auto.
  Qed.

  Lemma map_elements_hd_in : forall (m : Map.t V) k w l,
    Map.elements m = (k, w) :: l ->
    Map.In k m.
  Proof.
    intros.
    eexists; apply Map.elements_2.
    rewrite H.
    apply InA_cons_hd.
    constructor; hnf; eauto.
  Qed.

  Lemma mapeq_elements : forall m1 m2,
    @Map.Equal V m1 m2 -> Map.elements m1 = Map.elements m2.
  Proof.
    intros.
    apply MapOrdProperties.elements_Equal_eqlistA in H.
    generalize dependent (Map.elements m2).
    generalize dependent (Map.elements m1).
    induction l.
    - intros. inversion H. reflexivity.
    - intros. destruct l0; inversion H. subst.
      inversion H3. destruct a; destruct p; simpl in *; subst.
      f_equal; eauto.
  Qed.

  Hint Resolve MapProperties.eqke_equiv.

  Lemma KNoDup_NoDup: forall (l : list (Map.key * V)),
    KNoDup l -> NoDup (map fst l).
  Proof.
    induction l; simpl; intros; constructor.
    inversion H; subst.
    contradict H2.
    apply in_map_fst_exists_snd in H2; destruct H2.
    apply InA_alt.
    exists (fst a, x); intuition.
    destruct a; simpl in *.
    cbv; auto.
    inversion H; subst.
    apply IHl; auto.
  Qed.

  Lemma NoDupA_cons_inv : forall T (l : list T) m a,
    NoDupA m (a :: l) -> NoDupA m l.
  Proof.
    intros.
    rewrite <- app_nil_l.
    eapply NoDupA_split.
    rewrite app_nil_l. intuition eauto.
  Qed.

  Lemma KNoDup_cons_inv : forall l k,
    KNoDup (k :: l) -> KNoDup l.
  Proof.
    unfold KNoDup; intros.
    eapply NoDupA_cons_inv; eauto.
  Qed.

  Lemma map_fst_nodup: forall (ms : Map.t V),
    NoDup (map fst (Map.elements ms)).
  Proof.
    intros.
    apply KNoDup_NoDup.
    apply Map.elements_3w.
  Qed.

  Lemma InA_eqke_In : forall a v l,
    InA (Map.eq_key_elt (elt:=V)) (a, v) l -> In (a, v) l.
  Proof.
    induction l; intros; auto; inversion H; subst.
    inversion H1.
    destruct a0; simpl in *; hnf in *; subst; auto.
    simpl. right.
    apply IHl; auto.
  Qed.

  Lemma is_empty_eq_map0 : forall (m : Map.t V),
    Map.is_empty m = true -> Map.Equal m map0.
  Proof.
    unfold map0; intros.
    apply Map.is_empty_2 in H.
    hnf; intros.
    rewrite MapFacts.empty_o.
    apply MapFacts.not_find_in_iff.
    cbv in *; intros.
    destruct H0; eapply H; eauto.
  Qed.

  Lemma In_KIn : forall a (v : V) l,
    In a (map fst l) -> InA (@Map.eq_key V) (a, v) l.
  Proof.
    intros.
    apply in_map_fst_exists_snd in H.
    destruct H.
    apply InA_alt.
    exists (a, x).
    split; auto.
    hnf; auto.
  Qed.

  Lemma In_fst_KIn : forall a (l : list (Map.key * V)),
    In (fst a) (map fst l) -> KIn a l.
  Proof.
    intros; destruct a; simpl in *.
    eapply in_selN_exists in H.
    do 2 destruct H.
    rewrite map_length in H.
    apply InA_alt.
    eexists; split.
    2: apply in_selN_map; eauto.
    rewrite H0.
    hnf; auto.
    Unshelve.
    all : eauto.
  Qed.

  Lemma KIn_fst_In : forall a (l : list (Map.key * V)),
    KIn a l -> In (fst a) (map fst l).
  Proof.
    intros; destruct a; simpl in *.
    unfold KIn in *.
    apply InA_alt in H.
    inversion H.
    destruct x.
    intuition.
    unfold Map.eq_key in H1; simpl in *.
    rewrite H1.
    replace k0 with (fst (k0, v0)) by auto.
    eapply in_map; eauto.
  Qed.

  Lemma In_map_fst_MapIn : forall elt k m,
    In k (map fst (Map.elements (elt:=elt) m)) <-> Map.In k m.
  Proof.
    intros; split; intros.
    apply in_map_fst_exists_snd in H.
    destruct H.
    apply MapFacts.elements_in_iff.
    exists x.
    apply In_InA; auto.
    apply MapFacts.elements_in_iff in H.
    destruct H.
    apply InA_alt in H.
    destruct H; intuition.
    hnf in H0; simpl in *; intuition; subst.
    destruct x0; simpl in *; hnf in *; subst.
    generalize dependent (Map.elements m).
    induction l; intros; simpl; auto.
    inversion H1; intuition.
    destruct a; inversion H.
    tauto.
  Qed.

  Lemma map_add_comm : forall A k1 k2 (v1 v2 : A) m,
    k1 <> k2 ->
    Map.Equal (Map.add k1 v1 (Map.add k2 v2 m)) (Map.add k2 v2 (Map.add k1 v1 m)).
  Proof.
    intros; hnf; intro.
    destruct (OT.eq_dec y k1); destruct (OT.eq_dec y k2); subst; try congruence.
    rewrite MapFacts.add_eq_o by auto.
    rewrite MapFacts.add_neq_o by auto.
    rewrite MapFacts.add_eq_o; auto.
    setoid_rewrite MapFacts.add_eq_o at 2; auto.
    rewrite MapFacts.add_neq_o by auto.
    rewrite MapFacts.add_eq_o; auto.
    repeat rewrite MapFacts.add_neq_o; auto.
  Qed.

  Lemma map_add_repeat : forall a (v v' : V) m,
    Map.Equal (Map.add a v (Map.add a v' m)) (Map.add a v m).
  Proof.
    intros; hnf; intros.
    destruct (OT.eq_dec y a); subst; try congruence.
    rewrite MapFacts.add_eq_o by auto.
    rewrite MapFacts.add_eq_o; auto.
    rewrite MapFacts.add_neq_o by auto.
    repeat rewrite MapFacts.add_neq_o; auto.
  Qed.

  Lemma eq_key_dec : forall (a b : Map.key * V),
    {Map.eq_key a b} + {~ Map.eq_key a b}.
  Proof.
    intros; destruct a, b.
    destruct (OT.eq_dec k k0); subst.
    left; hnf; auto.
    right; hnf. tauto.
  Qed.

  Lemma map_empty_find_exfalso : forall a m (v : V),
    Map.find a m = Some v ->
    Map.Empty m -> False.
  Proof.
    intros.
    rewrite MapFacts.elements_o in H.
    apply MapProperties.elements_Empty in H0.
    rewrite H0 in H; simpl in H.
    congruence.
  Qed.

  Lemma map_remove_not_in_equal : forall a (m : Map.t V),
    ~ Map.In a m ->
    Map.Equal (Map.remove a m) m.
  Proof.
    intros.
    apply MapFacts.Equal_mapsto_iff; intros; split; intro.
    eapply Map.remove_3; eauto.
    apply MapFacts.remove_mapsto_iff; intuition.
    contradict H; subst.
    apply MapFacts.in_find_iff.
    apply Map.find_1 in H0.
    congruence.
  Qed.

  Lemma map_remove_not_in_elements_eq : forall a (m : Map.t V),
    ~ Map.In a m ->
    Map.elements (Map.remove a m) = Map.elements m.
  Proof.
    intros.
    erewrite mapeq_elements; eauto.
    apply map_remove_not_in_equal; auto.
  Qed.

  Lemma map_empty_find_none : forall (m : Map.t V) a,
    Map.Empty m ->
    Map.find a m = None.
  Proof.
    intros.
    rewrite MapFacts.elements_o.
    apply MapProperties.elements_Empty in H.
    rewrite H; simpl; auto.
  Qed.

  Lemma map_empty_not_In : forall (m : Map.t V) a,
    Map.Empty m ->
    ~ Map.In a m.
  Proof.
    intros.
    apply MapFacts.not_find_in_iff.
    apply map_empty_find_none; auto.
  Qed.

  Lemma find_none_empty : forall (m : Map.t V),
    (forall a, Map.find a m = None) ->
    Map.Empty m.
  Proof.
    intros; cbv; intros.
    eapply Map.find_1 in H0.
    congruence.
  Qed.

  Lemma map_remove_empty : forall (m : Map.t V) a,
    Map.Empty m ->
    Map.Empty (Map.remove a m).
  Proof.
    intros.
    eapply find_none_empty; intros.
    rewrite MapFacts.remove_o.
    destruct (OT.eq_dec a a0); auto.
    apply map_empty_find_none; auto.
  Qed.

  Lemma not_In_not_InA : forall a v (m : Map.t V),
    ~ Map.In a m ->
    ~ InA (@Map.eq_key_elt V) (a, v) (Map.elements m).
  Proof.
    intros.
    apply MapFacts.not_find_in_iff in H.
    intuition.
    eapply Map.elements_2 in H0.
    apply Map.find_1 in H0.
    congruence.
  Qed.

  Lemma map_remove_elements_not_in : forall m a (v : V),
    ~ InA (@Map.eq_key_elt V) (a, v) (Map.elements (Map.remove a m)).
  Proof.
    intros.
    apply not_In_not_InA.
    apply Map.remove_1; hnf; auto.
  Qed.

  Lemma not_in_remove_not_in : forall x y (m : Map.t V),
    ~ Map.In x m ->
    ~ Map.In x (Map.remove y m).
  Proof.
    intros.
    destruct (OT.eq_dec x y); hnf in *; subst.
    apply Map.remove_1; hnf; auto.
    destruct (MapFacts.In_dec (Map.remove y m) x).
    contradict H.
    eapply MapFacts.remove_neq_in_iff; eauto.
    auto.
  Qed.

  Lemma MapsTo_In : forall m a (v : V),
    Map.MapsTo a v m -> Map.In a m.
  Proof.
    intros.
    apply MapFacts.find_mapsto_iff in H.
    apply MapFacts.in_find_iff.
    congruence.
  Qed.

  Lemma In_MapsTo : forall (m : Map.t V) a,
    Map.In a m -> exists v, Map.MapsTo a v m.
  Proof.
    intros.
    apply MapFacts.in_find_iff.
    apply MapFacts.in_find_iff in H; auto.
  Qed.

  Lemma KIn_exists_elt_InA : forall l x,
    KIn x l ->
    exists v, InA (@Map.eq_key_elt V) (fst x, v) l.
  Proof.
    intros.
    apply InA_alt in H.
    destruct H as [y [? ?]].
    destruct x, y.
    cbv in H; subst.
    exists v0; simpl.
    apply In_InA; auto.
  Qed.

  Lemma length_elements_cardinal_gt : forall V (m : Map.t V) n,
    length (Map.elements m) > n ->
    Map.cardinal m > n.
  Proof.
    intros; rewrite Map.cardinal_1; auto.
  Qed.

  Lemma InA_filter : forall ents a f,
    InA (@Map.eq_key V) a (filter f ents) ->
    InA (@Map.eq_key V) a ents.
  Proof.
    induction ents; simpl; auto; intros.
    apply InA_cons.
    destruct (eq_key_dec a0 a); intuition.
    right; eapply IHents.
    destruct (f a); eauto.
    inversion H; subst; try congruence.
  Qed.

  Lemma KNoDup_filter : forall ents f,
    KNoDup ents ->
    KNoDup (filter f ents).
  Proof.
    induction ents; simpl; auto; intros.
    inversion H; subst.
    destruct (f a); intros; eauto.
    constructor.
    contradict H2.
    eapply InA_filter; eauto.
    apply IHents; eauto.
  Qed.

  Lemma map_cardinal_remove_le : forall (m : Map.t V) a,
    Map.cardinal (Map.remove a m) <= Map.cardinal m.
  Proof.
    intros.
    destruct (Map.find a m) eqn: Heq.
    rewrite map_remove_cardinal.
    omega.
    eexists; eapply Map.find_2; eauto.
    erewrite MapProperties.cardinal_m; eauto.
    apply map_remove_not_in_equal.
    apply MapFacts.not_find_in_iff; auto.
  Qed.

  End MapUtilsFacts.

  (* Coq bug : instance doesn't work well with section arguments *)
  Instance map_elements_proper {V} :
    Proper (Map.Equal ==> eq) (@Map.elements V).
  Proof.
    unfold Proper, respectful; intros; subst.
    apply mapeq_elements; auto.
  Qed.

End MapDefs.

Require Import FMapAVL.

Module AddrMap_AVL := FMapAVL.Make(Nat_as_OT).
Module AddrMap := MapDefs Nat_as_OT AddrMap_AVL.

Require Import MSetAVL.
Require Import MSetFacts.
Require Import Structures.OrdersEx.

Module SetDefs (OT : OrderedType) (M : S with Module E := OT).
  Module SS := M.
  Module SetFacts := WFacts SS.

  Lemma subset_add: forall x s,
    SS.Subset s (SS.add x s).
  Proof.
    cbv.
    intros.
    rewrite M.add_spec.
    auto.
  Qed.

  Lemma subset_add_in_l: forall s v s',
    SS.In v s' ->
    SS.Subset s s' ->
    SS.Subset (SS.add v s) s'.
  Proof.
    cbv [SS.Subset].
    intros.
    rewrite SS.add_spec in *.
    intuition subst; eauto.
    match goal with H: _ |- _ => rewrite H end.
    auto.
  Qed.

  Lemma set_in_fold_right_add: forall x l s,
    In x l ->
    SS.In x (fold_right SS.add s l).
  Proof.
    induction l; cbn.
    intuition.
    intros.
    rewrite SS.add_spec.
    intuition subst; eauto.
    left.
    reflexivity.
  Qed.

  Lemma in_fold_right_iff: forall x l,
    InA OT.eq x l <-> SS.In x (fold_right SS.add SS.empty l).
  Proof.
    induction l; cbn; auto.
    intuition.
    inversion H.
    rewrite SetFacts.empty_iff in H.
    intuition.
    rewrite SS.add_spec in *.
    intuition.
    inversion H1; subst; auto.
  Qed.

  Lemma in_fold_right_remove: forall l a s,
    SS.In a (fold_right SS.remove s l) ->
    SS.In a s /\ ~InA SS.E.eq a l.
  Proof.
    induction l; cbn; intros.
    intuition auto.
    inversion H0.
    rewrite SS.remove_spec in *.
    intuition subst.
    eapply IHl; eauto.
    inversion H; subst.
    congruence.
    eapply IHl; eauto.
  Qed.

  Lemma in_fold_right_not_added: forall l a s,
    ~InA SS.E.eq a l -> SS.In a (fold_right SS.add s l) ->
    SS.In a s.
  Proof.
    induction l; cbn; intros.
    auto.
    rewrite SS.add_spec in *.
    intuition eauto.
    contradiction H.
    eauto.
  Qed.

  Lemma in_fold_right_remove_notin: forall l a s,
    ~InA SS.E.eq a l -> SS.In a s -> SS.In a (fold_right SS.remove s l).
  Proof.
    induction l; cbn; intros.
    auto.
    rewrite SS.remove_spec.
    intuition auto.
  Qed.

  Lemma subset_fold_add_remove_tail: forall n l s t,
    SS.Subset s (fold_right SS.add t l) ->
    SS.Subset (fold_right SS.remove s (skipn n l)) (fold_right SS.add t (firstn n l)).
  Proof.
    cbv [SS.Subset].
    induction n, l; cbn; intros; auto.
    rewrite SS.remove_spec in *.
    intuition eauto.
    setoid_rewrite SS.add_spec in H.
    eapply in_fold_right_remove in H1.
    intuition eauto.
    eapply H in H0.
    intuition auto.
    eapply in_fold_right_not_added; eauto.
    rewrite SS.add_spec.
    eapply in_fold_right_remove in H0.
    intuition idtac.
    eapply H in H1.
    rewrite SS.add_spec in *.
    intuition auto.
    right.
    eapply IHn; eauto.
    eapply in_fold_right_remove_notin; eauto.
  Qed.

  Lemma subset_inter_l: forall s t,
    SS.Subset (SS.inter s t) s.
  Proof.
    cbv; intros.
    rewrite M.inter_spec in *.
    intuition.
  Qed.

  Lemma subset_inter_r: forall s t,
    SS.Subset (SS.inter s t) t.
  Proof.
    cbv; intros.
    rewrite M.inter_spec in *.
    intuition.
  Qed.

  Lemma subset_empty: forall s,
    SS.Subset SS.empty s.
  Proof.
    cbv. intros.
    rewrite SetFacts.empty_iff in *.
    intuition.
  Qed.

End SetDefs.

Module AddrSet_AVL := MSetAVL.Make (OrdersEx.Nat_as_OT).
Module AddrSet := SetDefs OrdersEx.Nat_as_OT AddrSet_AVL.

Module AddrSetFacts.

  Lemma nodup_elements: forall t,
    NoDup (AddrSet_AVL.elements t).
  Proof.
    intros.
    rewrite <- NoDup_NoDupA_eq.
    apply AddrSet_AVL.elements_spec2w.
    intuition.
  Qed.

  Lemma elements_spec1 : forall s x,
    In x (AddrSet_AVL.elements s) <-> AddrSet_AVL.In x s.
  Proof.
    intros.
    rewrite <- AddrSet_AVL.elements_spec1.
    rewrite InA_alt.
    intuition.
    eexists; eauto.
    destruct H; intuition (subst; auto).
  Qed.

End AddrSetFacts.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.

Section TrivialSemantics.

Context {Sigma: PropositionalVariables}.

Existing Instances L minL pL.

Definition model: Type := Var -> Prop.

Fixpoint denotation (x: expr Sigma): Ensemble model :=
  match x with
  | andp y z => Semantics.andp (denotation y) (denotation z)
  | orp y z => Semantics.orp (denotation y) (denotation z)
  | impp y z => Semantics.impp (denotation y) (denotation z)
  | falsep => Semantics.falsep
  | varp p => fun m => m p
  end.

Instance MD: Model :=
  Build_Model model.

Instance SM: Semantics L MD :=
  Build_Semantics L MD denotation.

Instance tminSM: TrivialMinimunSemantics L MD SM.
Proof.
  constructor.
  simpl; intros.
  apply Same_set_refl.
Qed.

Instance tpSM: TrivialPropositionalSemantics L MD SM.
Proof.
  constructor.
  + simpl; intros.
    apply Same_set_refl.
  + simpl; intros.
    apply Same_set_refl.
  + simpl; intros.
    apply Same_set_refl.
Qed.

End TrivialSemantics.


Require
  MathClasses.implementations.stdlib_binary_integers MathClasses.theory.integers MathClasses.orders.semirings.
Require Import
  Coq.Setoids.Setoid Coq.Numbers.Natural.SpecViaZ.NSig Coq.Numbers.Natural.SpecViaZ.NSigNAxioms Coq.NArith.NArith Coq.ZArith.ZArith Coq.Program.Program Coq.Classes.Morphisms
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.integers
  MathClasses.interfaces.orders MathClasses.interfaces.additional_operations.

Module NType_Integers (Import anyN: NType).

Module axioms := NTypeIsNAxioms anyN.

Instance NType_equiv : Equiv t := eq.
Instance NType_plus : Plus t := add.
Instance NType_0 : Zero t := zero.
Instance NType_1 : One t := one.
Instance NType_mult : Mult t := mul.

Instance: Setoid t | 10 := {}.

Program Instance: ∀ x y: t, Decision (x = y) := λ x y, match compare x y with
  | Eq => left _
  | _ => right _
  end.
Next Obligation.
  apply Zcompare_Eq_eq. now rewrite <-spec_compare.
Qed.
Next Obligation.
  rewrite spec_compare in *. intros E.
  apply Zcompare_Eq_iff_eq in E. auto.
Qed.

Ltac unfold_equiv := unfold equiv, NType_equiv, eq in *.

Lemma  NType_semiring_theory: semi_ring_theory zero one add mul eq.
Proof. repeat split; repeat intro; axioms.zify; auto with zarith. Qed.

Instance: SemiRing t | 10 := rings.from_stdlib_semiring_theory NType_semiring_theory.

Instance inject_NType_N: Cast t N := to_N.

Instance: Proper ((=) ==> (=)) to_N.
Proof. intros x y E. unfold equiv, NType_equiv, eq in E. unfold to_N. now rewrite E. Qed.

Instance: SemiRing_Morphism to_N.
Proof.
  repeat (split; try apply _); unfold to_N; intros.
     now rewrite spec_add, Z2N.inj_add by apply spec_pos.
    unfold mon_unit, zero_is_mon_unit, NType_0. now rewrite spec_0.
   now rewrite spec_mul, Z2N.inj_mul by apply spec_pos.
  unfold mon_unit, one_is_mon_unit, NType_1. now rewrite spec_1.
Qed.

Instance inject_N_NType: Cast N t := of_N.
Instance: Inverse to_N := of_N.

Instance: Surjective to_N.
Proof.
  split; try apply _. intros x y E.
  rewrite <-E. unfold to_N, inverse, compose. rewrite spec_of_N.
  apply N2Z.id.
Qed.

Instance: Injective to_N.
Proof.
  split; try apply _. intros x y E.
  unfold equiv, NType_equiv, eq. unfold to_N in E.
  rewrite <-(Z2N.id (to_Z x)), <-(Z2N.id (to_Z y)) by now apply spec_pos.
  now rewrite E.
Qed.

Instance: Bijective to_N := {}.

Instance: Inverse of_N := to_N.

Instance: Bijective of_N.
Proof. apply jections.flip_bijection. Qed.

Instance: SemiRing_Morphism of_N.
Proof. change (SemiRing_Morphism (to_N⁻¹)). split; apply _. Qed.

Instance: NaturalsToSemiRing t := naturals.retract_is_nat_to_sr of_N.
Instance: Naturals t := naturals.retract_is_nat of_N.

Instance inject_NType_Z: Cast t Z := to_Z.

Instance: Proper ((=) ==> (=)) to_Z.
Proof. now intros x y E. Qed.

Instance: SemiRing_Morphism to_Z.
Proof.
  repeat (split; try apply _).
     exact spec_add.
    exact spec_0.
   exact spec_mul.
  exact spec_1.
Qed.

(* Order *)
Instance  NType_le: Le t := le.
Instance  NType_lt: Lt t := lt.

Instance: Proper ((=) ==> (=) ==> iff) NType_le.
Proof.
  intros ? ? E1 ? ? E2. unfold NType_le, le. unfold equiv, NType_equiv, eq in *.
  now rewrite E1, E2.
Qed.

Instance: SemiRingOrder NType_le.
Proof.
  apply (semirings.projected_srorder to_Z).
   reflexivity.
  intros x y E. exists (sub y x).
  unfold_equiv. rewrite spec_add, spec_sub.
  rewrite Zmax_r by now apply Z.le_0_sub.
  ring.
Qed.

Instance: OrderEmbedding to_Z.
Proof. now repeat (split; try apply _). Qed.

Instance: TotalRelation NType_le.
Proof. now apply (maps.projected_total_order to_Z). Qed.

Instance: FullPseudoSemiRingOrder NType_le NType_lt.
Proof.
  rapply semirings.dec_full_pseudo_srorder.
  intros x y. split.
   intro. split.
    apply axioms.lt_eq_cases. now left.
   intros E. destruct (irreflexivity (<) (to_Z x)). now rewrite E at 2.
  intros [E1 E2].
  now destruct (proj1 (axioms.lt_eq_cases _ _) E1).
Qed.

(* Efficient comparison *)
Program Instance: ∀ x y: t, Decision (x ≤ y) := λ x y, match (compare x y) with
  | Gt => right _
  | _ => left _
  end.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Zcompare_spec (to_Z x) (to_Z y)); try discriminate.
  now apply orders.lt_not_le_flip.
Qed.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Zcompare_spec (to_Z x) (to_Z y)); try discriminate; try intuition.
   now apply Zeq_le.
  now apply orders.lt_le.
Qed.

Lemma NType_succ_1_plus x : succ x = 1 + x.
Proof.
  unfold_equiv. rewrite spec_succ, rings.preserves_plus, rings.preserves_1.
  now rewrite commutativity.
Qed.

Lemma NType_two_2 : two = 2.
Proof.
  unfold_equiv. rewrite spec_2.
  now rewrite rings.preserves_plus, rings.preserves_1.
Qed.

(* Efficient [nat_pow] *)
Program Instance NType_pow: Pow t t := pow.

Instance: NatPowSpec t t NType_pow.
Proof.
  split.
    intros x1 y1 E1 x2 y2 E2.
    now apply axioms.pow_wd.
   intros x1. apply axioms.pow_0_r.
  intros x n.
  unfold_equiv. unfold "^", NType_pow.
  rewrite <-axioms.pow_succ_r by (red; rewrite spec_0; apply spec_pos).
  now rewrite NType_succ_1_plus.
Qed.

(* Efficient [shiftl] *)
Program Instance NType_shiftl: ShiftL t t := shiftl.

Instance: ShiftLSpec t t NType_shiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x y.
  unfold additional_operations.pow, NType_pow, additional_operations.shiftl, NType_shiftl.
  unfold_equiv. simpl.
  rewrite rings.preserves_mult, spec_pow.
  rewrite spec_shiftl, Z.shiftl_mul_pow2 by apply spec_pos.
  now rewrite <-NType_two_2, spec_2.
Qed.

(* Efficient [shiftr] *)
Program Instance: ShiftR t t := shiftr.

End NType_Integers.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal82.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
Cons n x.

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) (Cons (Succ Zero) Nil))) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil))))) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


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

(**********************************************************************)
(*                Intensional Lambda Calculus                         *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                           Terms.v                                  *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.
Require Import Test.

(* lambda terms with operators and using de Bruijn's indices *)

Inductive operator :=
| Sop
| Fop
.

Inductive lamSF:  Set :=
  | Ref : nat -> lamSF
  | Op  : operator -> lamSF
  | Abs : lamSF -> lamSF
  | App : lamSF -> lamSF -> lamSF
.

Lemma decidable_term_equality : forall (M N: lamSF), M = N \/ M<> N.
Proof.
induction M; induction N; intros; try (left; congruence); try(right; congruence).
elim(decidable_nats n0 n); auto.
intro; right; intro; congruence.
case o; case o0; split_all; try (left; split_all; fail);  right; split_all.
elim(IHM N); split_all.
left; congruence.
right; congruence.
elim(IHM1 N1); elim(IHM2 N2); auto;
(right; congruence; fail) || left; congruence.
Qed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with

      (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Fixpoint lift_rec (L : lamSF) : nat -> nat -> lamSF :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
  | Abs M => Abs (lift_rec M (S k) n)
  end.

Definition lift (n : nat) (N : lamSF) := lift_rec N 0 n.

(* Substitution *)

Definition insert_Ref (N : lamSF) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : lamSF) : lamSF -> nat -> lamSF :=
  fun (N : lamSF) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  | Abs M => Abs (subst_rec M N (S k))
  end.

Definition subst (N M : lamSF) := subst_rec M N 0.