(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Properties about sets of sets, and maps over sets *)

Require Import Utils_WF.
Require Import DisjointSets.
Require Import DKA_Definitions.
Require Import MyFSets.
Require Import MyFSetProperties.
Require Import MyFMapProperties.
Require Import Common.

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

Module StateSetMap' := FMapAVL.Make StateSet. Module StateSetMap := FMapHide StateSetMap'.
Module StateSetMapProps := MyMapProps StateSetMap.
Notation statesetmap := StateSetMap.t.

(* this module is used in proofs only, no need to go to AVL sets *)
Module StateSetSet' := FSetList.Make StateSet. Module StateSetSet := FSetHide StateSetSet'.
Module StateSetSetProps := MySetProps StateSetSet.
Notation statesetset := StateSetSet.t.

(** map a function [f] over a set of statesets *)
Definition statesetset_map f t :=
  StateSetSet.fold (fun x acc => StateSetSet.add (f x) acc) t StateSetSet.empty.

(** properties of the above function *)
Section sssm.
  Variable t0: StateSetSet.t.
  Variable f: stateset -> stateset.

  Lemma statesetset_map_in p:
    StateSetSet.In p (statesetset_map f t0) -> exists2 q, StateSetSet.In q t0 & StateSet.Equal (f q) p.
  Proof.
    unfold statesetset_map.
    apply StateSetSetProps.Props.fold_rec_nodep. StateSetSetProps.setdec.
    intros q a Hq IH.  StateSetSetProps.Facts.set_iff. intros [Hp|Hp]; eauto.
  Qed.

  Hypothesis Hf: forall p q, StateSetSet.In p t0 -> StateSetSet.In q t0 ->
    (StateSet.Equal (f p) (f q) <-> StateSet.Equal p q).

  Lemma statesetset_map_cardinal:
    StateSetSet.cardinal (statesetset_map f t0) = StateSetSet.cardinal t0.
  Proof.
    refine (proj2 (StateSetSetProps.Props.fold_rec_bis
      (P:=fun t a => (forall p, StateSetSet.In p t0 -> (StateSetSet.In (f p) a <-> StateSetSet.In p t)) /\
        ((forall p, StateSetSet.In p t -> StateSetSet.In p t0) ->
          StateSetSet.cardinal a = StateSetSet.cardinal t)) _ _ _) _); trivial.
    intros. setoid_rewrite <- H. trivial.
    split; trivial. StateSetSetProps.setdec.
    intros p a t' Hp Hp' [IH IHc]. split.
    intros q Hq.
    StateSetSetProps.Facts.set_iff. specialize (IH q Hq). rewrite Hf by auto. tauto.
    intros Ht'.
    rewrite (StateSetSetProps.Props.cardinal_2 (s:=a) (x:=f p)); auto with set.
    symmetry. rewrite (StateSetSetProps.Props.cardinal_2 (s:=t') (x:=p)); auto with set.
    symmetry. rewrite IHc; auto. intros q Hq. apply Ht'. StateSetSetProps.setdec.
    rewrite IH; auto.
  Qed.
End sssm.

(** the only set whose all elements are below 0 is the empty set *)
Lemma below0_empty p: setbelow p (num_of_nat 0) -> StateSet.Equal p StateSet.empty.
Proof.
  intro H.
  apply StateSetProps.Props.empty_is_empty_1.
  rewrite StateSetProps.Props.elements_Empty.
  remember (StateSet.elements p) as l. destruct l as [|i l]. trivial.
  specialize (H i). apply apply in H. exfalso. clear - H. num_lia.
  rewrite StateSetProps.Facts.elements_iff. rewrite <- Heql. auto.
Qed.

(** technical lemmas for using FSet lemmas *)
Lemma compat_split s: compat_bool StateSet.Equal (fun p => StateSet.mem s p).
Proof. intros ? ? H. rewrite H. trivial. Qed.
Lemma compat_negsplit s: compat_bool StateSet.Equal (fun p => negb (StateSet.mem s p)).
Proof. intros ? ? H. rewrite H. trivial. Qed.
Local Hint Resolve compat_split compat_negsplit : core.

Ltac solve_p1 := intros ? ? H'; rewrite H'; reflexivity.

(** bound of the cardinal of a set of bounded sets *)
Lemma card_pset (s: nat) t: (forall p, StateSetSet.In p t -> setbelow p (state_of_nat s)) ->
  (StateSetSet.cardinal t <= power s)%nat.
Proof.
  revert t. induction s; intros t H; simpl.
  (* the set of set contains at most the empty set *)
   destruct (StateSetSetProps.Props.cardinal_0 t) as (l&Hl&Hlt&->).
   setoid_rewrite Hlt in H. clear Hlt. revert H Hl.
   destruct l as [|x [| y q]]; intros H Hl; simpl; auto with arith.
   exfalso. inversion_clear Hl. apply H0. left. clear H0 H1.
   rewrite (@below0_empty x), (@below0_empty y). reflexivity.
    apply H. right. left. reflexivity.
    apply H. left. reflexivity.

  (* for the inductive case, we partition the set according to the presence of [s] *)
  pose (t0 := StateSetSet.filter (fun p => StateSet.mem (state_of_nat s) p) t).
  pose (t1 := StateSetSet.filter (fun p => negb (StateSet.mem (state_of_nat s) p)) t).
  pose (t0' := statesetset_map (StateSet.remove (state_of_nat s)) t0).
  setoid_replace t with (StateSetSet.union t0 t1).
  rewrite StateSetSetProps.Props.union_cardinal.
  replace (StateSetSet.cardinal t0) with (StateSetSet.cardinal t0').
  assert (IH1 := IHs t1). apply apply in IH1.
  assert (IH0 := IHs t0'). apply apply in IH0.
  lia.

   subst t0' t0. clear t1 IH1 IH0. intros p Hp.
   destruct (statesetset_map_in Hp) as [q Hq Hq']. revert Hq.
   rewrite StateSetSetProps.mem_iff.
   rewrite StateSetSetProps.EqProps.filter_mem by solve_p1.
   case_eq (StateSetSet.mem q t). 2:(intros; discriminate). simpl. intros Hq Hq''.
   intros x Hx.
   destruct (eq_num_dec x s). rewrite e, <- Hq' in Hx.
    exfalso. revert Hx. clear. StateSetProps.setdec.
   rewrite <- StateSetSetProps.mem_iff in Hq.
   rewrite <- StateSetProps.mem_iff in Hq''.
   specialize (H q Hq x). apply apply in H. clear - H n. num_lia. StateSetProps.setdec.

   subst t1. clear t0 t0' IH1. intro p.
   rewrite StateSetSetProps.mem_iff.
   rewrite StateSetSetProps.EqProps.filter_mem by solve_p1.
   case_eq (StateSetSet.mem p t). 2:(intros; discriminate). simpl. intros Hp Hp'.
   intros x Hx.
   destruct (eq_num_dec x s). subst. apply StateSet.mem_1 in Hx. rewrite Hx in Hp'. discriminate.
   apply StateSetSet.mem_2 in Hp. pose (H' := H p Hp x Hx). num_lia.

  subst t0' t0. clear t1.
  apply statesetset_map_cardinal.
  intros p q.
  setoid_rewrite StateSetSetProps.mem_iff.
  do 2 rewrite StateSetSetProps.EqProps.filter_mem by solve_p1.
  case (StateSetSet.mem p t). 2: (intros; discriminate).
  case (StateSetSet.mem q t). 2: (intros; discriminate). simpl.
  setoid_rewrite <- StateSetProps.mem_iff. try StateSetProps.setdec. (* BUG setdec*)
   split; intro Hpq.
    clear - H0 H1 Hpq. intro x.
     generalize (Hpq x). clear Hpq. StateSetProps.set_iff.
     destruct (eq_num_dec s x). subst. firstorder. firstorder. rewrite Hpq. reflexivity.

  subst t0 t1. clear t0'. intro x.
  setoid_rewrite StateSetSetProps.mem_iff.
  do 2 rewrite StateSetSetProps.EqProps.filter_mem by solve_p1.
  StateSetProps.mem_analyse; StateSetSetProps.mem_analyse; simpl; firstorder congruence.

  subst t0 t1. clear t0'. intro x.
  rewrite StateSetSetProps.EqProps.union_filter by trivial.
  setoid_rewrite StateSetSetProps.mem_iff.
  rewrite StateSetSetProps.EqProps.filter_mem by solve_p1.
  rewrite andb_comm. StateSetProps.mem_analyse; reflexivity.
Qed.

(** domain of a statesetmap, to apply the above results to maps : *)
Section domain.
  Variable T: Type.

  Definition domain t := StateSetMap.fold (fun p (np: T) a => StateSetSet.add p a) t StateSetSet.empty.

  Lemma domain_spec: forall x t, StateSetSet.In x (domain t) <-> StateSetMap.In x t.
  Proof.
    intros x t. unfold domain.
    refine (StateSetMapProps.fold_rec_bis (P:=fun m a => StateSetSet.In x a <-> StateSetMap.In x m) _ _ _).
     intros. rewrite <- H. assumption.
     StateSetSetProps.set_iff. StateSetMapProps.map_iff. tauto.
     intros. StateSetSetProps.set_iff. StateSetMapProps.map_iff. tauto.
  Qed.

  Lemma cardinal_domain t: StateSetSet.cardinal (domain t) = StateSetMap.cardinal t.
  Proof.
    refine (proj2 (StateSetMapProps.fold_rec_bis
      (P:=fun t a => (forall p, StateSetSet.In p a <-> StateSetMap.In p t) /\
                     StateSetSet.cardinal a = StateSetMap.cardinal t) _ _ _)).
    intros. setoid_rewrite <- H. trivial.
    split; trivial. split. StateSetSetProps.setdec. StateSetMapProps.map_iff. tauto.
    intros p np a t' Hp Hp' [IH IHc]. split.
    intro q. StateSetSetProps.set_iff. StateSetMapProps.map_iff. specialize (IH q). tauto.
    rewrite (StateSetMapProps.cardinal_2 Hp') by (intro; reflexivity).
    rewrite (StateSetSetProps.Props.cardinal_2 (s:=a) (x:=p)). congruence. rewrite IH; trivial.
    auto with set.
  Qed.

End domain.

(** Results about the number of classes in a partition (for termination of the equivalence check) *)

Module DS := DisjointSets.PosDisjointSets.
Module DSUtils := DisjointSets.DSUtils Numbers.Positive DS.
Import DSUtils.Notations.

Definition add_classes t := fun i => StateSetSet.add (DS.class_of t (num_of_nat i)).
Fixpoint classes size t :=
  match size with
    | O => StateSetSet.empty
    | Datatypes.S n => add_classes t n (classes n t)
  end.
Definition measure size t := StateSetSet.cardinal (classes size t).

Lemma classes_compat: forall size `{DS.WF} {t'} `{DS.WF t'}, t [=T=] t' ->
  StateSetSet.Equal (classes size t) (classes size t').
Proof.
   induction size as [|s IHs]; intros t t' H H'' Ht; simpl.
    reflexivity.
    apply StateSetSetProps.add_m; trivial.
    apply DSUtils.class_of_compat'; ti_auto.
    apply IHs; trivial.
Qed.

Lemma measure_compat: forall size `{DS.WF} {t'} `{DS.WF t'}, t [=T=] t' -> measure size t = measure size t'.
Proof.
  intros.
  apply StateSetSetProps.Props.Equal_cardinal, classes_compat; trivial.
Qed.

Section protect.
(* Local Hint Resolve @DS.union_WF @DS.empty_WF: typeclass_instances. *)

Lemma measure_union_idem: forall `{DS.WF} size x y, {{t}} x y ->
  measure size (DS.union t x y) = measure size t.
Proof.
  intros. eapply measure_compat; ti_auto. symmetry. apply DSUtils.eq_union; auto.
Qed.

Lemma in_classes: forall t size x,
  StateSetSet.In x (classes size t) <-> exists2 y, y<size & StateSet.Equal x (DS.class_of t (state_of_nat y)).
Proof.
  induction size; intros x; simpl; unfold add_classes; StateSetSetProps.set_iff.
   intuition. destruct H. lia.
   rewrite IHsize. clear IHsize.
   completer idtac.
    symmetry in H. eauto with lia.
    destruct H. eauto with lia.
    destruct H as [y Hy H]. destruct (eq_nat_dec y size). subst.
     symmetry in H. auto.
     right. exists y. lia. assumption.
Qed.

Lemma in_classes_empty_below: forall size x,
  StateSetSet.In x (classes size DS.empty) -> setbelow x (state_of_nat size).
Proof.
  intros size x H z.
  rewrite in_classes in H. destruct H as [y Hy H].
  rewrite H. rewrite DSUtils.class_of_empty. StateSetProps.set_iff.
  intro. psubst. num_lia.
Qed.

Lemma add_classes_empty: forall x a,
  StateSetSet.Equal (add_classes DS.empty x a) (StateSetSet.add (StateSet.singleton x) a).
Proof.
  intros. unfold add_classes.
  rewrite DSUtils.class_of_empty.
  reflexivity.
Qed.

Lemma measure_empty: forall size, measure size DS.empty = size.
Proof.
  unfold measure. induction size as [|s IHs].
   reflexivity.
   simpl. rewrite add_classes_empty.
   rewrite StateSetSetProps.Props.add_cardinal_2. rewrite IHs. reflexivity.
   clear IHs. induction s; simpl.
    StateSetSetProps.setdec.
    rewrite add_classes_empty. StateSetSetProps.set_iff.
    clear. intros [H|H].
     eapply proj1 in H. apply apply in H. 2: rewrite StateSetProps.singleton_iff; trivial.
     revert H. StateSetProps.set_iff. intro. psubst.
     revert H. generalize (statesetelt_of_nat s). intro. num_lia.
     apply in_classes_empty_below in H. specialize (H (Pos.succ (state_of_nat s))).
     apply apply in H. num_lia. auto with set.
Qed.

Lemma classes_union_strict: forall `{DS.WF} size (x y: state),
  x < size -> y < size ->
  StateSetSet.Equal
  (classes size (DS.union t x y))
  (StateSetSet.add (StateSet.union (DS.class_of t x) (DS.class_of t y))
    (StateSetSet.remove (DS.class_of t x)
      (StateSetSet.remove (DS.class_of t y)
      (classes size t)))).
Proof.
  intros t Ht size x y Hx Hy s.
   rewrite in_classes.
   StateSetSetProps.set_iff. rewrite in_classes.
   split.
    intros [z Hz H].
    destruct (@DSUtils.sameclass_spec t Ht x (state_of_nat z)) as [Hxz|Hxz].
     rewrite DSUtils.class_of_union_1 in H by auto. symmetry in H. auto.
     destruct (@DSUtils.sameclass_spec t Ht y (state_of_nat z)) as [Hyz|Hyz].
      rewrite DSUtils.class_of_union_1 in H by auto. symmetry in H. auto.
      rewrite DSUtils.class_of_union_2 in H by auto. right.
       repeat split. eauto.
       rewrite H. intro F. apply DSUtils.class_of_injective in F; auto.
       rewrite H. intro F. apply DSUtils.class_of_injective in F; auto.

    intros [H|[[[z Hz H] Hys]Hxs]].
     exists x; trivial. symmetry in H. rewrite DSUtils.class_of_union_1; auto. left. bool_simpl. reflexivity.
     exists z; trivial. rewrite DSUtils.class_of_union_2; auto.
      intro F. apply Hxs. rewrite F, H. reflexivity.
      intro F. apply Hys. rewrite F, H. reflexivity.
Qed.

Lemma add_cardinal: forall s s' x,
  Datatypes.S (StateSetSet.cardinal s) < StateSetSet.cardinal s' ->
  StateSetSet.cardinal (StateSetSet.add x s) < StateSetSet.cardinal s'.
Proof.
  intros. destruct (StateSetSetProps.mem_spec x s) as [Hx|Hx].
   rewrite StateSetSetProps.Props.add_cardinal_1; auto with lia.
   rewrite StateSetSetProps.Props.add_cardinal_2; auto.
Qed.

Lemma rem_cardinal_lt: forall s x,
  StateSetSet.In x s ->
  StateSetSet.cardinal (StateSetSet.remove x s) < StateSetSet.cardinal s.
Proof.
  intros. rewrite <- (StateSetSetProps.Props.remove_cardinal_1 H) ; auto.
Qed.

Lemma measure_union_strict: forall `{DS.WF} size t' (x y: state),
  x < size -> y < size ->
  DS.equiv t x y = (false,t') -> measure size (DS.union t x y) < measure size t.
Proof.
  intros. unfold measure.
  rewrite classes_union_strict; try eassumption.
  apply add_cardinal. rewrite StateSetSetProps.Props.remove_cardinal_1. apply rem_cardinal_lt.
   rewrite in_classes. exists y; trivial. bool_simpl; reflexivity.
   apply StateSetSet.remove_2.
    intro F. apply DSUtils.class_of_injective in F; trivial.
    apply (@Equivalence_Symmetric _ _ (@DS.sameclass_Equivalence _ H)) in F.
    rewrite <- DS.sameclass_equiv, H2 in F; trivial. discriminate.
    rewrite in_classes. exists x; trivial. bool_simpl; reflexivity.
Qed.

End protect.


Require Import BaseTactics.
Require Import ILogic ILEmbed.
Require Import List.
Require Import Containers.Maps MapInterface MapFacts.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Definition find_prop (A : Type) := (list Prop * A)%type.

Definition find_prop_unop {A B : Type} (op : A -> B) (a : option (find_prop A)) :
option (find_prop B) :=
match a with
	| Some a => Some (fst a, op (snd a))
	| None => None
end.

  Definition find_prop_binop {A B C : Type} (op : A -> B -> C) (a : option (find_prop A))
  	(b: option (find_prop B)) : option (find_prop C) :=
  	match a, b with
  	  | Some a, Some b => Some (fst a ++ fst b, op (snd a) (snd b))
  	  | _,      _      => None
  	end.

  	Definition find_prop_create {A : Type} (a : option A) : option (find_prop A) :=
  	match a with
  		| Some a => Some (nil, a)
  		| None   => None
  	end.

 	Fixpoint find_prop_eval_and_aux {A : Type} {ILA : ILogicOps A} {H: EmbedOp Prop A} (Ps : list Prop) (a : A) : A :=
 		match Ps with
 			| nil     => a
 			| P :: Ps => P /\\ (find_prop_eval_and_aux Ps a)
 		end.

	Definition find_prop_eval_and {A : Type} {ILA : ILogicOps A} {H: EmbedOp Prop A} (p : find_prop A) :=
		find_prop_eval_and_aux (fst p) (snd p).

Fixpoint pull_and {A : Type} {ILA : ILogicOps A}
                  (t : @deep_op A _) (de_env : env A) (tac_env : env (find_prop A)) : option (find_prop A) :=
match t with
	| t_and t1 t2   => find_prop_binop land (pull_and t1 de_env tac_env) (pull_and t2 de_env tac_env)
	| t_and_inj B _ _ _ _ _ _ a b => find_prop_binop lembedand (pull_and a (env_empty B) (env_empty (find_prop B)))
	                         (pull_and b de_env tac_env)
	| t_and_prop _ _ a b =>
		match deep_op_eval (env_empty Prop) a, pull_and b de_env tac_env with
			| Some a, Some b => Some (a::(fst b), snd b)
			| _, _           => None
		end
    | t_unop n p =>
    	match ((fst tac_env) [n]) with
    		| Some f => unop_option f (pull_and p de_env tac_env)
    		| None => None
    	end
	| t_binop n p q =>
		match ((snd tac_env) [n]) with
			| Some f => binop_option f (pull_and p de_env tac_env) (pull_and q de_env tac_env)
			| None => None
		end
    | _ => match deep_op_eval de_env t with
    	     | Some t => Some (nil, t)
    	     | None   => None
    	   end
end.

Section PullAndRight.

	Lemma find_prop_unop_sound_ar {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B}
						{HEA : Embed Prop A} {HEB : Embed Prop B}
	        (Ps : list Prop) (f : A) (op : A -> B)
        (Hop : forall (P : Prop) p, P /\\ op p |-- op (P /\\ p)) :
	      find_prop_eval_and_aux Ps (op f) |-- op (find_prop_eval_and_aux Ps f).
	Proof.
		induction Ps.
		simpl. reflexivity.
		simpl in *. rewrite <- Hop.
		apply lpropandL; intro H. apply lpropandR; [apply H|].
		rewrite IHPs. reflexivity.
	Qed.

 Lemma find_prop_binop_sound_ar {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B} {HC : EmbedOp Prop C}
						{HAE : Embed Prop A} {HBE : Embed Prop B} {HCE : Embed Prop C}
         (Ps Qs : list Prop) (f : A) (g : B) (op : A -> B -> C)
        (Hop1 : forall (P : Prop) p q, P /\\ op p q |-- op (P /\\ p) q)
        (Hop2 : forall (P : Prop) p q, P /\\ op p q |-- op p (P /\\ q)) :
      find_prop_eval_and_aux (Ps ++ Qs) (op f g) |-- op (find_prop_eval_and_aux Ps f) (find_prop_eval_and_aux Qs g).
Proof.
	induction Ps; simpl in *.
	+ apply find_prop_unop_sound_ar.
	  intros. apply Hop2.
	+ rewrite <- Hop1.
	  apply lpropandL; intro H. apply lpropandR; [apply H|].
	  rewrite <- IHPs; reflexivity.
Qed.

  Lemma binop_sound_ar {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B} {HC : EmbedOp Prop C}
 						{HAE : Embed Prop A} {HBE : Embed Prop B} {HCE : Embed Prop C}
                       (de_env1 : env A) (tac_env1 : env (find_prop A))
                       (de_env2 : env B) (tac_env2 : env (find_prop B))
                       (p : @deep_op A _) (q : @deep_op B _) (op : A -> B -> C)
                       {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_and p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => find_prop_eval_and q |-- p
	    | _, _ => False
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_and q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => find_prop_eval_and q |-- p
	    | _, _ => False
	  end)
        (Hop1 : forall (P : Prop) p q, P /\\ op p q |-- op (P /\\ p) q)
        (Hop2 : forall (P : Prop) p q, P /\\ op p q |-- op p (P /\\ q)) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_prop_binop op (pull_and p de_env1 tac_env1) (pull_and q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => find_prop_eval_and q |-- p
  | _, _           => False
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_and p de_env1 tac_env1) as o3.
	remember (pull_and q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity; [|apply H; [apply Hp | apply Hq]].
	destruct f; destruct f0. simpl.
	unfold find_prop_eval_and. simpl. apply find_prop_binop_sound_ar.
	apply Hop1. apply Hop2.
Qed.

  	Lemma env_sound_aux_ar {A : Type} `{ILA : ILogic A} {HA : EmbedOp Prop A} {HAE : Embed Prop A} (de_env : env A) (tac_env : env (find_prop A))
    (t : @deep_op A _) :
    match deep_op_eval de_env t, pull_and t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_prop_eval_and q |-- p
      | _, _           => False
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + simpl. apply binop_sound_ar; [apply IHt1; apply _ | apply IHt2; apply _ | |].
          intros. unfold lembedand. rewrite <- landA. reflexivity.
          intros. unfold lembedand. rewrite <- landA, (landC (embed P)), landA. reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + admit.
        + admit.
        + simpl. reflexivity.
        + simpl. reflexivity.
        + apply binop_sound_ar.
          apply IHt1. assumption. assumption.
          apply IHt2. assumption. assumption.
          intros. apply lpropandAL.
          intros. apply lpropandAC.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl in *.
          specialize (IHt2 _ HA HAE de_env tac_env).
          remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          remember (pull_and t2 de_env tac_env) as o3.
          destruct o1, o2, o3; try (simpl; intuition congruence).
          simpl. rewrite <- IHt2. destruct f; simpl.
          unfold find_prop_eval_and. simpl.
          unfold lembedand; rewrite emb_prop_eq; reflexivity.
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
    Qed.

  	Lemma env_sound_ar {A : Type} `{ILA : ILogic A} {EmbOp : EmbedOp Prop A} {Emb : Embed Prop A}
  	(de_env : env A) (tac_env : env (find_prop A))
    (t : @deep_op A _) (P : A) :
    match deep_op_eval de_env t, pull_and t de_env tac_env with
      | None, None     => True
      | Some p, Some q => P |-- find_prop_eval_and q -> P |-- p
      | _, _           => False
    end.
    Proof.
    	pose proof (env_sound_aux_ar de_env tac_env t).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_and t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite <- H; assumption.
    Qed.

End PullAndRight.

Ltac lpropandR_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of Q in
      let t := quote_term Q in
       apply (env_sound_ar (env_empty A) (env_empty (find_prop A)) t P);
        simpl; cbv [find_prop_eval_and find_prop_eval_and_aux]; simpl
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lpropandR := lpropandR_aux; repeat apply lpropandR.

Local Existing Instance EmbedOpId.
Local Existing Instance EmbedId.

Lemma test_ar {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (a b c d : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) (HF : False):
  lfalse |-- (a /\\ P) //\\ b /\\ (c /\\ S) /\\ Q //\\ (d /\\ R).
Proof.
	lpropandR; intuition.
Qed.

Section PullAndLeft.

	Lemma find_prop_unop_sound_al {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B}
						{HEA : Embed Prop A} {HEB : Embed Prop B}
	        (Ps : list Prop) (f : A) (op : A -> B)
        (Hop : forall (P : Prop) p, op (P /\\ p) |-- P /\\ op p) :
	      op (find_prop_eval_and_aux Ps f) |-- find_prop_eval_and_aux Ps (op f).
	Proof.
		induction Ps.
		simpl. reflexivity.
		simpl in *. rewrite Hop.
		apply lpropandL; intro H. apply lpropandR; [apply H|].
		rewrite IHPs. reflexivity.
	Qed.

 Lemma find_prop_binop_sound_al {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B} {HC : EmbedOp Prop C}
						{HAE : Embed Prop A} {HBE : Embed Prop B} {HCE : Embed Prop C}
         (Ps Qs : list Prop) (f : A) (g : B) (op : A -> B -> C)
        (Hop1 : forall (P : Prop) p q, op (P /\\ p) q |-- P /\\ op p q)
        (Hop2 : forall (P : Prop) p q, op p (P /\\ q) |-- P /\\ op p q) :
      op (find_prop_eval_and_aux Ps f) (find_prop_eval_and_aux Qs g)
      |-- find_prop_eval_and_aux (Ps ++ Qs) (op f g).
Proof.
	induction Ps; simpl in *.
	+ apply find_prop_unop_sound_al.
	  intros. apply Hop2.
	+ rewrite Hop1.
	  apply lpropandL; intro H. apply lpropandR; [apply H|].
	  rewrite <- IHPs; reflexivity.
Qed.

  Lemma binop_sound_al {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B} {HC : EmbedOp Prop C}
 						{HAE : Embed Prop A} {HBE : Embed Prop B} {HCE : Embed Prop C}
                       (de_env1 : env A) (tac_env1 : env (find_prop A))
                       (de_env2 : env B) (tac_env2 : env (find_prop B))
                       (p : @deep_op A _) (q : @deep_op B _) (op : A -> B -> C)
                       {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_and p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => p |-- find_prop_eval_and q
	    | _, _ => False
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_and q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => p |-- find_prop_eval_and q
	    | _, _ => False
	  end)
        (Hop1 : forall (P : Prop) p q, op (P /\\ p) q |-- P /\\ op p q)
        (Hop2 : forall (P : Prop) p q, op p (P /\\ q) |-- P /\\ op p q) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_prop_binop op (pull_and p de_env1 tac_env1) (pull_and q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => p |-- find_prop_eval_and q
  | _, _           => False
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_and p de_env1 tac_env1) as o3.
	remember (pull_and q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity; [apply H; [apply Hp | apply Hq]|].
	destruct f; destruct f0. simpl.
	unfold find_prop_eval_and. simpl. apply find_prop_binop_sound_al.
	apply Hop1. apply Hop2.
Qed.

  	Lemma env_sound_aux_al {A : Type} `{ILA : ILogic A} {HA : EmbedOp Prop A} {HAE : Embed Prop A} (de_env : env A) (tac_env : env (find_prop A))
    (t : @deep_op A _) :
    match deep_op_eval de_env t, pull_and t de_env tac_env with
      | None, None     => True
      | Some p, Some q => p |-- find_prop_eval_and q
      | _, _           => False
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + simpl. apply binop_sound_al; [apply IHt1; apply _ | apply IHt2; apply _ | |].
          intros. unfold lembedand. rewrite <- landA. reflexivity.
          intros. unfold lembedand. rewrite <- landA, (landC _ (embed P)), landA. reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + admit.
        + admit.
        + simpl. reflexivity.
        + simpl. reflexivity.
        + apply binop_sound_al.
          apply IHt1. assumption. assumption.
          apply IHt2. assumption. assumption.
          intros. apply lpropandAR.
          intros. apply lpropandAC.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl in *.
          specialize (IHt2 _ HA HAE de_env tac_env).
          remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          remember (pull_and t2 de_env tac_env) as o3.
          destruct o1, o2, o3; try (simpl; intuition congruence).
          simpl. rewrite IHt2. destruct f; simpl.
          unfold find_prop_eval_and. simpl.
          unfold lembedand.
          apply landR; [apply landL1; apply emb_prop_eq|apply landL2; reflexivity].
        + simpl. remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
    Qed.

  	Lemma env_sound_al {A : Type} `{ILA : ILogic A} {EmbOp : EmbedOp Prop A} {Emb : Embed Prop A}
  	(de_env : env A) (tac_env : env (find_prop A))
    (t : @deep_op A _) (P : A) :
    match deep_op_eval de_env t, pull_and t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_prop_eval_and q |-- P -> p |-- P
      | _, _           => False
    end.
    Proof.
    	pose proof (env_sound_aux_al de_env tac_env t).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_and t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite H; assumption.
    Qed.

End PullAndLeft.

Ltac lpropandL_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of P in
      let t := quote_term P in
       apply (env_sound_al (env_empty A) (env_empty (find_prop A)) t Q);
        simpl; cbv [find_prop_eval_and find_prop_eval_and_aux]; simpl
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lpropandL2 := lpropandL_aux; repeat (apply lpropandL; intro).

Tactic Notation "lpropandL" := lpropandL2.
Tactic Notation "lpropandL" simple_intropattern(x1) :=
	first [simple apply lpropandL with x1 | lpropandL_aux; simple apply lpropandL; intro x1].
Tactic Notation "lpropandL" simple_intropattern(x1) simple_intropattern(x2) :=
	first [simple apply lpropandL with x1 | lpropandL_aux; simple apply lpropandL; intro x1]; lpropandL x2.
Tactic Notation "lpropandL" simple_intropattern(x1) simple_intropattern(x2) simple_intropattern(x3) :=
	first [simple apply lpropandL with x1 | lpropandL_aux; simple apply lpropandL; intro x1]; lpropandL x2 x3.
Tactic Notation "lpropandL" simple_intropattern(x1) simple_intropattern(x2) simple_intropattern(x3) simple_intropattern(x4) :=
	first [simple apply lpropandL with x1 | lpropandL_aux; simple apply lpropandL; intro x1]; lpropandL x2 x3 x4.

Local Existing Instance EmbedOpId.
Local Existing Instance EmbedId.

Lemma test_al {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (a b c d : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) :
  (a /\\ P) //\\ b /\\ (c /\\ S) /\\ Q //\\ (d /\\ R) |-- ltrue.
Proof.
	lpropandL Ha Hb Hc Hd.
	apply ltrueR.
Qed.

 	Fixpoint find_prop_eval_impl_aux {A : Type} {ILA : ILogicOps A} {H: EmbedOp Prop A} (Ps : list Prop) (a : A) : A :=
 		match Ps with
 			| nil     => a
 			| P :: Ps => P ->> (find_prop_eval_impl_aux Ps a)
 		end.

	Definition find_prop_eval_impl {A : Type} {ILA : ILogicOps A} {H: EmbedOp Prop A} (p : find_prop A) :=
		find_prop_eval_impl_aux (fst p) (snd p).

Fixpoint pull_impl {A : Type} {ILA : ILogicOps A} {EmbOp : EmbedOp Prop A} {Emb : Embed Prop A}
                  (t : @deep_op A _) (de_env : env A) (tac_env : env (find_prop A)) : option (find_prop A) :=
match t with
	| t_and t1 t2   => find_prop_binop land (pull_impl t1 de_env tac_env) (pull_impl t2 de_env tac_env)
	| t_and_inj B _ _ _ _ _ _ a b => find_prop_binop lembedand (pull_impl a (env_empty B) (env_empty (find_prop B)))
	                         (pull_impl b de_env tac_env)
	| t_and_prop _ _ a b => find_prop_binop lembedand (pull_impl a (env_empty Prop) (env_empty (find_prop Prop)))
	                         (pull_impl b de_env tac_env)
	| t_impl_prop _ _ a b =>
		match deep_op_eval (env_empty Prop) a, pull_impl b de_env tac_env with
			| Some a, Some b => Some (a::(fst b), snd b)
			| _, _           => None
		end
    | t_unop n p =>
    	match ((fst tac_env) [n]) with
    		| Some f => unop_option f (pull_impl p de_env tac_env)
    		| None => None
    	end
	| t_binop n p q =>
		match ((snd tac_env) [n]) with
			| Some f => binop_option f (pull_impl p de_env tac_env) (pull_impl q de_env tac_env)
			| None => None
		end
    | _ => match deep_op_eval de_env t with
    	     | Some t => Some (nil, t)
    	     | None   => None
    	   end
end.

Section PullImplLeft.

	Lemma find_prop_unop_sound_il {A B : Type} {ILA : ILogicOps A} `{ILB : ILogic B}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B}
						{HEA : Embed Prop A} {HEB : Embed Prop B}
	        (Ps : list Prop) (f : A) (op : A -> B)
        (Hop : forall (P : Prop) p, op (P ->> p) |-- P ->> op p) :
	      op (find_prop_eval_impl_aux Ps f) |-- find_prop_eval_impl_aux Ps (op f).
	Proof.
		induction Ps.
		simpl. reflexivity.
		simpl in *. rewrite Hop.
		apply lpropimplR; intro H. apply lpropimplL; [apply H|].
		rewrite IHPs. reflexivity.
	Qed.

 Lemma find_prop_binop_sound_il {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B} {HC : EmbedOp Prop C}
						{HAE : Embed Prop A} {HBE : Embed Prop B} {HCE : Embed Prop C}
         (Ps Qs : list Prop) (f : A) (g : B) (op : A -> B -> C)
        (Hop1 : forall (P : Prop) p q, op (P ->> p) q |-- P ->> op p q)
        (Hop2 : forall (P : Prop) p q, op p (P ->> q) |-- P ->> op p q) :
      op (find_prop_eval_impl_aux Ps f) (find_prop_eval_impl_aux Qs g) |-- find_prop_eval_impl_aux (Ps ++ Qs) (op f g).
Proof.
	induction Ps; simpl in *.
	+ apply find_prop_unop_sound_il.
	  intros. apply Hop2.
	+ rewrite Hop1.
	  apply lpropimplR; intro H. apply lpropimplL; [apply H|].
	  rewrite <- IHPs; reflexivity.
Qed.

  Lemma binop_sound_il {A B C : Type} {ILA : ILogicOps A} {ILB : ILogicOps B} `{ILC : ILogic C}
						{HA : EmbedOp Prop A} {HB : EmbedOp Prop B} {HC : EmbedOp Prop C}
 						{HAE : Embed Prop A} {HBE : Embed Prop B} {HCE : Embed Prop C}
                       (de_env1 : env A) (tac_env1 : env (find_prop A))
                       (de_env2 : env B) (tac_env2 : env (find_prop B))
                       (p : @deep_op A _) (q : @deep_op B _) (op : A -> B -> C)
                       {H : Proper (lentails ==> lentails ==> lentails) op}
      (Hp : match deep_op_eval de_env1 p, pull_impl p de_env1 tac_env1 with
	    | None, None => True
	    | Some p, Some q => p |-- find_prop_eval_impl q
	    | _, _ => False
	  end)
      (Hq : match deep_op_eval de_env2 q, pull_impl q de_env2 tac_env2 with
	    | None, None => True
	    | Some p, Some q => p |-- find_prop_eval_impl q
	    | _, _ => False
	  end)
        (Hop1 : forall (P : Prop) p q, op (P ->> p) q |-- P ->> op p q)
        (Hop2 : forall (P : Prop) p q, op p (P ->> q) |-- P ->> op p q) :
match binop_option op (deep_op_eval de_env1 p) (deep_op_eval de_env2 q),
      find_prop_binop op (pull_impl p de_env1 tac_env1) (pull_impl q de_env2 tac_env2) with
  | None, None     => True
  | Some p, Some q => p |-- find_prop_eval_impl q
  | _, _           => False
end.
Proof.
	remember (deep_op_eval de_env1 p) as o1.
	remember (deep_op_eval de_env2 q) as o2.
	remember (pull_impl p de_env1 tac_env1) as o3.
	remember (pull_impl q de_env2 tac_env2) as o4.
	destruct o1, o2, o3, o4; simpl in *; try intuition congruence.
	etransitivity; [apply H; [apply Hp | apply Hq]|].
	destruct f; destruct f0. simpl.
	unfold find_prop_eval_impl. simpl. apply find_prop_binop_sound_il.
	apply Hop1. apply Hop2.
Qed.

  	Lemma env_sound_aux_il {A : Type} `{ILA : ILogic A} {HA : EmbedOp Prop A} {HAE : Embed Prop A} (de_env : env A) (tac_env : env (find_prop A))
    (t : @deep_op A _) :
    match deep_op_eval de_env t, pull_impl t de_env tac_env with
      | None, None     => True
      | Some p, Some q => p |-- find_prop_eval_impl q
      | _, _           => False
    end.
    Proof.
    	induction t.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
    	+ simpl; reflexivity.
        + simpl. apply binop_sound_il; [apply IHt1; apply _ | apply IHt2; apply _ | |].
          intros. unfold lembedimpl. apply limplAdj. apply landR.
          * rewrite landA. apply limplL. apply landL2. reflexivity.
            apply landL1. reflexivity.
          * apply landL1. apply landL2. reflexivity.
          * intros. rewrite landC. apply limplAdj. rewrite landA. apply limplL.
            apply landL2. reflexivity.
            apply landR. apply landL2. apply landL1. reflexivity.
            apply landL1. reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl; remember (deep_op_eval de_env t1) as o1.
	      remember (deep_op_eval de_env t2) as o2.
	      destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + admit.
        + admit.
        + simpl. reflexivity.
        + simpl. reflexivity.
        + apply binop_sound_il.
          apply IHt1. assumption.
          apply IHt2. assumption.
          intros. apply lpropimplAL.
          intros; apply lpropimplAR.
        + simpl. remember (deep_op_eval (env_empty B) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          destruct o1, o2; simpl; (try intuition congruence); reflexivity.
        + simpl in *.
          apply binop_sound_il.
          apply IHt1. apply _.
          apply IHt2. apply _.
          intros; apply lpropimplAL.
          intros. unfold lembedand, lembedimpl.
          etransitivity; [apply lpropimplAR|].
          rewrite emb_prop_eq. reflexivity.
        + simpl in *.
          specialize (IHt2  ILA EmbOp Emb de_env tac_env).
          remember (deep_op_eval (env_empty Prop) t1) as o1.
          remember (deep_op_eval de_env t2) as o2.
          remember (@pull_impl A ILA0 EmbOp Emb t2 de_env tac_env) as o3.
          destruct o1, o2, o3; try (simpl; intuition congruence).
          simpl. destruct f; simpl.
          unfold find_prop_eval_impl. simpl.
          apply lpropimplR. intros HP.
          apply lpropimplL. apply HP.
          rewrite IHt2. unfold find_prop_eval_impl; simpl.
          admit. (* Proof by induction on find_pro_eval_impl_aux *)
    Qed.

  	Lemma env_sound_il {A : Type} `{ILA : ILogic A} {EmbOp : EmbedOp Prop A} {Emb : Embed Prop A}
  	(de_env : env A) (tac_env : env (find_prop A))
    (t : @deep_op A _) (P : A) :
    match deep_op_eval de_env t, pull_impl t de_env tac_env with
      | None, None     => True
      | Some p, Some q => find_prop_eval_impl q |-- P -> p |-- P
      | _, _           => False
    end.
    Proof.
    	pose proof (env_sound_aux_il de_env tac_env t).
    	remember (deep_op_eval de_env t) as o1.
    	remember (pull_impl t de_env tac_env) as o2.
    	destruct o1, o2; simpl in *; try intuition congruence.
    	intros. rewrite <- H0. assumption.
    Qed.

End PullImplLeft.

Ltac lpropimplL_aux :=
  match goal with
    | |- ?P |-- ?Q =>
      let A := type of P in
      let t := quote_term P in
       apply (env_sound_il (env_empty A) (env_empty (find_prop A)) t Q);
        simpl; cbv [find_prop_eval_impl find_prop_eval_impl_aux]; simpl
    | |- _ => fail 1 "Goal is not an entailment"
  end.

Ltac lpropimplL := lpropimplL_aux; repeat apply lpropimplL.

   Lemma test_il {A B : Type} `{H : Embed B A} {HBPO: EmbedOp Prop B} {HPB : Embed Prop B} {HO : EmbedOp Prop A} {HE: Embed Prop A} {HA : ILogic A} {HB : ILogic B}
    (P Q R : A) (S : B) (a b c d : Prop) (f : nat -> A) (g : nat -> B) (h : nat -> Prop) (HF : False):
  (a ->> P) //\\ (b ->> (c ->> S)) /\\ Q //\\ (d ->> R) |-- ltrue.
Proof.
	lpropimplL; destruct HF.
Qed.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.Max.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.
Require Import Coq.Logic.DecidableTypeEx.

Require Import CoqFSetDecide.
Require Import CoqListFacts.
Require Import FSetExtra.
Require Import FSetWeakNotin.
Require Import LibTactics.

(* ********************************************************************** *)
(** * Defining atoms *)

(** Atoms are structureless objects such that we can always generate
    one fresh from a finite collection.  Equality on atoms is [eq] and
    decidable.  We use Coq's module system to make abstract the
    implementation of atoms. *)

Module Type ATOM.

  Parameter atom : Set.

  Parameter eq_atom_dec : forall x y : atom, {x = y} + {x <> y}.

  Parameter atom_fresh_for_list :
    forall (xs : list atom), {x : atom | ~ List.In x xs}.

  Hint Resolve eq_atom_dec.

End ATOM.

(** The implementation of the above interface is hidden for
    documentation purposes. *)

Module AtomImpl <: ATOM.

  (* begin hide *)

  Definition atom := nat.

  Definition eq_atom_dec := eq_nat_dec.

  Lemma max_lt_r : forall x y z,
    x <= z -> x <= max y z.
  Proof.
    induction x. auto with arith.
    induction y. auto with arith.
      simpl. induction z. omega. auto with arith.
  Qed.

  Lemma nat_list_max : forall (xs : list nat),
    { n : nat | forall x, List.In x xs -> x <= n }.
  Proof.
    induction xs as [ | x xs [y H] ].
    (* case: nil *)
    exists 0. inversion 1.
    (* case: cons x xs *)
    exists (max x y). intros z J. simpl in J. destruct J as [K | K].
      subst. auto with arith.
      auto using max_lt_r.
  Qed.

  Lemma atom_fresh_for_list :
    forall (xs : list atom), { n : atom | ~ List.In n xs }.
  Proof.
    intros xs. destruct (nat_list_max xs) as [x H].
    exists (S x). intros J. lapply (H (S x)). omega. trivial.
  Qed.

  (* end hide *)

End AtomImpl.

(** We make [atom], [eq_atom_dec], and [atom_fresh_for_list] available
    without qualification. *)

Export AtomImpl.

(** It is trivial to implement the [DecidableType] interface with [atom]. *)

Module AtomDT <: UsualDecidableType with Definition t := atom.

  Definition t := atom.

  Definition eq := @eq t.
  Definition eq_refl := @refl_equal t.
  Definition eq_sym := @sym_eq t.
  Definition eq_trans := @trans_eq t.

  Definition eq_dec := eq_atom_dec.

End AtomDT.

(** It is trivial to declare an instance of [EqDec] for [atom]. *)

Instance EqDec_atom : @EqDec atom eq eq_equivalence.
Proof. exact eq_atom_dec. Defined.

(* ********************************************************************** *)
(** * Finite sets of atoms *)

(** We use our implementation of atoms to obtain an implementation of
    finite sets of atoms.  We give the resulting type an intuitive
    name, as well as import names of set operations for use within
    this library.  In order to avoid polluting Coq's namespace, we do
    not use [Module Export]. *)

Module Import AtomSetImpl <: FSetExtra.WSfun AtomDT :=
  FSetExtra.Make AtomDT.

Notation atoms :=
  AtomSetImpl.t.

(** The [AtomSetDecide] module provides the [fsetdec] tactic for
    solving facts about finite sets of atoms. *)

Module Export AtomSetDecide := CoqFSetDecide.WDecide_fun AtomDT AtomSetImpl.

(** The [AtomSetNotin] module provides the [destruct_notin] and
    [solve_notin] for reasoning about non-membership in finite sets of
    atoms, as well as a variety of lemmas about non-membership. *)

Module Export AtomSetNotin := FSetWeakNotin.Notin_fun AtomDT AtomSetImpl.

(** Given the [fsetdec] tactic, we typically do not need to refer to
    specific lemmas about finite sets.  However, instantiating
    functors from the FSets library makes a number of setoid rewrites
    available.  These rewrites are crucial to developments since they
    allow us to replace a set with an extensionally equal set (see the
    [Equal] relation on finite sets) in propositions about finite
    sets. *)

Module AtomSetFacts := FSetFacts.WFacts_fun AtomDT AtomSetImpl.
Module AtomSetProperties := FSetProperties.WProperties_fun AtomDT AtomSetImpl.

(* ********************************************************************** *)
(** * Properties *)

(** For any given finite set of atoms, we can generate an atom fresh
    for it. *)

Lemma atom_fresh : forall L : atoms, { x : atom | ~ In x L }.
Proof.
  intros L. destruct (atom_fresh_for_list (elements L)) as [a H].
  exists a. intros J. contradiction H.
  rewrite <- CoqListFacts.InA_iff_In. auto using @elements_1.
Qed.

(* ********************************************************************** *)
(** * Tactic support for picking fresh atoms *)

(* begin hide *)

(** The auxiliary tactic [simplify_list_of_atom_sets] takes a list of
    finite sets of atoms and unions everything together, returning the
    resulting single finite set. *)

Ltac simplify_list_of_atom_sets L :=
  let L := eval simpl in L in
  let L := ltac_remove_dups L in
  let L := eval simpl in (List.fold_right union empty L) in
  match L with
    | context C [union ?E empty] => context C [ E ]
  end.

(* end hide *)

(** [gather_atoms_with F] returns the union of all the finite sets
    [F x] where [x] is a variable from the context such that [F x]
    type checks. *)

Ltac gather_atoms_with F :=
  let apply_arg x :=
    match type of F with
      | _ -> _ -> _ -> _ => constr:(@F _ _ x)
      | _ -> _ -> _ => constr:(@F _ x)
      | _ -> _ => constr:(@F x)
    end in
  let rec gather V :=
    match goal with
      | H : _ |- _ =>
        let FH := apply_arg H in
        match V with
          | context [FH] => fail 1
          | _ => gather (union FH V)
        end
      | _ => V
    end in
  let L := gather empty in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
    sets and returns the same set cleaned up: empty sets are removed
    and items are laid out in a nicely parenthesized way. *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | union ?E1 ?E2 => let Acc2 := go Acc E2 in go Acc2 E1
     | empty => Acc
     | ?E1 => match Acc with
                | empty => E1
                | _ => constr:(union E1 Acc)
              end
     end
  in go empty V.

(** The tactic [pick fresh Y for L] takes a finite set of atoms [L]
    and a fresh name [Y], and adds to the context an atom with name
    [Y] and a proof that [~ In Y L], i.e., that [Y] is fresh for [L].
    The tactic will fail if [Y] is already declared in the context.

    The variant [pick fresh Y] is similar, except that [Y] is fresh
    for "all atoms in the context."  This version depends on the
    tactic [gather_atoms], which is responsible for returning the set
    of "all atoms in the context."  By default, it returns the empty
    set, but users are free (and expected) to redefine it. *)

Ltac gather_atoms :=
  constr:empty.

Tactic Notation "pick" "fresh" ident(Y) "for" constr(L) :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (atom_fresh L) as [Y Fr]); destruct_notin.

Tactic Notation "pick" "fresh" ident(Y) :=
  let L := gather_atoms in
  pick fresh Y for L.

Ltac pick_fresh y :=
  pick fresh y.

(** Example: We can redefine [gather_atoms] to return all the
    "obvious" atoms in the context using the [gather_atoms_with] thus
    giving us a "useful" version of the "[pick fresh]" tactic. *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  constr:(union A B).

Lemma example_pick_fresh_use : forall (x y z : atom) (L1 L2 L3: atoms), True.
(* begin show *)
Proof.
  intros x y z L1 L2 L3.
  pick fresh k.

  (** At this point in the proof, we have a new atom [k] and a
      hypothesis [Fr] that [k] is fresh for [x], [y], [z], [L1], [L2],
      and [L3]. *)

  trivial.
Qed.
(* end show *)


Definition foo := fix foo (n : nat) : Type := match n with 0 => nat | S k => let bar : Type := foo k in (bar * bar)%type end.
Definition baz := fix baz (n : nat) : foo n := match n with 0 => 0 | S k => let quux := baz k in (quux, quux) end.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e222m117_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Coq.Init.Prelude.

Fixpoint deep (n : nat) : Set :=
  match n with
  | O => unit
  | S n => option (deep n)
  end.

Goal deep 1000.
  Time assert (deep 1000) by (abstract (repeat constructor)).
  assumption.
Time Qed.
(*
Finished transaction in 2.879 secs (2.764u,0.099s) (successful)
Finished transaction in 0.654 secs (0.651u,0.s) (successful)
*)

Goal deep 1000.
  Time assert (deep 1000) by (repeat constructor).
  assumption.
Time Qed.
(*
Finished transaction in 1.238 secs (1.213u,0.016s) (successful)
Finished transaction in 1.63 secs (1.62u,0.s) (successful)
*)


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert sltype.
Require Import CTL_def hilbert.
Import IC.

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

(** * Translation of History Rules to Hilbert Refutations *)

Definition AU_ (u s t : form) := AU (s :/\: u) (t :/\: u).

Lemma AUH_hil (s t u v : form) :
  prv (u :/\: t ---> Bot) ->
  prv (u ---> s ---> ~~: AX (AU_ (~~: u :/\: v) s t)) ->
  prv (u ---> AU_ v s t ---> Bot).
Proof.
  move => H0 H1.
  suff sf: prv (AU_ v s t ---> AU_ (~~: u :/\: v) s t).
  { do 2 Intro.
    Have (~~: t); [Intro; ApplyH H0; by ApplyH axAI| Intro].
    Have ((s :/\: v) :/\: AX (AU_ v s t)).
    + Rev* 1. rewrite /AU_. rewrite -> axAUeq at 1. rewrite /Or.
      Intro. Apply. ApplyH axAcase. do 2 Intro. by Apply* 3.
    + rewrite -> sf at 2. do 2 ApplyH axAcase. do 2 Intro. by ApplyH H1. }
  apply: rAU_ind.
  - rule axAcase. do 2 Intro. ApplyH axAUI. ApplyH axAI.
    ApplyH axAI. Intro. ApplyH H0. by ApplyH axAI.
  - rule axAcase. do 3 Intro. ApplyH axAUf. ApplyH axAI.
    ApplyH axAI. Intro. by ApplyH H1.
Qed.

Definition EU_ (H s t : form) := EU (s :/\: H) (t :/\: H).

Lemma ARH_hil (s t C H : form) :
  prv (t ---> ~~: C) ->
  prv (EX (EU_ (~~: C :/\: H) s t) ---> s ---> ~~: C) ->
  prv (C ---> EU_ H s t ---> fF).
Proof.
  move => H0 H1.
  suff sf: prv (EU_ H s t ---> EU_ (~~: C :/\: H) s t).
  { do 2 Intro.
    Have (~~: t); [Intro; ApplyH H0; by ApplyH axAI| Intro].
    Have ((s :/\: H) :/\: EX (EU_ H s t)).
    + Rev* 1. rewrite /EU_. rewrite -> axEUeq at 1. rewrite /Or.
      Intro. Apply. ApplyH axAcase. do 2 Intro. by Apply* 3.
    + rewrite -> sf at 2. do 2 ApplyH axAcase. do 3 Intro. by ApplyH H1. }
  apply: EU_ind.
  - rule axAcase. do 2 Intro. ApplyH axEUI. ApplyH axAI.
    ApplyH axAI. Intro. by ApplyH H0.
  - rule axAcase. do 3 Intro. ApplyH axEUI2. ApplyH axAI.
    ApplyH axAI. Intro. by ApplyH H1.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import coqutil.Datatypes.List.
Require Import coqutil.Decidable.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Import ListNotations.
Local Open Scope Z_scope.

(**** Helpers for working with words ****)

Section WithWord.
  Context {width} {word : word.word width} {word_ok : word.ok word}.

  (* Compute sequential register addresses given a start address and a number of
   registers *)
  Definition list_reg_addrs (start : word.rep)
             (nregs : nat) (size_in_bytes : Z)
    : list word :=
    map (fun i => word.add start (word.of_Z (Z.of_nat i * size_in_bytes)))
        (seq 0 nregs).

  Definition select_bits (w : word) (offset mask : word) : word :=
    word.and (word.sru w offset) mask.

  (* the flag is set if ((val & (1 << flag)) != 0) *)
  Definition is_flag_set (val : word) (flag : Z) : bool :=
    negb (word.eqb (word.and val (word.slu (word.of_Z 1) (word.of_Z flag))) (word.of_Z 0)).

  Definition has_size (w : word) (n : Z) : Prop :=
    0 <= word.unsigned w < 2 ^ n.

  Record enum {elts : list word} {size : Z} :=
    { enum_size_ok :
        Forall (fun w => has_size w size) elts;
      enum_unique : NoDup elts;
      enum_member (w : word) := In w elts;
    }.
  Global Arguments enum : clear implicits.

  Definition boolean (w : word) : Prop := (w = word.of_Z 0 \/ w = word.of_Z 1).
End WithWord.

(* changes H : unique_words [a;b;c] into a <> b, a <> c, b <> c *)
Ltac simplify_unique_words_in H :=
  lazymatch type of H with
  | NoDup ?words =>
    cbn [List.map] in H;
    repeat lazymatch goal with
           | H : List.NoDup [] |- _ => clear H
           | H : List.NoDup (_ :: _) |- _ => inversion H; clear H; subst; cbv [List.In] in *
           | H : ~ (_ \/ _) |- _ => apply Decidable.not_or in H
           | H : _ /\ _ |- _ => destruct H
           end
  | ?t => fail "expected hypothesis of type [unique_words _], got one of type" t
  end.


Require Import ssr.
Require Import lib.

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

Module Type RING.

  Parameter base : eqType.

  Parameter addr : base -> base -> base.
  Parameter mulr : base -> base -> base.
  Parameter oppr : base -> base.
  Parameter zeror : base.
  Parameter oner : base.

  Notation "x1 + x2" := (addr x1 x2).
  Notation "x1 * x2" := (mulr x1 x2).
  Notation "x - y" := (x + oppr y).
  Notation "- x" := (oppr x).
  Notation "0" := zeror.
  Notation "1" := oner.
  Notation addrr := (fun x y => y + x).
  Notation mulrr := (fun x y => y * x).

  Axiom addC : forall x y, x + y = y + x.
  Axiom addA : forall x y z, x + (y + z) = (x + y) + z.
  Axiom addr0 : forall x, x + 0 = x.
  Axiom oppL : forall x, -x + x = 0.
  Axiom mulC : forall x y, x * y = y * x.
  Axiom mulA : forall x y z, x * (y * z) = x * y * z.
  Axiom mul1r : forall x, 1 * x = x.
  Axiom distPM : forall x1 x2 x3, (x1 + x2) * x3 = (x1 * x3) + (x2 * x3).
  Axiom distMP : forall x1 x2 x3, x1 * (x2 + x3) = (x1 * x2) + (x1 * x3).

End RING.

Module Type RING_LEMMAS.

  Declare Module R : RING.

  Notation addr := R.addr.
  Notation mulr := R.mulr.
  Notation "x1 + x2" := (addr x1 x2).
  Notation "x1 * x2" := (mulr x1 x2).
  Notation "x - y" := (x + R.oppr y).
  Notation "- x" := (R.oppr x).
  Notation "0" := R.zeror.
  Notation "1" := R.oner.
  Notation addrr := (fun x y => y + x).
  Notation mulrr := (fun x y => y * x).

  Axiom mulr1 : forall x, x * 1 = x.
  Axiom add0r : forall x, 0 + x = x.
  Axiom mul0r : forall x, 0 * x = 0.
  Axiom mulr0 : forall x, x * 0 = 0.
  Axiom oppR : forall x, x + -x = 0.
  Axiom addr_injl : forall x, injective (addr x).
  Axiom addr_injr : forall x, injective (addrr x).
  Axiom addKr : forall x, cancel (addr x) (addr (- x)).
  Axiom addKrV : forall x, cancel (addr (- x)) (addr x).
  Axiom addrK : forall x : R.base, cancel (addrr x) (addrr (- x)).
  Axiom addrKV : forall x, cancel (addrr (- x)) (addrr x).
  Axiom opp_opp : forall x, -(-x) = x.
  Axiom opp_uniq : forall x y y', x + y = 0 -> x + y' = 0 -> y = y'.
  Axiom opp_def : forall x y, x + y = 0 -> y = - x.
  Axiom mul_oppL : forall x y, - x * y = - (x * y).
  Axiom mul_oppR : forall x y, x * - y = - (x * y).
  Axiom mul_opp_opp : forall x y, - x * - y = x * y.
  Axiom opp_sym : forall x y, - x = y -> x = - y.
  Axiom addrCA : forall m n p, m + (n + p) = n + (m + p).
  Axiom opp0 : - 0 = 0.
  Axiom oppr0 : forall x, (-x == 0) = (x == 0).
  Axiom mul_opp1r : forall x, -(1) * x = - x.
  Axiom mul_opp1_opp : forall x, -(1) * - x = x.
  Axiom mul_opp1_opp1 : -(1) * -(1) = 1.
  Axiom zero_ring : 1 = 0 -> forall x, x = 0.
  Axiom mulrCA : forall m n p, m * (n * p) = n * (m * p).
  Axiom subr0 : forall x, x - 0 = x.
  Axiom opp_add : forall x y, -(x + y) = - x - y.
  Axiom sub0r : forall x, 0 - x = - x.

End RING_LEMMAS.

Module RingLemmas(R : RING) : RING_LEMMAS with Module R := R.

Module R := R.

Notation addr := R.addr.
Notation mulr := R.mulr.
Notation oppr := R.oppr.
Notation addrr := R.addrr.
Notation mulrr := R.mulrr.
Notation addC := R.addC.
Notation addA := R.addA.
Notation addr0 := R.addr0.
Notation oppL := R.oppL.
Notation mulC := R.mulC.
Notation mulA := R.mulA.
Notation mul1r := R.mul1r.
Notation distPM := R.distPM.
Notation distMP := R.distMP.
Notation "x1 + x2" := (R.addr x1 x2).
Notation "x1 * x2" := (R.mulr x1 x2).
Notation "- x" := (R.oppr x).
Notation "0" := R.zeror.
Notation "1" := R.oner.
Notation "x - y" := (x + R.oppr y).

Lemma mulr1 : forall x, x * 1 = x.
Proof. by move=> x; rewrite mulC; exact: mul1r. Qed.

Lemma add0r : forall x, 0 + x = x.
Proof. by move=> x; rewrite addC; exact: addr0. Qed.

Lemma oppR : forall x, x + -x = 0.
Proof. move=> x. rewrite addC; exact: oppL. Qed.

Lemma addr_injl : forall x, injective (addr x).
Proof. by move=> x y z; move/(congr1 (addr (-x))); rewrite !addA !oppL !add0r. Qed.

Lemma addr_injr : forall x, injective (addrr x).
Proof. by move=> x y z /=; rewrite addC [z + _]addC; exact: addr_injl. Qed.

Lemma addKr : forall x, cancel (addr x) (addr (- x)).
Proof. by move=> x y; rewrite addA oppL add0r. Qed.

Lemma addKrV : forall x, cancel (addr (- x)) (addr x).
Proof. by move=> x y; rewrite addA oppR add0r. Qed.

Lemma addrK : forall x, cancel (addrr x) (addrr (- x)).
Proof. by move=> x y; rewrite -addA oppR addr0. Qed.

Lemma addrKV : forall x, cancel (addrr (- x)) (addrr x).
Proof. by move=> x y; rewrite -addA oppL addr0. Qed.

Lemma opp_opp : forall x, -(-x) = x.
Proof. by move=> x; apply: (@addr_injr (- x)); rewrite oppL oppR. Qed.

Lemma opp_uniq : forall x y y', x + y = 0 -> x + y' = 0 -> y = y'.
Proof. by move=> x y y' H H'; apply (@addr_injl x); rewrite H H'. Qed.

Lemma opp_def : forall x y, x + y = 0 -> y = - x.
Proof. move=> x y H; apply (@opp_uniq x);auto; by rewrite oppR. Qed.

(** #  ROTMAN: Theorem 1(i)  # *)
Lemma mul0r : forall x, 0 * x = 0.
Proof. by move=> x; apply (@addr_injr (0 * x)); rewrite -distPM !add0r. Qed.

Lemma mulr0 : forall x, x * 0 = 0.
Proof. by move=> x; apply (@addr_injr (x * 0)); rewrite -distMP !add0r. Qed.

Lemma mul_oppL : forall x y, - x * y = - (x * y).
Proof. by move=> x y; apply (@opp_uniq (x * y));rewrite -?distPM oppR ?mul0r. Qed.

Lemma mul_oppR : forall x y, x * - y = - (x * y).
Proof. by move=> x y; apply (@opp_uniq (x * y)); rewrite -?distMP oppR ?mulr0. Qed.

Lemma mul_opp_opp : forall x y, - x * - y = x * y.
Proof. by move=> x y; rewrite mul_oppR mul_oppL opp_opp. Qed.

Lemma opp_sym : forall x y, - x = y -> x = - y.
Proof. by move=> x y H; rewrite -H; symmetry; exact: opp_opp. Qed.

Lemma addrCA : forall m n p, m + (n + p) = n + (m + p).
Proof. by move=> m n p; rewrite addA [m + _]addC addA. Qed.

Lemma opp0 : - 0 = 0.
Proof. by apply (@addr_injr 0); rewrite oppL !addr0. Qed.

Lemma oppr0 : forall x, (-x == 0) = (x == 0).
Proof.
 (* {{{ *)
move=> x.
apply/eqP.
case H : (_ == _) => [|H']; first by rewrite (eqP H) opp0.
move: (congr1 oppr H).
rewrite opp_opp opp0 => H0.
by rewrite H0 eq_refl in H'.
 (* }}} *)
Qed.

(** #  ROTMAN: Theorem 1(ii)  # *)
Lemma mul_opp1r : forall x, -(1) * x = - x.
Proof. by move=> x; apply (@addr_injl x); rewrite oppR mul_oppL mul1r oppR. Qed.

(** #  ROTMAN: Theorem 1(iii)  # *)
Lemma mul_opp1_opp : forall x, -(1) * - x = x.
Proof. by move=> x; rewrite mul_opp1r opp_opp. Qed.

Lemma mul_opp1_opp1 : -(1) * -(1) = 1.
Proof.  exact: mul_opp1_opp. Qed.

Lemma opp_add : forall x y, -(x + y) = - x - y.
Proof. by move=> x y; rewrite -mul_opp1r distMP !mul_opp1r. Qed.

Lemma zero_ring : 1 = 0 -> forall x, x = 0.
Proof. by move=> H x; rewrite -[x]mul1r H mul0r. Qed.

Lemma subr0 : forall x, x - 0 = x.
Proof. by rewrite opp0; exact: addr0. Qed.

Lemma sub0r : forall x, 0 - x = - x.
Proof. by move=> x; rewrite add0r. Qed.

Lemma mulrCA : forall m n p, m * (n * p) = n * (m * p).
Proof. by move=> m n p; rewrite mulA [m * _]mulC mulA. Qed.

End RingLemmas.


(*
Copyright 2015 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

(******************************************************************************)
(* This file contains an implementation of maps over non-zero natural         *)
(* numbers, pcm instance for natmap, gapless natmaps, natmaps with binary     *)
(* range, several sorts of continuous natmaps.                                *)
(* Histories are a special case of natmaps.                                   *)
(******************************************************************************)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path.
From fcsl Require Import prelude ordtype pcm finmap unionmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(************************)
(************************)
(* Maps over non-0 nats *)
(************************)
(************************)

Module Type NMSig.
Parameter tp : Type -> Type.

Section Params.
Variable A : Type.
Notation tp := (tp A).

Parameter nm_undef : tp.
Parameter defined : tp -> bool.
Parameter empty : tp.
Parameter upd : nat -> A -> tp -> tp.
Parameter dom : tp -> seq nat.
Parameter dom_eq : tp -> tp -> bool.
Parameter free : nat -> tp -> tp.
Parameter find : nat -> tp -> option A.
Parameter union : tp -> tp -> tp.
Parameter nm_filter : pred nat -> tp -> tp.
Parameter empb : tp -> bool.
Parameter undefb : tp -> bool.
Parameter pts : nat -> A -> tp.

Parameter from : tp -> @UM.base nat_ordType A (fun x => x != 0).
Parameter to : @UM.base nat_ordType A (fun x => x != 0) -> tp.

Axiom ftE : forall b, from (to b) = b.
Axiom tfE : forall f, to (from f) = f.
Axiom undefE : nm_undef = to (@UM.Undef nat_ordType A (fun x => x != 0)).
Axiom defE : forall f, defined f = UM.valid (from f).
Axiom emptyE : empty = to (@UM.empty nat_ordType A (fun x => x != 0)).
Axiom updE : forall k v f, upd k v f = to (UM.upd k v (from f)).
Axiom domE : forall f, dom f = UM.dom (from f).
Axiom dom_eqE : forall f1 f2, dom_eq f1 f2 = UM.dom_eq (from f1) (from f2).
Axiom freeE : forall k f, free k f = to (UM.free k (from f)).
Axiom findE : forall k f, find k f = UM.find k (from f).
Axiom unionE : forall f1 f2, union f1 f2 = to (UM.union (from f1) (from f2)).
Axiom nmfiltE : forall q f, nm_filter q f = to (UM.um_filter q (from f)).
Axiom empbE : forall f, empb f = UM.empb (from f).
Axiom undefbE : forall f, undefb f = UM.undefb (from f).
Axiom ptsE : forall k v, pts k v = to (@UM.pts nat_ordType A (fun x => x != 0) k v).

End Params.
End NMSig.

Module NMDef : NMSig.
Section NMDef.
Variable A : Type.

Definition nonz x := x != 0.

Definition tp : Type := @UM.base nat_ordType A nonz.

Definition nm_undef := @UM.Undef nat_ordType A nonz.
Definition defined f := @UM.valid nat_ordType A nonz f.
Definition empty := @UM.empty nat_ordType A nonz.
Definition upd k v f := @UM.upd nat_ordType A nonz k v f.
Definition dom f := @UM.dom nat_ordType A nonz f.
Definition dom_eq f1 f2 := @UM.dom_eq nat_ordType A nonz f1 f2.
Definition free k f := @UM.free nat_ordType A nonz k f.
Definition find k f := @UM.find nat_ordType A nonz k f.
Definition union f1 f2 := @UM.union nat_ordType A nonz f1 f2.
Definition nm_filter q f := @UM.um_filter nat_ordType A nonz q f.
Definition empb f := @UM.empb nat_ordType A nonz f.
Definition undefb f := @UM.undefb nat_ordType A nonz f.
Definition pts k v := @UM.pts nat_ordType A nonz k v.

Definition from (f : tp) : @UM.base nat_ordType A nonz := f.
Definition to (b : @UM.base nat_ordType A nonz) : tp := b.

Lemma ftE b : from (to b) = b. Proof. by []. Qed.
Lemma tfE f : to (from f) = f. Proof. by []. Qed.
Lemma undefE : nm_undef = to (@UM.Undef nat_ordType A nonz). Proof. by []. Qed.
Lemma defE f : defined f = UM.valid (from f). Proof. by []. Qed.
Lemma emptyE : empty = to (@UM.empty nat_ordType A nonz). Proof. by []. Qed.
Lemma updE k v f : upd k v f = to (UM.upd k v (from f)). Proof. by []. Qed.
Lemma domE f : dom f = UM.dom (from f). Proof. by []. Qed.
Lemma dom_eqE f1 f2 : dom_eq f1 f2 = UM.dom_eq (from f1) (from f2).
Proof. by []. Qed.
Lemma freeE k f : free k f = to (UM.free k (from f)). Proof. by []. Qed.
Lemma findE k f : find k f = UM.find k (from f). Proof. by []. Qed.
Lemma unionE f1 f2 : union f1 f2 = to (UM.union (from f1) (from f2)).
Proof. by []. Qed.
Lemma nmfiltE q f : nm_filter q f = to (UM.um_filter q (from f)).
Proof. by []. Qed.
Lemma empbE f : empb f = UM.empb (from f). Proof. by []. Qed.
Lemma undefbE f : undefb f = UM.undefb (from f). Proof. by []. Qed.
Lemma ptsE k v : pts k v = to (@UM.pts nat_ordType A nonz k v).
Proof. by []. Qed.

End NMDef.
End NMDef.

Notation natmap := NMDef.tp.

Definition natmapMixin A :=
  UMCMixin (@NMDef.ftE A) (@NMDef.tfE A) (@NMDef.defE A)
           (@NMDef.undefE A) (@NMDef.emptyE A) (@NMDef.updE A)
           (@NMDef.domE A) (@NMDef.dom_eqE A) (@NMDef.freeE A)
           (@NMDef.findE A) (@NMDef.unionE A) (@NMDef.nmfiltE A)
           (@NMDef.empbE A) (@NMDef.undefbE A) (@NMDef.ptsE A).

Canonical nat_mapUMC A :=
  Eval hnf in UMC (natmap A) (@natmapMixin A).

(* we add the canonical projections matching against naked type *)
(* thus, there are two ways to get a PCM for a union map: *)
(* generic one going through union_map_classPCM, and another by going *)
(* through union_mapPCM. Luckily, they produce equal results *)
(* and this is just a matter of convenience *)
(* Ditto for the equality type *)

Definition nat_mapPCMMix A := union_map_classPCMMix (nat_mapUMC A).
Canonical nat_mapPCM A := Eval hnf in PCM (natmap A) (@nat_mapPCMMix A).

Definition nat_mapCPCMMix A := union_map_classCPCMMix (nat_mapUMC A).
Canonical nat_mapCPCM A := Eval hnf in CPCM (natmap A) (@nat_mapCPCMMix A).

Definition nat_mapTPCMMix A := union_map_classTPCMMix (nat_mapUMC A).
Canonical nat_mapTPCM A := Eval hnf in TPCM (natmap A) (@nat_mapTPCMMix A).

Definition nat_map_eqMix (A : eqType) :=
  @union_map_class_eqMix nat_ordType A _ _ (@natmapMixin A).
Canonical nat_map_eqType (A : eqType) :=
  Eval hnf in EqType (natmap A) (@nat_map_eqMix A).

Definition nm_pts A (k : nat) (v : A) :=
  @UMC.pts nat_ordType A (@nat_mapUMC A) k v.

Notation "x \-> v" := (@nm_pts _ x v) (at level 30).

Lemma nm_dom0 A (h : natmap A) : (h = um_undef \/ h = Unit) <-> (dom h = [::]).
Proof.
split=>[|E]; first by case=>->; rewrite ?dom_undef ?dom0.
case V : (valid h); last by move/invalidE: (negbT V)=>->; left.
by rewrite (dom0E V) ?E //; right.
Qed.

(***************************************)
(***************************************)
(* Constructions of last_key and fresh *)
(***************************************)
(***************************************)

Section FreshLastKey.
Variable A : Type.
Implicit Type h : natmap A.

Definition last_key h := last 0 (dom h).
Definition fresh h := (last_key h).+1.

Lemma lastkey_undef : last_key um_undef = 0.
Proof. by rewrite /last_key !umEX. Qed.

Lemma lastkey0 : last_key Unit = 0.
Proof. by rewrite /last_key /Unit /= !umEX. Qed.

Lemma lastkey_dom h : valid h -> last_key h \notin dom h -> h = Unit.
Proof.
rewrite /valid /= /last_key /Unit /= !umEX /= -{4}[h]UMC.tfE.
case: (UMC.from h)=>//=; case=>s H /= H1 _ /seq_last_in.
rewrite /UM.empty UMC.eqE UM.umapE /supp fmapE /= {H H1}.
by elim: s.
Qed.

Lemma dom_lastkey0P h : last_key h = 0 <-> dom h = [::].
Proof.
rewrite -nm_dom0; split; last first.
- by case=>E; subst h; rewrite ?lastkey_undef ?lastkey0.
move=>E; case V : (valid h); last by left; move/invalidE: (negbT V).
right; apply: lastkey_dom=>//; rewrite E.
by apply: contraT; rewrite negbK; apply: dom_cond.
Qed.

Lemma dom_lastkey h :  valid h -> ~~ empb h -> last_key h \in dom h.
Proof. by move=>X; apply: contraR; move/(lastkey_dom X)=>->; apply/empbP. Qed.

Lemma lastkeyxx h : valid h -> last_key h = 0 -> h = Unit.
Proof.
by move=>V H; apply: lastkey_dom V _; apply/negP=>/dom_cond; rewrite H.
Qed.

Lemma dom_lastkeyE h a : a < last_key h -> last_key h \in dom h.
Proof.
move=>H; case V : (valid h); last first.
- by move/invalidE: (negbT V) H=>->; rewrite lastkey_undef.
by apply: dom_lastkey V (contraL _ H)=>/empbE ->; rewrite lastkey0.
Qed.

Lemma lastkey_max h x : x \in dom h -> x <= last_key h.
Proof.
rewrite /last_key /= !umEX; case: (UMC.from h)=>//; case=>s H _ /=.
rewrite /supp /ord /= (leq_eqVlt x) orbC.
by apply: sorted_last_key_max (sorted_oleq H).
Qed.

Lemma max_lastkey h x :
        x \in dom h -> {in dom h, forall y, y <= x} -> last_key h = x.
Proof.
rewrite /last_key !umEX; case: (UMC.from h)=>//; case=>s H _ /=.
move=>H1 /= H2; apply: sorted_max_key_last (sorted_oleq H) H1 _.
by move=>z /(H2 z); rewrite leq_eqVlt orbC.
Qed.

Lemma lastkeyPt (x : nat) v : x != 0 -> last_key (x \-> v) = x.
Proof. by rewrite /last_key domPtK /= => ->. Qed.

Lemma hist_path h : path oleq 0 (dom h).
Proof.
rewrite !umEX; case: (UMC.from h)=>// {h} h /= _; case: h; case=>//= x s H.
rewrite {1}/oleq /ord /= orbC -leq_eqVlt /=.
by apply: sub_path H=>z y; rewrite /oleq=>->.
Qed.

Lemma lastkey_mono h1 h2 :
        {subset dom h1 <= dom h2} -> last_key h1 <= last_key h2.
Proof. by rewrite leq_eqVlt orbC; apply: seq_last_mono; apply: hist_path. Qed.

Lemma lastkeyfUn h1 h2 :
        valid (h1 \+ h2) -> last_key h1 <= last_key (h1 \+ h2).
Proof. by move=>X; apply: lastkey_mono=>x; rewrite domUn inE X => ->. Qed.

Lemma lastkeyUnf h1 h2 :
        valid (h1 \+ h2) -> last_key h2 <= last_key (h1 \+ h2).
Proof. by rewrite joinC; apply: lastkeyfUn. Qed.

(* a convenient rephrasing of above lemmas *)

Lemma lastkeyUn_mono h1 h2 t :
        valid (h1 \+ h2) -> last_key (h1 \+ h2) < t -> last_key h1 < t.
Proof.
move=>V; apply/leq_trans/lastkey_mono.
by move=>x D; rewrite domUn inE V D.
Qed.

Lemma lastkeyUn0 h1 h2 :
        valid (h1 \+ h2) ->
        last_key h1 = last_key h2 -> (h1 = Unit) * (h2 = Unit).
Proof.
move=>V E.
case E1: (empb h1).
- move/empbE: E1 E V=>->; rewrite unitL lastkey0.
  by case/esym/dom_lastkey0P/nm_dom0=>-> //; rewrite valid_undef.
case E2: (empb h2).
- move/empbE: E2 E V=>->; rewrite unitR lastkey0.
  by case/dom_lastkey0P/nm_dom0=>-> //; rewrite valid_undef.
case: validUn (V)=>// _ _ /(_ _ (dom_lastkey (validL V) (negbT E1))).
by rewrite E (dom_lastkey (validR V) (negbT E2)).
Qed.

Lemma lastkeyUn h1 h2 :
        last_key (h1 \+ h2) =
        if valid (h1 \+ h2) then maxn (last_key h1) (last_key h2) else 0.
Proof.
have H k1 k2 : valid (k1 \+ k2) ->
  last_key k1 < last_key k2 -> last_key (k1 \+ k2) = last_key k2.
- move=>V H; apply: max_lastkey=>[|x].
  - by rewrite domUn inE V (dom_lastkeyE H) orbT.
  rewrite domUn inE V; case/orP; move/lastkey_max=>// T;
  by apply: leq_trans T (ltnW H).
case V : (valid _); last first.
- by move/invalidE: (negbT V)=>->; rewrite lastkey_undef.
rewrite /maxn; case: ltngtP.
- by rewrite joinC in V *; apply: H.
- by apply: H.
by move/esym/(lastkeyUn0 V)=>E; rewrite !E unitL.
Qed.

Lemma lastkeyPtUn h t u :
        valid h -> last_key h < t -> valid (t \-> u \+ h).
Proof.
move=>V L; rewrite validPtUn; apply/and3P; split=>//=.
- by rewrite -lt0n; apply: leq_ltn_trans L.
by apply: contraL L; move/lastkey_max; case: leqP.
Qed.

(* freshness *)

Lemma dom_ordfresh h x : x \in dom h -> x < fresh h.
Proof. by move/lastkey_max. Qed.

Lemma dom_freshn h n : fresh h + n \notin dom h.
Proof. by apply: contra (@dom_ordfresh _ _) _; rewrite -leqNgt leq_addr. Qed.

Lemma dom_freshUn h1 h2 : valid h1 -> [pcm h2 <= h1] -> fresh h1 \notin dom h2.
Proof.
move=>V [x E]; rewrite {h1}E in V *; apply: contra (@dom_ordfresh _ _) _.
by rewrite joinC in V *; rewrite -leqNgt; apply: lastkeyUnf.
Qed.

Lemma dom_fresh h : fresh h \notin dom h.
Proof. by move: (dom_freshn h 0); rewrite addn0.  Qed.

Lemma valid_freshUn h1 h2 v :
        valid h1 -> [pcm h2 <= h1] -> valid (fresh h1 \-> v \+ h2) = valid h2.
Proof.
move=>V [x E]; rewrite {h1}E in V *.
by rewrite validPtUn dom_freshUn // andbT.
Qed.

Lemma valid_fresh h v : valid (fresh h \-> v \+ h) = valid h.
Proof. by rewrite validPtUn dom_fresh andbT. Qed.

Lemma lastkey_freshUn h1 h2 v :
        valid h1 -> [pcm h2 <= h1] ->
        last_key (fresh h1 \-> v \+ h2) = fresh h1.
Proof.
move=>V [x E]; rewrite {h1}E in V *.
apply: max_lastkey=>[|y] /=.
- by rewrite domUn inE valid_freshUn // (validL V) domPt inE eq_refl.
rewrite domUn inE valid_freshUn // (validL V) /= domPt inE /= eq_sym.
rewrite leq_eqVlt; case: eqP=>//= _ D.
by apply: lastkey_max; rewrite domUn inE V D.
Qed.

Lemma lastkey_fresh h v : valid h -> last_key (fresh h \-> v \+ h) = fresh h.
Proof.
move=>Vf; apply: max_lastkey=>[|x] /=.
- by rewrite domUn inE valid_fresh Vf domPt inE eq_refl.
rewrite domUn inE /= valid_fresh Vf /= domPt inE /= eq_sym.
by rewrite leq_eqVlt; case: eqP=>//= _; apply: dom_ordfresh.
Qed.

(* pcm induced ordering *)

Lemma umpleq_lastkey h1 h2 :
        valid h2 -> [pcm h1 <= h2] -> last_key h1 <= last_key h2.
Proof.
by move=>V H; case: H V=>z->V; apply: lastkey_mono=>k D; rewrite domUn inE V D.
Qed.

(* backward induction on valid natmaps *)

Lemma valid_indb (P : natmap A -> Prop) :
        P Unit ->
        (forall u, P (1 \-> u)) ->
        (forall t u h, P h -> last_key h < t ->
                       valid (t \-> u \+ h) -> P (t \-> u \+ h)) ->
        forall h, valid h -> P h.
Proof.
move=>H1 H2 H3; elim/um_indb=>//=.
- by rewrite -[valid _]negbK; move/negP/invalidE.
move=>k v f H V K _.
case E: (empb f); last first.
- apply: H3=>//; first by apply: H (validR V).
  apply: K; apply: contraR (negbT E).
  by rewrite -empbE; apply: lastkey_dom (validR V).
move/empbE: {K H} E V=>->; rewrite unitR => V.
move: (H3 k v Unit H1); rewrite unitR lastkey0 lt0n.
by apply=>//; rewrite validPt /= in V.
Qed.

(* forward induction on valid natmaps *)

Lemma valid_indf (P : natmap A -> Prop) :
        P Unit ->
        (forall t u h, P h ->
           (forall x, x \in dom h -> t < x) ->
           valid (t \-> u \+ h) -> P (t \-> u \+ h)) ->
        forall h, valid h -> P h.
Proof.
move=>H1 H2; elim/um_indf=>//=.
- by rewrite -[valid _]negbK; move/negP/invalidE.
move=>k v f H V K _.
apply: H2=>//; first by apply: H (validR V).
move=>x; move/(order_path_min (@ordtype.trans _)): K.
by case: allP=>// X _; apply: X.
Qed.

End FreshLastKey.

(*******************)
(*******************)
(* Gapless natmaps *)
(*******************)
(*******************)

Section Gapless.
Variable A : Type.
Implicit Type h : natmap A.

Definition gapless h := forall k, 0 < k <= last_key h -> k \in dom h.

Lemma gp_undef : gapless um_undef.
Proof. by move=>k; rewrite lastkey_undef; case: k. Qed.

Lemma gp0 : gapless Unit.
Proof. by move=>k; rewrite lastkey0; case: k. Qed.

Lemma gp_fresh h u : gapless (fresh h \-> u \+ h) <-> gapless h.
Proof.
case V : (valid h); last first.
- by move/invalidE: (negbT V)=>->; rewrite join_undefR.
split=>H k; move: (V); rewrite -(valid_fresh _ u)=>V'; last first.
- rewrite lastkey_fresh // domPtUn inE V' /= (leq_eqVlt k) eq_sym.
  by move: (H k); rewrite -(ltnS k); case: ltngtP.
rewrite -(ltnS k) -/(fresh h); case/andP=>Z N.
move: (H k); rewrite lastkey_fresh // domPtUn inE V' Z /= leq_eqVlt eq_sym.
by case: ltngtP N=>//= _ _; apply.
Qed.

Lemma gpPtUn h k u :
        valid (k \-> u \+ h) ->
        gapless (k \-> u \+ h) -> last_key h < k -> k = fresh h.
Proof.
move=>V C N; apply/eqP/contraT=>X.
have Y : fresh h < k by rewrite leq_eqVlt eq_sym (negbTE X) in N.
suff Z : last_key (k \-> u \+ h) = k.
- move: (C (fresh h)); rewrite Z (leq_eqVlt _ k) Y orbT andbT => /(_ erefl).
  rewrite domPtUn inE (negbTE X) /=; case/andP=>_ /dom_ordfresh.
  by rewrite ltnn.
apply: max_lastkey (find_some (findPtUn V)) _ => x.
rewrite domUn inE; case/andP=>_ /orP [].
- by rewrite domPt inE; case/andP=>_ /eqP ->.
by move/lastkey_max/leq_ltn_trans/(_ N)/ltnW.
Qed.
End Gapless.

Arguments gp_fresh [A][h] u.

(*****************************)
(*****************************)
(* Natmaps with binary range *)
(*****************************)
(*****************************)

Section AtVal.
Variable A : Type.
Implicit Type h : natmap (A * A).

Definition atval v t h := oapp snd v (find t h).

Lemma umpleq_atval v t h1 h2 :
        gapless h1 -> valid h2 -> [pcm h1 <= h2] -> t <= last_key h1 ->
        atval v t h2 = atval v t h1.
Proof.
move=>G V H K; rewrite /atval; case E1 : (find t h1)=>[a|].
- by rewrite (umpleq_some V H E1).
case: t K E1 => [|t] K E1; last by move: (G t.+1 K) (find_none E1)=>->.
by case E2 : (find 0 h2)=>//; move/find_some/dom_cond: E2.
Qed.

Definition last_val v h := atval v (last_key h) h.

Lemma lastval0 v : last_val v Unit = v.
Proof. by rewrite /last_val /atval lastkey0 find0E. Qed.

Lemma lastvalPt v p x : p != 0 -> last_val v (p \-> x) = x.2.
Proof.
by move=>V; rewrite /last_val /atval lastkeyPt // findPt /= V.
Qed.

Lemma lastval_fresh v x h :
        valid h -> last_val v (fresh h \-> x \+ h) = x.2.
Proof.
by move=>V; rewrite /last_val /atval lastkey_fresh // findPtUn // valid_fresh.
Qed.

Lemma lastvalUn v h1 h2 :
        last_val v (h1 \+ h2) =
        if valid (h1 \+ h2) then
          if last_key h1 < last_key h2 then last_val v h2 else last_val v h1
        else v.
Proof.
rewrite /last_val /atval lastkeyUn maxnC /maxn.
case: ifP; last by move/negbT/invalidE=>->; rewrite find_undef.
case: ltngtP=>N V.
- by rewrite findUnR // (dom_lastkeyE N).
- by rewrite findUnL // (dom_lastkeyE N).
by rewrite !(lastkeyUn0 V N) unitL lastkey0 find0E.
Qed.

Lemma lastval_freshUn v x h1 h2 :
        valid h1 -> [pcm h2 <= h1] ->
        last_val v (fresh h1 \-> x \+ h2) = x.2.
Proof.
move=>V H; rewrite /last_val /atval.
rewrite lastkey_freshUn // findPtUn // valid_freshUn //.
by case: H V=>h -> /validL.
Qed.

End AtVal.

(* Continuous maps with binary range *)

Section Continuous.
Variable A : Type.
Implicit Type h : natmap (A * A).

Definition continuous v h :=
  forall k x, find k.+1 h = Some x -> oapp snd v (find k h) = x.1.

Lemma cn_undef v : continuous v um_undef.
Proof. by move=>x w; rewrite find_undef. Qed.

Lemma cn0 v : continuous v Unit.
Proof. by move=>x w; rewrite find0E. Qed.

Lemma cn_fresh v h x :
        valid h ->
        continuous v (fresh h \-> x \+ h) <->
        continuous v h /\ last_val v h = x.1.
Proof.
rewrite -(valid_fresh _ x)=>V; split; last first.
- case=>C H k y; rewrite !findPtUn2 // eqSS; case: ltngtP=>N.
  - by rewrite ltn_eqF; [apply: C | apply: (ltn_trans N _)].
  - by move/find_some /dom_ordfresh /(ltn_trans N); rewrite ltnn.
  by case=><-; rewrite N ltn_eqF.
move=>C; split; last first.
- move: (C (last_key h) x).
  by rewrite !findPtUn2 // eq_refl ltn_eqF //; apply.
move=>k w; case: (ltnP k (last_key h))=>N; last first.
- by move/find_some /dom_ordfresh /(leq_ltn_trans N); rewrite ltnn.
by move: (C k w); rewrite !findPtUn2 // eqSS !ltn_eqF // (ltn_trans N _).
Qed.

Lemma cn_sub v h x y k :
        valid (k.+1 \-> (x, y) \+ h) -> continuous v (k.+1 \-> (x, y) \+ h) ->
        oapp snd v (find k h) = x.
Proof.
by move=>V /(_ k (x, y)); rewrite !findPtUn2 // eq_refl ltn_eqF //; apply.
Qed.

End Continuous.

Arguments cn_fresh [A][v][h][x] _.

(* Complete natmaps with binary range *)

Section Complete.
Variable A : Type.
Implicit Type h : natmap (A * A).

Definition complete v0 h vn :=
  [/\ valid h, gapless h, continuous v0 h & last_val v0 h = vn].

Lemma cm_valid v0 h vn : complete v0 h vn -> valid h.
Proof. by case. Qed.

Lemma cm0 v : complete v Unit v.
Proof. by split=>//; [apply: gp0 | apply: cn0 | rewrite lastval0]. Qed.

Lemma cm_fresh v0 vn h x :
        complete v0 (fresh h \-> x \+ h) vn <-> vn = x.2 /\ complete v0 h x.1.
Proof.
split.
- by case=>/validR V /gp_fresh G /(cn_fresh V) []; rewrite lastval_fresh.
case=>-> [V] /(gp_fresh x) G C E; split=>//;
by [rewrite valid_fresh | apply/(cn_fresh V) | rewrite lastval_fresh].
Qed.

Lemma cmPtUn v0 vn h k x :
        complete v0 (k \-> x \+ h) vn -> last_key h < k -> k = fresh h.
Proof. by case=>V /(gpPtUn V). Qed.

Lemma cmPt v0 vn k x : complete v0 (k \-> x) vn -> k = 1 /\ x = (v0, vn).
Proof.
case; rewrite validPt; case: k=>//= k _ /(_ 1).
rewrite lastkeyPt //= domPt inE /= => /(_ (erefl _))/eqP ->.
move/(_ 0 x); rewrite findPt findPt2 /= => -> //.
by rewrite /last_val lastkeyPt // /atval findPt /= => <-; case: x.
Qed.

Lemma cmCons v0 vn k x h :
        complete v0 (k \-> x \+ h) vn -> last_key h < k ->
         [/\ k = fresh h, vn = x.2 & complete v0 h x.1].
Proof. by move=>C H; move: {C} (cmPtUn C H) (C)=>-> /cm_fresh []. Qed.

End Complete.

Prenex Implicits cm_valid cmPt.


From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts.
Require Import Undecidability.FOL.Arithmetics.FA.
Require Import Undecidability.FOL.Arithmetics.Signature.
Require Import Undecidability.FOL.Arithmetics.Problems.
Require Import Lia List Vector.
Import Vector.VectorNotations.

Set Default Proof Using "Type".

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Notation "x 'i=' y" := (i_atom (P:=Eq) [x ; y]) (at level 30) : PA_Notation.
Notation "'iO'" := (i_func (Σ_funcs:=PA_funcs_signature) (f:=Zero) []) (at level 2) : PA_Notation.
Notation "'iσ' d" := (i_func (f:=Succ) [d]) (at level 37) : PA_Notation.
Notation "x 'i⊕' y" := (i_func (f:=Plus) [x ; y]) (at level 39) : PA_Notation.
Notation "x 'i⊗' y" := (i_func (f:=Mult) [x ; y]) (at level 38) : PA_Notation.

Section FA_models.

  Variable D : Type.
  Variable I : interp D.

  Hypothesis ext_model : extensional I.
  Hypothesis FA_model : forall ax rho, List.In ax FA -> rho ⊨ ax.
  Arguments FA_model _ _ _ : clear implicits.

  (* # <a id="imu" /> #*)
  Fixpoint iμ k := match k with
                   | O => iO
                   | S n => iσ (iμ n)
                   end.

  Fact eval_num sigma n : eval sigma (num n) = iμ n.
  Proof.
    induction n.
    - reflexivity.
    - cbn. now rewrite IHn.
  Qed.

  Lemma add_zero : forall d : D, iO i⊕ d = d.
  Proof using ext_model FA_model.
    intros d.
    assert (List.In ax_add_zero FA) as H by firstorder.
    specialize (FA_model ax_add_zero (d.:(fun _ => iO)) H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Lemma add_rec : forall n d : D, iσ n i⊕ d = iσ (n i⊕ d).
  Proof using ext_model FA_model.
    intros n d.
    assert (List.In ax_add_rec FA) as H by firstorder.
    specialize (FA_model ax_add_rec (d.:(fun _ => iO))  H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Lemma mult_zero : forall d : D, iO i⊗ d = iO.
  Proof using ext_model FA_model.
    intros d.
    assert (List.In ax_mult_zero FA) as H by firstorder.
    specialize (FA_model ax_mult_zero (d.:(fun _ => iO)) H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Lemma mult_rec : forall n d : D, iσ d i⊗ n = n i⊕ d i⊗ n.
  Proof using ext_model FA_model.
    intros n d.
    assert (List.In ax_mult_rec FA) as H by firstorder.
    specialize (FA_model ax_mult_rec (d.:(fun _ => iO)) H).
    cbn in FA_model. now apply ext_model.
  Qed.

  Corollary add_hom x y : iμ (x + y) = iμ x i⊕ iμ y.
  Proof using ext_model FA_model.
    induction x.
    - now rewrite add_zero.
    - change (iσ iμ (x + y) = iσ iμ x i⊕ iμ y).
      now rewrite add_rec, IHx.
  Qed.

  Corollary add_nat_to_model : forall x y z, x + y = z -> (iμ x i⊕ iμ y = iμ z).
  Proof using ext_model FA_model.
    intros x y z H. now rewrite <- add_hom, H.
  Qed.

  Corollary mult_hom x y : iμ (x * y) = iμ x i⊗ iμ y.
  Proof using ext_model FA_model.
    induction x.
    - now rewrite mult_zero.
    - change (iμ (y + x * y) = (iσ iμ x) i⊗ iμ y ).
      now rewrite add_hom, IHx, mult_rec.
  Qed.

  Corollary mult_nat_to_model : forall z x y, x * y = z -> (iμ x i⊗ iμ y = iμ z).
  Proof using ext_model FA_model.
    intros x y z H. now rewrite <- mult_hom, H.
  Qed.

End FA_models.

Arguments iμ {_ _} _.