Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.
(* Require Import MultiSigWallet.Lib.CPDT. *)

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.

Set Typeclasses Iterative Deepening.
(*Set Typeclasses Depth 1.
Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

(* Require Import MultiSigWallet.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs. *)

Require Import depoolContract.Lib.Tactics.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.

Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

(* Existing Instance embeddedMultisig.
Existing Instance monadStateT.
Existing Instance monadStateStateT. *)

Lemma foldLeftAccOrProp: forall l a b,
                       (a <-> b) ->
                       fold_left or l a <-> fold_left or l b.
Proof.
 intros. split. generalize dependent a. generalize dependent b.
 induction l. intros. simpl. simpl in H0. apply H. auto.
 simpl. intros. apply IHl with (a:=or a0 a).
 rewrite H. tauto. auto. intros.
 generalize dependent a. generalize dependent b.
 induction l. intros. simpl. simpl in H0. apply H. auto.
 simpl. intros. apply IHl with (b:=or b a).
 auto. rewrite H. tauto.
 Qed.

Lemma foldLeftAccAndProp: forall l a b,
                       (a <-> b) ->
                       fold_left and l a <-> fold_left and l b.
Proof.
 intros. split. generalize dependent a. generalize dependent b.
 induction l. intros. simpl. simpl in H0. apply H. auto.
 simpl. intros. apply IHl with (a:=and a0 a).
 rewrite H. tauto. auto. intros.
 generalize dependent a. generalize dependent b.
 induction l. intros. simpl. simpl in H0. apply H. auto.
 simpl. intros. apply IHl with (b:=and b a).
 auto. rewrite H. tauto.
 Qed.

Lemma foldLeftOrProp: forall l a b,
                    fold_left or l (a \/ b)  <-> a \/ fold_left or l b.
Proof.
 intros. split; intros.
 generalize dependent a. generalize dependent b.
 induction l.
 intros. simpl in H. simpl. tauto.
 intros. simpl in H. simpl.
 apply IHl. assert ((a0 \/ b) \/ a <-> a0 \/ b \/ a).
 apply or_assoc. rewrite foldLeftAccOrProp. apply H. rewrite H0. tauto.
 generalize dependent a. generalize dependent b.
 induction l.
 intros. simpl in H. simpl. tauto.
 intros. simpl in H. simpl.
 assert ((a0 \/ b) \/ a <-> a0 \/ b \/ a).
 apply or_assoc. rewrite foldLeftAccOrProp. apply IHl.
 apply H. apply H0.
Qed.

Lemma foldLeftPropOrFalse: forall l a,
                    fold_left or l a  <-> a \/ fold_left or l False.
Proof.
 intros. rewrite foldLeftAccOrProp with (b:= a \/ False).
 apply foldLeftOrProp. tauto.
Qed.

Lemma foldLeftAndProp: forall l a b,
                    fold_left and l (a /\ b)  <-> a /\ fold_left and l b.
Proof.
 intros. split; intros.
 generalize dependent a. generalize dependent b.
 induction l.
 intros. simpl in H. simpl. tauto.
 intros. simpl in H. simpl.
 apply IHl. assert ((a0 /\ b) /\ a <-> a0 /\ b /\ a).
 apply and_assoc. rewrite foldLeftAccAndProp. apply H. tauto.
 generalize dependent a. generalize dependent b.
 induction l.
 intros. simpl in H. simpl. tauto.
 intros. simpl in H. simpl.
 assert ((a0 /\ b) /\ a <-> a0 /\ b /\ a).
 apply and_assoc. rewrite foldLeftAccAndProp. apply IHl.
 apply H. tauto.
Qed.

Lemma foldLeftPropAndTrue: forall l a,
                    fold_left and l a  <-> a /\ fold_left and l True.
Proof.
 intros. rewrite foldLeftAccAndProp with (b:= a /\ True).
 apply foldLeftAndProp. tauto.
Qed.

Lemma foldLeftAndProp2: forall l a b,
                    fold_left and l (a /\ b)  <-> b /\ fold_left and l a.
Proof.
 intros. split;intros.
 apply foldLeftPropAndTrue in H.
 split. inversion H. inversion H0.
 auto. apply foldLeftPropAndTrue.
 inversion H. split. inversion H0. auto.
 auto. inversion H. apply foldLeftPropAndTrue in H1.
 inversion H1. apply foldLeftPropAndTrue.
 split;tauto.
 Qed.

Lemma ErrorValueFalse: forall X E l (x:X) (e:E) ,
           toErrorProp l x e -> toValueProp l x -> False.
Proof.
 intros. induction l.
 compute in H. compute in H0. auto.
 simpl in H. unfold toValueProp in H0.
 simpl in H0. unfold toErrorProp in H.
 simpl  in H. remember (a x).
 destruct p. simpl in H0.
 simpl in H. rewrite foldLeftPropOrFalse in H.
 inversion H. inversion_clear H1.
 rewrite foldLeftPropAndTrue in H2.
 inversion H2. rewrite foldLeftPropAndTrue in H0.
 inversion H0. unfold not  in H5. apply H5. auto.
 apply IHl. unfold toErrorProp.
 match goal with
 | H1: fold_left or ?h False |- _ => remember h
 end. destruct l0. simpl in H1. inversion H1.
 simpl in H1. rewrite foldLeftAccOrProp. apply H1.
 tauto. apply foldLeftPropAndTrue in H0.
 inversion  H0. unfold toValueProp.
 remember (List.map (fun p : X -> Prop * E => ~ fst (p x)) l).
 destruct l0. apply I. simpl in H3.
 rewrite foldLeftAccAndProp . apply H3.
 tauto.
 Qed.

Lemma forallEqEq: forall X (P:X -> Prop) Q A,
           (forall x, P x -> A) ->
           (forall x, P x <-> Q x) ->
           (forall x, Q x -> A).
Proof.
 intros. apply X0 with (x:=x). apply H. apply H0. Qed.

Lemma ForallFoldEqProp: forall (l:list Prop) P,
                        (Forall (@Datatypes.id Prop) l /\ P) <-> fold_left and l P.
Proof.
 intros. split. intros.
 generalize dependent P. induction l. intros.
 simpl. inversion H. auto. intros.
 inversion H. simpl. apply foldLeftAndProp2.
 inversion H0. unfold Datatypes.id in H4.
 split. auto. apply IHl. split.
 auto. auto.
 generalize dependent P. induction l; intros.
 split. constructor. tauto.
 split. constructor. simpl in H.
 apply foldLeftAndProp2 in H.
 inversion H. tauto. simpl in  H.
 apply foldLeftAndProp2 in H. inversion H.
 apply IHl in H1. inversion H1. auto.
 simpl in  H.
 apply foldLeftAndProp2 in H. inversion H.
 apply IHl in H1. inversion H1. auto.
 Qed.

Lemma toValueForall: forall X E (l: list (X -> (Prop * E)%type)) (x:X), toValueProp l x <->
                                       Forall not (List.map (fun p => fst (p x)) l).
Proof.
  intros. split; intros.
  induction l. simpl. compute in H. constructor.
  simpl. constructor. unfold toValueProp in  H.
  simpl in H. apply foldLeftPropAndTrue in H.
  inversion H. auto. apply IHl.
  unfold toValueProp in  H.
  simpl in H. apply foldLeftPropAndTrue in H.
  inversion H. unfold toValueProp.
  destruct l. simpl. auto. simpl. simpl in H1.
  apply foldLeftPropAndTrue in H1.
  apply foldLeftPropAndTrue. inversion_clear H1.
  inversion_clear H2. split; tauto.
  induction l. compute. auto.
  unfold toValueProp. simpl. simpl in  H.
  inversion H. apply IHl in H3.
  apply foldLeftPropAndTrue. split. auto.
  unfold toValueProp in H3. destruct l. simpl. auto.
  simpl. simpl in H3. apply foldLeftPropAndTrue.
  split. split. auto. apply foldLeftPropAndTrue in H3.
  inversion H3. auto. apply foldLeftPropAndTrue in H3.
  inversion H3. auto.
Qed.

Lemma ForallNotFoldEqProp: forall (l:list Prop) P,
                        (Forall not l /\ ~P) <->
                        ~ fold_left or l P.
Proof.
 intros. split; intros.
 unfold not. intros.
 induction l. simpl in H0. inversion H.
 apply H2. auto.  simpl in H0.
 inversion_clear H. inversion H1.
 apply foldLeftPropOrFalse in H0.
 inversion H0. inversion H6.
 congruence. congruence.
 apply IHl. split. auto. auto.
 apply foldLeftPropOrFalse.  right. auto.
 induction l. split. constructor.
 simpl in H. auto.
 simpl in H. unfold  not in H.
 rewrite foldLeftPropOrFalse in H.
 apply Classical_Prop.not_or_and in H.
 inversion H. apply Classical_Prop.not_or_and in H0.
 inversion H0. split. constructor.
 auto. apply IHl. unfold not. intros.
 apply H1. rewrite foldLeftPropOrFalse in H4.
 inversion H4. congruence. auto. auto.
Qed.

Lemma ForallNotFoldEqProp2: forall (l:list Prop) P,
                            fold_left and (List.map (fun p : Prop => ~ p) l) P <->
                            Forall not l /\ P.
Proof.
 intros. split; intros.
 induction l. simpl in H.
 split. constructor. auto.
 simpl in H.
 apply foldLeftPropAndTrue in H.
 inversion H. inversion H0.
 split. constructor. auto.
 apply IHl. apply foldLeftPropAndTrue.
 split. auto. auto. auto.
 induction l. simpl. inversion H.
 auto. simpl. apply foldLeftPropAndTrue.
 split. inversion H. inversion H0.
 split. auto. auto.
 inversion H. inversion H0.
 assert ( Forall not l /\ P). tauto.
 apply IHl in H6. apply foldLeftPropAndTrue in H6.
 apply H6.
 Qed.

Lemma ErrorPropCons1: forall X E (l:list (X -> Prop*E)) a (x:X),
                     (forall e : E, ~ toErrorProp (a :: l) x e) ->
                     (forall e : E, ~ toErrorProp l x e).
Proof.
 intros. unfold not.
 intros. remember (H e).
 apply n. unfold toErrorProp.
 simpl. apply foldLeftPropOrFalse.
 right. unfold toErrorProp in H0.
 match goal with
 | |- fold_left or ?l False => remember l
 end. destruct l0.  simpl.  auto.
 simpl. apply  foldLeftOrProp.
 right. auto.
Qed.

Lemma  ErrorPropCons2_helper: forall X E (l:list (X -> Prop*E)) (x:X),
(List.map (fun p : X -> Prop * E => fst (p x)) l)  =
 (hd nil
     ((fix
       f (l0 : list (X -> Prop * E)) (x0 : X) {struct l0} :
         list (list Prop) :=
         match l0 with
         | nil => nil
         | cons p  ls =>
             cons (cons (fst (p x0)) (hd nil (f ls x0))) (f ls x0)
         end) l x)).
Proof.
 intros. induction l.
 simpl. auto.
 simpl. rewrite IHl. auto.
 Qed.

Lemma ErrorPropCons2: forall X E (l:list (X -> Prop*E)) a (x:X),
                     (forall e : E, ~ toErrorProp (a :: l) x e) ->
                      ~(fst(a x) /\ Forall not (List.map (fun p  => fst (p x)) l)).
Proof.
 intros. unfold not. intros.
 apply H with (e:=snd (a x)).
 unfold toErrorProp. simpl.
 apply foldLeftPropOrFalse.
 left. split; auto.
 apply foldLeftPropAndTrue.
 split. apply H0.
 inversion H0. apply ForallNotFoldEqProp2.
 split. rewrite <- ErrorPropCons2_helper.
 apply H2. auto.
 Qed.

Lemma ErrorPropCons2': forall X E e (l:list (X -> Prop*E)) a (x:X),
                      toErrorProp (a :: l) x e ->
                      ~fst(a x) -> toErrorProp l x e.
Proof.
 intros.
 unfold toErrorProp in H.
 simpl in H. apply foldLeftPropOrFalse in H.
 inversion H. inversion H1.
 apply foldLeftPropAndTrue in H2.
 inversion H2.
 congruence.
 unfold toErrorProp.
 match goal with
 | H1: fold_left or ?l False |- _ => remember l
 end. destruct l0. simpl in H1. auto.
 simpl  in H1. apply foldLeftOrProp in H1.
 inversion H1. inversion H2. auto.
 Qed.

Lemma ErrorPropCons: forall X E (l:list (X -> Prop*E)) a (x:X),
                     (forall e : E, ~ toErrorProp (a :: l) x e) ->
                     (forall e : E, ~ toErrorProp l x e) /\
                      ~(fst(a x) /\ Forall not (List.map (fun p  => fst (p x)) l)).
Proof.
 intros. split. apply ErrorPropCons1 with (a:=a). auto.
  apply ErrorPropCons2. auto.
  Qed.

Lemma ValueTrueErrorFalse: forall X E l (x:X),
toValueProp l x -> (forall (e:E), ~(toErrorProp l x e)).
Proof.
 intros. unfold not.
 intros. apply toValueForall in H. induction l.
 simpl in H. unfold toErrorProp in H0. simpl in H0.
 auto. apply ErrorPropCons2' in H0.
 apply IHl. simpl in H. inversion H.
 auto. auto.  simpl in H. inversion H. auto.
 Qed.

Lemma ErrorPropCons3: forall X E (l:list (X -> Prop*E)) (a:X->Prop*E) (x:X),
                      fst (a x) -> toValueProp l x -> toErrorProp (a :: l) x (snd (a x)).
Proof.
 intros. apply toValueForall in H0.
 unfold toErrorProp. simpl. apply foldLeftPropOrFalse.
 left. split; auto.  rewrite <- ErrorPropCons2_helper.
 apply foldLeftPropAndTrue. split; auto.
 apply ForallNotFoldEqProp2. split; auto.
Qed.

Theorem ErrorValueEquivalence1: forall X E l V (x:X) (f: X -> ErrorValue V E) ,
           (forall e, toErrorProp l x e <-> f x = Error e) ->
           (toValueProp l x <-> exists v, f x = Value v).
Proof.
 intros. split; intros.
 intros.
 remember (f x) as y. destruct y.
 (*1st part - False*)
 assert False. assert (toErrorProp l x e).
 apply H. auto. apply ErrorValueFalse in H1.
 auto. auto. inversion H1.
 (*2nd part  - Value*)
 exists v. auto.
 inversion H0.
 assert (forall e, not (toErrorProp l x e)).
 intros. unfold not. intros. apply H in  H2.
 rewrite H1 in  H2.
 discriminate.
 induction l. unfold toValueProp.
 simpl. auto.
 apply ErrorPropCons in H2.
 inversion_clear H2.
 apply toValueForall. simpl. constructor.
 apply Classical_Prop.not_and_or in H4.
 inversion H4. auto.
 unfold not. intros.
 unfold not in H2.
 assert (f x = Error (snd (a x))).
 apply H. unfold toErrorProp.
 simpl. apply foldLeftPropOrFalse.
 left. split; auto.
 rewrite <- ErrorPropCons2_helper.
 apply foldLeftPropAndTrue.
 split. auto.
 apply ForallNotFoldEqProp2. split.
 apply toValueForall. apply IHl; auto.
 split. intros.
 remember (H3 e). congruence.
 intros. congruence. auto.
 congruence. apply toValueForall.
 apply IHl; auto.
 split. intros.
 remember (H3 e). congruence.
 intros. congruence.
Qed.

Lemma notForallCons: forall {X} (f:X->Prop) a l, ~ Forall f (a::l) <-> ~(f a) \/ ~ Forall f l.
Proof.
 intros. split. intros.
 apply Classical_Prop.not_and_or. unfold not.
 intros. apply H. constructor. apply H0. apply H0.
 intros. unfold not. intros.
 inversion H0. inversion H; auto.
 Qed.

Lemma ForallCons: forall {X} (f:X->Prop) a l,
      Forall f (a::l) <-> (f a) /\ Forall f l.
Proof.
 intros. split. intros.
 inversion H. tauto.
 intros. inversion H. constructor; auto.
 Qed.

Lemma forallAnd: forall X (P:X->Prop) (Q:X->Prop),
      (forall x, P x /\ Q x) <->
      ((forall x, P x) /\ (forall x, Q x)).
Proof.
 intros. split;intros. split; intros;
 apply H. split; apply H.
 Qed.

Lemma existsOrforall: forall X (P:X -> Prop),
      exists x, P x \/ forall x, ~ (P x).
Proof.
 intros. Abort.

Lemma ErrorPropCons4: forall E X (l: list (X->Prop*E)) x a (e:E),
      toErrorProp l x e -> toErrorProp (a::l) x e.
Proof.
 intros.
 unfold toErrorProp.
 simpl. apply foldLeftPropOrFalse.
 right. unfold toErrorProp in H.
 match goal with
 | |- fold_left or ?l _ => remember l
 end.
 destruct l0. inversion H.
 simpl. apply foldLeftOrProp.
 right. auto.
 Qed.

Lemma ValueOrErrorTrue: forall X E l (x:X),
     (forall x, Forall (fun p => fst (p x) \/ ~fst (p x)) l) ->
     toValueProp l x \/ exists (e:E), toErrorProp l x e.
Proof.
 intros. induction l.
 compute. left. auto.
 rewrite toValueForall. simpl.
 rewrite ForallCons.
 assert (forall x : X, (fst (a x) \/ ~ fst (a x)) /\
    Forall
      (fun p : X -> Prop * E => fst (p x) \/ ~ fst (p x))
      l).
 intros.
 remember (ForallCons (X:=X->Prop*E) (fun p => fst (p x0) \/ ~ fst (p x0))).
 rewrite <- i. apply H. rewrite forallAnd in H0.
 inversion_clear H0.
 apply IHl in H2. remember (H1 x). clear Heqo.
 inversion o. right.
 inversion H2.
 exists (snd (a x)).
 apply  ErrorPropCons3; auto.
 inversion H3. inversion H3.
 apply ErrorPropCons4 with (a:=a) in H5.
 exists x1. auto.
 inversion H2. left.
 split; auto. apply toValueForall. auto.
 right. inversion H3.
 apply ErrorPropCons4 with (a:=a) in H4.
 exists x0. auto.
Qed.

Lemma ValuePropDecidable: forall (X:Type) E (l: list (X -> Prop*E)),
      (forall x, Forall (fun p => fst (p x) \/ ~fst (p x)) l) ->
      (forall x, ~toValueProp l x \/ toValueProp l x).
Proof.
 intros. rewrite toValueForall.
 induction  l.  simpl. right. constructor.
 simpl. rewrite ForallCons.
 assert (forall x : X, (fst (a x) \/ ~ fst (a x)) /\
    Forall
      (fun p : X -> Prop * E => fst (p x) \/ ~ fst (p x))
      l).
 intros.
 remember (ForallCons (X:=X->Prop*E) (fun p => fst (p x0) \/ ~ fst (p x0))).
 rewrite <- i. apply H.
 rewrite forallAnd in H0.
 inversion_clear H0. apply IHl in H2.
 remember (H1 x). clear Heqo.
 inversion o. left.
 unfold not. intros.
 inversion H3. tauto.
 inversion H2.
 left.  unfold not. intros.
 inversion  H4. tauto.
 right. tauto.
Qed.

Lemma ValueFalseErrorTrue: forall X E l (x:X),
      (forall x, Forall (fun p => fst (p x) \/ ~fst (p x)) l) ->
     ~toValueProp l x -> exists (e:E), toErrorProp l x e.
Proof.
intros.
assert (toValueProp l x \/ exists (e:E), toErrorProp l x e).
apply ValueOrErrorTrue. auto.
assert (~toValueProp l x \/ toValueProp l x).
apply ValuePropDecidable. auto.
inversion H1; inversion H2; try tauto.
Qed.

Theorem ErrorValueEquivalence2: forall X E l V (x:X) (f: X -> ErrorValue V E),
           (forall x, Forall (fun p => fst (p x) \/ ~fst (p x)) l) ->
           (toValueProp l x <-> exists v, f x = Value v) ->
           ((exists (e:E), toErrorProp l x e) <-> exists e0, f x = Error e0).
Proof.
 intros.
 assert (toValueProp l x \/ exists (e:E), toErrorProp l x e).
 apply ValueOrErrorTrue. auto.
 assert (~toValueProp l x \/ toValueProp l x).
 apply ValuePropDecidable. auto.
 remember (f x) as fx.
 split; intros.
 destruct fx. inversion_clear H2. inversion_clear H3.
 (* try tauto. try assert_succeeds (exists e;  auto). exists e. auto. *)
 exists e. auto. exists e. auto. inversion_clear H2.
 assert False. apply H4. apply H0. exists v. auto. inversion H3.
 apply ErrorValueFalse in H5. inversion H2. apply H0. exists v. auto.
 destruct f. rewrite Heqfx. exists e. auto.
 inversion_clear H3. apply ErrorValueFalse in H2. inversion H2.
 apply H4.
 (* <- *)
 inversion_clear H2. inversion_clear H1.
 assert False. apply H4. apply H2. inversion H1. apply H2.
 apply H0 in H4.
 inversion_clear H4. inversion_clear H3. destruct fx.
 congruence. congruence.
Qed.

Lemma orFalse: forall P, False \/ P <-> P.
Proof.
 intros. split. intros. inversion H. inversion H0.
 auto. intros. right. auto.
Qed.

Lemma andTrue: forall P, P /\ ~False <-> P.
Proof.
 intros. split. intros. inversion H. auto.
 intros. split. auto. unfold not. intros. auto.
Qed.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import RelationClasses.
From MetaCoq.Template Require Import config utils.

From Equations.Prop Require Import DepElim.
From Equations Require Import Equations.

(* Dependent lexicographic order *)
Inductive dlexprod {A} {B : A -> Type}
          (leA : A -> A -> Prop) (leB : forall x, B x -> B x -> Prop)
  : sigT B -> sigT B -> Prop :=
| left_lex :
    forall x x' y y',
      leA x x' ->
      dlexprod leA leB (x;y) (x';y')

| right_lex :
    forall x y y',
      leB x y y' ->
      dlexprod leA leB (x;y) (x;y').

Derive Signature for dlexprod.

Definition lexprod := Subterm.lexprod.
Arguments lexprod {_ _} _ _ _ _.

(* Dependent lexicographic order modulo another relation *)
Inductive dlexmod {A} {B : A -> Type}
    (leA : A -> A -> Prop)
    (eA : A -> A -> Prop)
    (coe : forall x x', eA x x' -> B x -> B x')
    (leB : forall x, B x -> B x -> Prop)
  : sigT B -> sigT B -> Prop :=
| left_dlexmod :
    forall x x' y y',
      leA x x' ->
      dlexmod leA eA coe leB (x;y) (x';y')

| right_dlexmod :
    forall x x' y y' (e : eA x x'),
      leB x' (coe _ _ e y) y' ->
      dlexmod leA eA coe leB (x;y) (x';y').
Derive Signature for dlexmod.

Notation "x ⊩ R1 ⨶ R2" :=
  (dlexprod R1 (fun x => R2)) (at level 20, right associativity).
Notation "R1 ⊗ R2" :=
  (lexprod R1 R2) (at level 20, right associativity).

Notation "x ⊨ e \ R1 'by' coe ⨷ R2" :=
  (dlexmod R1 e coe (fun x => R2)) (at level 20, right associativity).

Lemma acc_dlexprod A B leA leB :
    (forall x, well_founded (leB x)) ->
    forall x,
      Acc leA x ->
      forall y,
        Acc (leB x) y ->
        Acc (@dlexprod A B leA leB) (x;y).
Proof.
  intros hw. induction 1 as [x hx ih1].
  intros y. induction 1 as [y hy ih2].
  constructor.
  intros [x' y'] h. simple inversion h.
  - intro hA. inversion H0. inversion H1. subst.
    eapply ih1.
    + assumption.
    + apply hw.
  - intro hB. rewrite <- H0.
    pose proof (projT2_eq H1) as p2.
    set (projT1_eq H1) as p1 in *; cbn in p1.
    destruct p1; cbn in p2; destruct p2.
    eapply ih2. assumption.
Qed.

Lemma dlexprod_Acc A B leA leB :
    (forall x, well_founded (leB x)) ->
    forall x y,
      Acc leA x ->
      Acc (@dlexprod A B leA leB) (x;y).
Proof.
  intros hB x y hA.
  eapply acc_dlexprod ; try assumption.
  apply hB.
Qed.

#[global]
Instance dlexprod_trans A B RA RB :
    Transitive RA ->
    (forall x, Transitive (RB x)) ->
    Transitive (@dlexprod A B RA RB).
Proof.
  intros hA hB [u1 u2] [v1 v2] [w1 w2] h1 h2.
  revert w1 w2 h2. induction h1 ; intros w1 w2 h2.
  - dependent induction h2.
    + left. eapply hA ; eassumption.
    + left. assumption.
  - dependent induction h2.
    + left. assumption.
    + right. eapply hB ; eassumption.
Qed.

Lemma acc_dlexmod A B
      (leA : A -> A -> Prop) (eA : A -> A -> Prop)
      (coe : forall x x', eA x x' -> B x -> B x')
      (leB : forall x : A, B x -> B x -> Prop)
      (sym : forall x y, eA x y -> eA y x)
      (trans : forall x y z, eA x y -> eA y z -> eA x z) :
    (forall x, well_founded (leB x)) ->
    (forall x x' y, eA x x' -> leA y x' -> leA y x) ->
    (forall x, exists e : eA x x, forall y, coe _ _ e y = y) ->
    (forall x x' y e, coe x x' (sym _ _ e) (coe _ _ e y) = y) ->
    (forall x0 x1 x2 e1 e2 y,
      coe _ _ (trans x0 x1 x2 e1 e2) y =
      coe _ _ e2 (coe _ _ e1 y)
    ) ->
    (forall x x' e y y',
      leB _ y (coe x x' e y') ->
      leB _ (coe _ _ (sym _ _ e) y) y'
    ) ->
    forall x,
      Acc leA x ->
      forall y,
        Acc (leB x) y ->
        forall x' (e : eA x x'),
          Acc (@dlexmod A B leA eA coe leB) (x'; coe _ _ e y).
Proof.
  intros hw hA hcoe coesym coetrans lesym.
  induction 1 as [x hx ih1].
  induction 1 as [y hy ih2].
  intros x' e.
  constructor.
  intros [x'' y''] h. dependent destruction h.
  - specialize (hcoe x'') as [e' he'].
    rewrite <- (he' y'').
    eapply ih1.
    + eapply hA. all: eauto.
    + apply hw.
  - simpl in *.
    specialize ih2 with (x' := x'').
    set (e2 := trans _ _ _ e0 (sym _ _ e)).
    set (e1 := sym _ _ e2).
    replace y'' with (coe _ _ e1 (coe _ _ e2 y''))
      by eauto using coesym.
    eapply ih2. subst e2.
    rewrite coetrans.
    eapply lesym.
    assumption.
Qed.

Lemma dlexmod_Acc A B
      (leA : A -> A -> Prop) (eA : A -> A -> Prop)
      (coe : forall x x', eA x x' -> B x -> B x')
      (leB : forall x : A, B x -> B x -> Prop)
      (sym : forall x y, eA x y -> eA y x)
      (trans : forall x y z, eA x y -> eA y z -> eA x z) :
    (forall x, well_founded (leB x)) ->
    (forall x x' y, eA x x' -> leA y x' -> leA y x) ->
    (forall x, exists e : eA x x, forall y, coe _ _ e y = y) ->
    (forall x x' y e, coe x x' (sym _ _ e) (coe _ _ e y) = y) ->
    (forall x0 x1 x2 e1 e2 y,
      coe _ _ (trans x0 x1 x2 e1 e2) y =
      coe _ _ e2 (coe _ _ e1 y)
    ) ->
    (forall x x' e y y',
      leB _ y (coe x x' e y') ->
      leB _ (coe _ _ (sym _ _ e) y) y'
    ) ->
    forall x y,
      Acc leA x ->
      Acc (@dlexmod A B leA eA coe leB) (x ; y).
Proof.
  intros hB ? hcoe ? ? ? x y h.
  specialize (hcoe x) as h'. destruct h' as [e he].
  rewrite <- (he y).
  eapply acc_dlexmod. all: eauto.
  apply hB.
Qed.

Lemma wf_dlexprod A B (leA : A -> A -> Prop) (leB : forall x : A, B x -> B x -> Prop) :
  well_founded leA ->
  (forall x : A, well_founded (leB x)) ->
  well_founded (dlexprod leA leB).
Proof.
  intros wA wB.
  intros [a b]. eapply dlexprod_Acc. all: eauto.
Qed.

#[global]
Instance WF_precompose {T M} (R : M -> M -> Prop) (m : T -> M) :
  WellFounded R -> WellFounded (precompose R m)
  := wf_precompose R m.


Require Import Foundations.Generalities.uuu.
Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.
Require Import RezkCompletion.auxiliary_lemmas_HoTT.
Require Import RezkCompletion.precategories.

Require Import RezkCompletion.limits.aux_lemmas_HoTT.
Require Import RezkCompletion.limits.terminal.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
Local Notation "f ;; g" := (compose f g)(at level 50).

Section product_def.

Variable C : precategory.

Definition isProductCone (c d p: C) (p1 : p --> c) (p2 : p --> d) :=
  forall (a : C) (f : a --> c) (g : a --> d),
    iscontr (total2 (fun fg : a --> p => dirprod (fg ;; p1 == f)
                                                 (fg ;; p2 == g))).

Definition ProductCone (c d : C) :=
   total2 (fun pp1p2 : total2 (fun p : C => dirprod (p --> c) (p --> d)) =>
             isProductCone c d (pr1 pp1p2) (pr1 (pr2 pp1p2)) (pr2 (pr2 pp1p2))).

Definition Products := forall (c d : C), ProductCone c d.
Definition hasProducts := ishinh Products.

Definition ProductObject {c d : C} (P : ProductCone c d) : C := pr1 (pr1 P).
Definition ProductPr1 {c d : C} (P : ProductCone c d): ProductObject P --> c :=
  pr1 (pr2 (pr1 P)).
Definition ProductPr2 {c d : C} (P : ProductCone c d) : ProductObject P --> d :=
   pr2 (pr2 (pr1 P)).

Definition isProductCone_ProductCone {c d : C} (P : ProductCone c d) :
   isProductCone c d (ProductObject P) (ProductPr1 P) (ProductPr2 P).
Proof.
  exact (pr2 P).
Defined.

Definition ProductArrow {c d : C} (P : ProductCone c d) {a : C} (f : a --> c) (g : a --> d) :
       a --> ProductObject P.
Proof.
  exact (pr1 (pr1 (isProductCone_ProductCone P _ f g))).
Defined.

Lemma ProductPr1Commutes (c d : C) (P : ProductCone c d):
     forall (a : C) (f : a --> c) g, ProductArrow P f g ;; ProductPr1 P == f.
Proof.
  intros a f g.
  exact (pr1 (pr2 (pr1 (isProductCone_ProductCone P _ f g)))).
Qed.

Lemma ProductPr2Commutes (c d : C) (P : ProductCone c d):
     forall (a : C) (f : a --> c) g, ProductArrow P f g ;; ProductPr2 P == g.
Proof.
  intros a f g.
  exact (pr2 (pr2 (pr1 (isProductCone_ProductCone P _ f g)))).
Qed.

Lemma ProductArrowUnique (c d : C) (P : ProductCone c d) (x : C)
    (f : x --> c) (g : x --> d) (k : x --> ProductObject P) :
    k ;; ProductPr1 P == f -> k ;; ProductPr2 P == g ->
      k == ProductArrow P f g.
Proof.
  intros H1 H2.
  set (H := tpair (fun h => dirprod _ _ ) k (dirprodpair H1 H2)).
  set (H' := (pr2 (isProductCone_ProductCone P _ f g)) H).
  apply (base_paths _ _ H').
Qed.

Lemma ProductArrowEta (c d : C) (P : ProductCone c d) (x : C)
    (f : x --> ProductObject P) :
    f == ProductArrow P (f ;; ProductPr1 P) (f ;; ProductPr2 P).
Proof.
  apply ProductArrowUnique;
  apply idpath.
Qed.

Definition ProductOfArrows {c d : C} (Pcd : ProductCone c d) {a b : C}
    (Pab : ProductCone a b) (f : a --> c) (g : b --> d) :
          ProductObject Pab --> ProductObject Pcd :=
    ProductArrow Pcd (ProductPr1 Pab ;; f) (ProductPr2 Pab ;; g).

Lemma ProductOfArrowsPr1 {c d : C} (Pcd : ProductCone c d) {a b : C}
    (Pab : ProductCone a b) (f : a --> c) (g : b --> d) :
    ProductOfArrows Pcd Pab f g ;; ProductPr1 Pcd == ProductPr1 Pab ;; f.
Proof.
  unfold ProductOfArrows.
  rewrite ProductPr1Commutes.
  apply idpath.
Qed.

Lemma ProductOfArrowsPr2 {c d : C} (Pcd : ProductCone c d) {a b : C}
    (Pab : ProductCone a b) (f : a --> c) (g : b --> d) :
    ProductOfArrows Pcd Pab f g ;; ProductPr2 Pcd == ProductPr2 Pab ;; g.
Proof.
  unfold ProductOfArrows.
  rewrite ProductPr2Commutes.
  apply idpath.
Qed.

Lemma postcompWithProductArrow {c d : C} (Pcd : ProductCone c d) {a b : C}
    (Pab : ProductCone a b) (f : a --> c) (g : b --> d)
    {x : C} (k : x --> a) (h : x --> b) :
        ProductArrow Pab k h ;; ProductOfArrows Pcd Pab f g ==
         ProductArrow Pcd (k ;; f) (h ;; g).
Proof.
  apply ProductArrowUnique.
  - rewrite <- assoc, ProductOfArrowsPr1.
    rewrite assoc, ProductPr1Commutes.
    apply idpath.
  - rewrite <- assoc, ProductOfArrowsPr2.
    rewrite assoc, ProductPr2Commutes.
    apply idpath.
Qed.

Lemma precompWithProductArrow {c d : C} (Pcd : ProductCone c d) {a : C}
    (f : a --> c) (g : a --> d) {x : C} (k : x --> a)  :
       k ;; ProductArrow Pcd f g  == ProductArrow Pcd (k ;; f) (k ;; g).
Proof.
  apply ProductArrowUnique.
  -  rewrite <- assoc, ProductPr1Commutes;
     apply idpath.
  -  rewrite <- assoc, ProductPr2Commutes;
     apply idpath.
Qed.

End product_def.

Section test.

Variable C : precategory.
Variable H : Products C.

About ProductObject.
Arguments ProductObject [C] c d {_}.
About ProductObject.
Local Notation "c 'x' d" := (ProductObject  c d )(at level 5).

Check (fun c d : C => c x d).

End test.


Add LoadPath "/Users/sweirich/github/deepspec/metalib/" as Metalib.
Require Import Metalib.Metatheory.

Require Import systemf_ott.

Definition void := t_all (t_var_b 0).
Definition abort : Exp -> Typ -> Exp := e_App.

Lemma abort_spec : forall (d : D) (g : G) (e : Exp),
    exp d g e void -> forall r : Typ,
      type d r ->
      exp d g (abort e r) r.
Proof.
  unfold void, abort.
  intros.
  replace r with (open_Typ_wrt_Typ (t_var_b 0) r).
  - apply exp_App; assumption.
  - reflexivity.
Qed.

Definition unit := t_all (t_arr (t_var_b 0) (t_var_b 0)).
Definition tt   := e_Lam (e_lam (t_var_b 0) (e_var_b 0)).

Lemma lc_Typ_void : lc_Typ void.
Proof.
  eapply lc_t_all. intro X.
  unfold open_Typ_wrt_Typ. simpl.
  eapply lc_t_var_f.
Qed.

Lemma tt_unit : exp nil nil tt unit.
Proof.
  unfold unit. unfold tt.
  pick fresh X and apply exp_Lam.
  unfold open_Exp_wrt_Typ. unfold open_Typ_wrt_Typ.
  simpl.
  pick fresh x and apply exp_lam.
  constructor; repeat (try (left; reflexivity); right).
  unfold open_Exp_wrt_Exp. simpl.
  eapply exp_var; constructor; repeat (try (left; reflexivity); right).
  auto.
Qed.

Definition prod (t1 t2 : Typ) : Typ :=
  t_all (t_arr (t_arr t1 (t_arr t2 (t_var_b 0))) (t_var_b 0)).

Definition pair : Exp :=
  e_Lam
    (e_Lam
       (e_lam (t_var_b 1)
          (e_lam (t_var_b 0)
                 (e_Lam
                    (e_lam (t_arr (t_var_b 2) (t_arr (t_var_b 1) (t_var_b 0)))
                           (e_ap (e_ap (e_var_b 0) (e_var_b 2)) (e_var_b 1))))))).

Lemma pair_typing :
  exp nil nil pair (t_all (t_all (t_arr (t_var_b 1)
                                                (t_arr (t_var_b 0)
                                             (prod (t_var_b 2) (t_var_b 1)))))).
Proof.
  intros.
  unfold pair, prod.
  pick fresh X and apply exp_Lam.
  unfold open_Exp_wrt_Typ, open_Typ_wrt_Typ. simpl.
  pick fresh Y and apply exp_Lam.
  unfold open_Exp_wrt_Typ, open_Typ_wrt_Typ. simpl.

  pick fresh x and apply exp_lam.
  constructor; repeat (try (left; reflexivity); right).
  unfold open_Exp_wrt_Exp. simpl.

  pick fresh y and apply exp_lam.
  constructor; repeat (try (left; reflexivity); right).
  unfold open_Exp_wrt_Exp. simpl.

  pick fresh Z and apply exp_Lam.
  unfold open_Exp_wrt_Typ, open_Typ_wrt_Typ. simpl.

  pick fresh z and apply exp_lam.
  repeat eapply type_arr; constructor; repeat (try (left; reflexivity); right).

  unfold open_Exp_wrt_Exp. simpl.
  repeat eapply exp_ap; repeat (constructor; repeat (try (left; reflexivity); right)).
Qed.

Definition prl : Exp :=
  e_Lam
    (e_Lam
       (e_lam (prod (t_var_b 1) (t_var_b 0))
              (e_ap
                 (e_App (e_var_b 0) (t_var_b 1))
                 (e_lam (t_var_b 1)
                        (e_lam (t_var_b 0)
                               (e_var_b 1)))))).

Definition prr : Exp :=
  e_Lam
    (e_Lam
       (e_lam (prod (t_var_b 1) (t_var_b 0))
              (e_ap
                 (e_App (e_var_b 0) (t_var_b 0))
                 (e_lam (t_var_b 1)
                        (e_lam (t_var_b 0)
                               (e_var_b 0)))))).

Definition sum (t1 t2 : Typ) : Typ :=
  t_all (t_arr (t_arr t1 (t_var_b 0)) (t_arr (t_arr t2 (t_var_b 0)) (t_var_b 0))).

Definition num : Typ :=
  t_all (t_arr (t_var_b 0) (t_arr (t_arr (t_var_b 0) (t_var_b 0)) (t_var_b 0))).


Require Import Coq.Logic.JMeq.
Require Import Eqdep_dec.

Require Import foltl.
Require Import varset.
Require Import dec.
Require Import finite.
Require Import set.

Section Vars.

Context {Ts: Type} {Tv: Ts->Type} {Tc: Ts->Type} {Tp: Type}.
Variable Sg: @Sig Ts Tv Tc Tp.

Definition tm_vars {s'} (tm: term Sg s'): VarSet Sg :=
  match tm with
    Var _ _ v => vsSing Sg v
  | Cst _ _ s => vsEmpty Sg
  end.

Definition lt_vars lt: VarSet Sg :=
  match lt with
    PApp _ n p args => vsGUnion Sg (fun i => tm_vars (args i))
  end.

Definition at_vars a : VarSet Sg :=
  match a with
  | Literal _ a | NLiteral _ a => lt_vars a
  | Eq _ _ t1 t2 | NEq _ _ t1 t2 => vsUnion Sg (tm_vars t1) (tm_vars t2)
  end.

Fixpoint fm_vars f : VarSet Sg :=
  match f with
  | FTrue _ | FFalse _ => vsEmpty Sg
  | Atom _ a => at_vars a
  | And _ f1 f2 | Or _ f1 f2 => vsUnion Sg (fm_vars f1) (fm_vars f2)
  | Ex _ s v f | All _ s v f => fm_vars f
  | F _ f | G _ f => fm_vars f
  end.

Definition removeVars `{K: Finite} {sk: K->Sort} (vk: forall k, variable (sk k)) (e:VarSet Sg): VarSet Sg :=
  fun s => SV.Filter (fun (x:variable s) => NotDec (ExDecidable (ex_dec (fun k => isEq2 (U:=variable) s x (sk k) (vk k))))) (e s).

Definition at_free a: VarSet Sg :=
  match a with
  | Literal _ lt | NLiteral _ lt => lt_vars lt
  | Eq _ _ t1 t2 | NEq _ _ t1 t2 => vsUnion Sg (tm_vars t1) (tm_vars t2)
  end.

Fixpoint free f: VarSet Sg :=
  match f with
  | FTrue _ | FFalse _ => vsEmpty Sg
  | Atom _ a => at_vars a
  | And _ f1 f2 | Or _ f1 f2 => vsUnion Sg (free f1) (free f2)
  | Ex _ s v f | All _ s v f => vsRemove Sg v (free f)
  | F _ f | G _ f => free f
  end.

  Lemma lt_free_X: forall l, lt_vars (ltX Sg l) = lt_vars l.
  Proof.
    intro.
    destruct l; simpl in *; auto.
  Qed.

  Lemma at_free_X: forall a, at_vars (atX Sg a) = at_vars a.
  Proof.
    intro.
    destruct a; simpl; intros; auto.
    apply lt_free_X.
    apply lt_free_X.
  Qed.

  Lemma free_X: forall f, free (X Sg f) = free f.
  Proof.
    induction f; simpl; intros; auto.
    apply at_free_X.
    f_equal.
    apply IHf1.
    apply IHf2.
    rewrite IHf1, IHf2; auto.
    rewrite IHf; auto.
    rewrite IHf; auto.
  Qed.

  Lemma free_Ex: forall s (v: variable s) f, (free (Ex Sg s v f)) = (vsRemove Sg v (free f)).
  Proof.
    intros; reflexivity.
  Qed.

  Lemma free_IAll: forall `{K: Finite} {sk} vk f {s} (v: variable s), vsIn _ v (free (IAll Sg K sk vk f)) -> (vsIn _ v (free f) /\ forall k, existT variable (sk k) (vk k) <> existT variable s v).
  Proof.
    assert (forall `{K: Finite} {sk:K -> Sort} (vk: forall k, variable (sk k)) f {s} (v: variable s), vsIn _ v (free (IAll Sg K sk vk f)) -> (vsIn _ v (free f) /\ forall k, List.In k fin_set -> existT variable (sk k) (vk k) <> existT variable s v)).
    intros T K; unfold IAll.
    generalize (@fin_set T K) as l.
    induction l; simpl; intros; auto.
    apply vsInRemove_elim in H.
    destruct H as [H1 H2].
    split; intros; auto.
    apply (IHl sk vk f); auto.
    destruct H.
    subst.
    intro; apply H2; clear H2.
    inversion H; subst s; reflexivity.
    intro.
    inversion H0; subst s.
    apply inj_pair2_eq_dec in H5; try apply eq_dec.
    subst v.
    now apply (proj2 (IHl sk vk f _ (vk k) H1) _ H).

    intros.
    specialize (H T K sk vk f s v H0); destruct H; split; intros; auto.
    apply H1.
    apply fin_all.
  Qed.

  Lemma free_IEx: forall `{K: Finite} {sk} vk f {s} (v: variable s), vsIn _ v (free (IEx Sg K sk vk f)) -> (vsIn _ v (free f) /\ forall k, existT variable (sk k) (vk k) <> existT variable s v).
  Proof.
    assert (forall `{K: Finite} {sk:K -> Sort} (vk: forall k, variable (sk k)) f {s} (v: variable s), vsIn _ v (free (IEx Sg K sk vk f)) -> (vsIn _ v (free f) /\ forall k, List.In k fin_set -> existT variable (sk k) (vk k) <> existT variable s v)).
    intros T K; unfold IEx.
    generalize (@fin_set T K) as l.
    induction l; simpl; intros; auto.
    apply vsInRemove_elim in H.
    destruct H as [H1 H2].
    split; intros; auto.
    apply (IHl sk vk f); auto.
    destruct H.
    subst.
    intro; apply H2; clear H2.
    inversion H; subst s; reflexivity.
    intro.
    inversion H0; subst s.
    apply inj_pair2_eq_dec in H5; try apply eq_dec.
    subst v.
    now apply (proj2 (IHl sk vk f _ (vk k) H1) _ H).

    intros.
    specialize (H T K sk vk f s v H0); destruct H; split; intros; auto.
    apply H1.
    apply fin_all.
  Qed.

  Lemma free_And: forall f1 f2, free (And _ f1 f2) = (vsUnion Sg (free f1) (free f2)).
  Proof.
    intros.
    reflexivity.
  Qed.

  Lemma free_Or: forall f1 f2,  free (Or _ f1 f2) = (vsUnion Sg (free f1) (free f2)).
  Proof.
    intros; reflexivity.
  Qed.

  Lemma free_IAnd_sub: forall `(K: Finite) fk, vsSubset Sg (free (IAnd _ K fk)) (vsGUnion Sg (fun k => free (fk k))).
  Proof.
    intros; unfold IAnd, vsGUnion; simpl.
    induction fin_set; simpl; intros; auto.
    repeat intro.
    destruct H.

    repeat intro.
    apply vsUnion_elim in H.
    destruct H.
    apply SV.InCUnion_intro with (u:=a); simpl; now auto.
    apply IHs in H; clear IHs.
    apply SV.InCUnion_elim in H.
    destruct H as [u [h1 h2]].
    apply SV.InCUnion_intro with (u0:=u); simpl; intros; auto.
    apply h2.
    apply h1.
  Qed.

  Lemma free_IAnd_sup: forall `(K: Finite) fk, vsSubset Sg (vsGUnion Sg (fun k => free (fk k))) (free (IAnd Sg K fk)).
  Proof.
    intros; unfold IAnd, vsGUnion; simpl.
    induction fin_set; simpl; intros; auto.
    repeat intro.
    destruct H.

    repeat intro.
    apply SV.InCUnion_elim in H; simpl in H.
    destruct H as [u [h1 [h2 h3]]].
    apply h3 in h1; clear h3.
    destruct h2.
    subst u.
    apply vsUnion_l; now auto.
    apply vsUnion_r.
    apply IHs; auto.
    apply SV.InCUnion_intro with (u0:=u); auto.
  Qed.

  Lemma free_IOr_sub: forall `(K: Finite) fk, vsSubset Sg (free (IOr Sg K fk)) (vsGUnion Sg (fun k => free (fk k))).
  Proof.
    intros; unfold IOr, vsGUnion; simpl.
    induction fin_set; simpl; intros; auto.
    repeat intro.
    destruct H.

    repeat intro.
    apply vsUnion_elim in H.
    destruct H.
    apply SV.InCUnion_intro with (u:=a); simpl; now auto.
    apply IHs in H; clear IHs.
    apply SV.InCUnion_elim in H.
    destruct H as [u [h1 h2]].
    apply SV.InCUnion_intro with (u0:=u); simpl; intros; auto.
    apply h2.
    apply h1.
  Qed.

  Lemma free_IOr_sup: forall `(K: Finite) fk, vsSubset Sg (vsGUnion Sg (fun k => free (fk k))) (free (IOr Sg K fk)).
  Proof.
    intros; unfold IOr, vsGUnion; simpl.
    induction fin_set; simpl; intros; auto.
    repeat intro.
    destruct H.

    repeat intro.
    apply SV.InCUnion_elim in H; simpl in H.
    destruct H as [u [h1 [h2 h3]]].
    apply h3 in h1; clear h3.
    destruct h2.
    subst u.
    apply vsUnion_l; now auto.
    apply vsUnion_r.
    apply IHs; auto.
    apply SV.InCUnion_intro with (u0:=u); auto.
  Qed.

End Vars.


(* https://softwarefoundations.cis.upenn.edu/lf-current/Poly.html *)

From LF Require Export C_Lists.

Inductive list (X : Type) : Type :=
    | nil
    | cons (x : X) (l : list X).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
    match count with
    | 0 => nil X
    | S count' => cons X x (repeat X x count')
    end.

Example test_repeat1 : repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 : repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

Module MumbleGrumble.

Inductive mumble : Type :=
    | a
    | b (x : mumble) (y : nat)
    | c.
Inductive grumble (X:Type) : Type :=
    | d (m : mumble)
    | e (x : X).

(*
    Which are well-typed elements of
    grumble X?

    - d (b a 5)        - NO
    - d mumble (b a 5) - YES
    - d bool (b a 5)   - YES
    - e bool true      - YES
    - e mumble (b c 0) - YES
    - e bool (b c 0)   - NO
    - c                - NO

*)

End MumbleGrumble.

Arguments nil {X}.
Arguments cons {X}.
Arguments repeat {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
    match l1 with
    | nil => l2
    | cons h t => cons h (app t l2)
    end.
Fixpoint rev {X:Type} (l:list X) : list X :=
    match l with
    | nil => nil
    | cons h t => app (rev t) (cons h nil)
    end.
Fixpoint length {X : Type} (l : list X) : nat :=
    match l with
    | nil => 0
    | cons _ l' => S (length l')
    end.
Example test_rev1 :
    rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
    rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Notation "x :: y" := (cons x y)
                        (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                        (at level 60, right associativity).

Theorem app_nil_r : forall (X : Type), forall (l : list X),
    l ++ [] = l.
Proof.
    intros X l. induction l.
    - reflexivity.
    - simpl. rewrite -> IHl. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n : list A),
    l ++ m ++ n = (l ++ m) ++ n.
Proof.
    intros A l m n. induction l as [| hl tl IHl ].
    - reflexivity.
    - simpl. rewrite -> IHl. reflexivity.
Qed.

Lemma app_length : forall (X : Type) (l1 l2 : list X),
    length (l1 ++ l2) = length l1 + length l2.
Proof.
    intros X l1 l2. induction l1 as [| h1 t1 IHl1 ].
    - simpl. reflexivity.
    - simpl. rewrite <- IHl1. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
    intros X l1 l2. induction l1 as [| h1 t1 IHl1 ].
    - simpl. rewrite -> app_nil_r. reflexivity.
    - simpl. rewrite -> app_assoc. rewrite <- IHl1. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
    rev (rev l) = l.
Proof.
    intros X l. induction l as [| h t IHl ].
    - reflexivity.
    - simpl. rewrite -> rev_app_distr.
      rewrite -> IHl. simpl. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
    | pair (x : X) (y : Y).
Arguments pair {X} {Y}.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
    match p with
    | (x, y) => x
    end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
    match p with
    | (x, y) => y
    end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
                : list (X * Y) :=
    match lx, ly with
    | [], _ => []
    | _, [] => []
    | x :: tx, y :: ty => (x, y) :: (combine tx ty)
    end.

Check @combine.
Compute (combine [1;2] [false;false;true;true]).

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
    match l with
    | [] => ([], [])
    | (x, y) :: t => (x :: (fst (split t)), (y ::(snd (split t))))
    end.

Example test_split: split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Module OptionPlayground.

Inductive option (X : Type) : Type :=
    | Some (x : X)
    | None.

Arguments Some {X}.
Arguments None {X}.

End OptionPlayground.

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
    match l with
    | nil => None
    | a :: l' => match n with
        | O => Some a
        | S n' => nth_error l' n'
        end
    end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
    match l with
    | nil => None
    | h :: t => Some h
    end.

Check @hd_error : forall X : Type, list X -> option X.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X : Type} (f : X -> X) (n : X) : X :=
    f (f ( f n)).

Check @doit3times : forall X : Type, (X -> X) -> X -> X.

Definition minustwo (n : nat) : nat :=
    n - 2.

Example test_doit3times : doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.
Example test_doit3times' : doit3times negb true = false.
Proof. reflexivity. Qed.

Fixpoint filter {X : Type} (test : X -> bool) (l : list X) : list X :=
    match l with
    | nil => nil
    | h :: t =>
        if test h then h :: (filter test t)
        else filter test t
    end.

Example test_filter1 : filter even [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
    (length l) =? 1.

Example test_filter2 : filter length_is_1 [[1;2]; [3]; [4]; [5;6;7]; []; [8]] = [[3]; [4]; [8]].
Proof. reflexivity. Qed.

Definition filter_even_gt_7 (l : list nat) : list nat :=
    filter (fun n => (even n) && (7 <=? n)) l.

Example test_filter_even_gt7_1 :
    filter_even_gt_7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
filter_even_gt_7 [5;2;6;19;129] = [].
    Proof. reflexivity. Qed.

Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X :=
    ((filter test l), (filter (fun n => negb (test n)) l)).

Example test_partition1: partition odd [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
    match l with
    | nil => nil
    | h :: t => (f h) :: (map f t)
    end.

Example test_map1 : map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.
Example test_map_2 : map odd [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.
Example test_map_3 : map (fun n => [even n; odd n]) [2;1;2;5]
    = [[true;false]; [false;true]; [true;false]; [false;true]].
Proof. reflexivity. Qed.

Lemma map_append : forall (X Y : Type) (f : X -> Y) (l : list X) (h : X),
    map f (l ++ [h]) = map f l ++ [f h].
Proof.
    intros X Y f l h. induction l as [| a t IHl' ].
    - reflexivity.
    - simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
    map f (rev l) = rev (map f l).
Proof.
    intros X Y f l. induction l as [| h t IHl' ].
    - (* l = [] *)
        simpl. reflexivity.
    - (* l = h :: t' *)
        simpl. rewrite <- IHl'. rewrite -> map_append. reflexivity.
Qed.

Fixpoint flat_map {X Y : Type} (f : X -> list Y) (l : list X) : list Y :=
    match l with
    | nil => nil
    | h :: t => (f h) ++ (flat_map f t)
    end.

Example test_flat_map1 : flat_map (fun n => [n;n;n]) [1;5;4] =
    [1;1;1;5;5;5;4;4;4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y :=
    match xo with
    | None => None
    | Some x => Some (f x)
    end.

Fixpoint fold {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
    match l with
    | nil => b
    | h :: t => f h (fold f t b)
    end.

Check (fold andb) : list bool -> bool -> bool.

Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.
Example fold_example2 : fold andb [true; true; false; true] true = false.
Proof. reflexivity. Qed.
Example fold_example3 : fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(*
    fold_types_different

    Observe that the type of fold is
    parameterized by two type variables,
    X and Y, and the parameter f is a
    binary operator that takes an X and
    a Y and returns a Y. Can you think
    of a situation where it would be
    useful for X and Y to be different?

    X and Y must be different if f
    receives input of multiple types.
    So, for example, if
    f = (fun x b => (x <=? 7) && b)
    then X and Y must be different.
*)

Definition constfun {X : Type} (x : X) : nat -> X :=
    fun (k : nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition plus3 := plus 3.
Check plus3 : nat -> nat.

Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Module Exercises.

Definition fold_length {X : Type} (l : list X) : nat :=
    fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall (X : Type) (l : list X),
    fold_length l = length l.
Proof.
    intros X l. induction l as [| h t IHl' ].
    - simpl. reflexivity.
    - simpl. rewrite <- IHl'. reflexivity.
Qed.

Definition fold_map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
    fold (fun h t => f h :: t) l [].

Theorem fold_map_correct : forall (X Y : Type) (f : X -> Y -> Y) (l : list X),
    fold_map f l = map f l.
Proof.
    intros X Y f l. induction l as [| h t IHl' ].
    - reflexivity.
    - simpl. rewrite <- IHl'. reflexivity.
Qed.

Definition prod_curry {X Y Z : Type}
    (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
    (f : X -> Y -> Z) (p : X * Y) : Z :=
    (f (fst p)) (snd p).

Example test_map1' : map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) (x : X) (y : Y),
    prod_curry (prod_uncurry f) x y = f x y.
Proof.
    reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type) (f : (X * Y) -> Z) (p : X * Y),
    prod_uncurry (prod_curry f) p = f p.
Proof.
    intros X Y Z f p. destruct p. reflexivity.
Qed.

(*
    nth_error_informal

    For all lists with length n, the
    @nth_error function given l and n
    as input will return None.

    @nth_error will recursively iterate
    through l. At each step, if l is
    empty, None will be returned.
    Otherwise, if n = 0, the current
    item being checked is returned
    with the Some constructor.

    Let us perform induction on n
    to show that for the length n of
    any list, @nth_error l n will always
    return None.

    In the case where n = 0, l is empty.
    Therefore, by our @nth_error
    definition, None will be returned.

    In the case where n = S n', we know
    that when the recursive step happens,
    the subcall to @nth_error receives
    l', a list that is one element
    shorter than l. Therefore, n' is the
    length of l', as it is one less than
    n. Because of this, the recursive
    steps will always result in the
    check comparing l with an empty list
    evaluating to true, therefore None
    will always be returned.

    By the property of induction, we
    have proved that when n = length l,
    @nth_error l n will always return
    None.
*)

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

Example zero_church_peano : zero nat S O = 0.
Proof. reflexivity. Qed.
Example one_church_peano : one nat S O = 1.
Proof. reflexivity. Qed.
Example two_church_peano : two nat S O = 2.
Proof. reflexivity. Qed.

Definition scc (n : cnat) : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example scc_1 : scc zero = one.
Proof. reflexivity. Qed.
Example scc_2 : scc one = two.
Proof. reflexivity. Qed.
Example scc_3 : scc two = three.
Proof. reflexivity. Qed.

Definition plus (n m : cnat) : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.
Example plus_3 : plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition mult (n m : cnat) : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => n X (m X f) x.

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

Definition exp (n m : cnat) : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => m (X -> X) (n X) f x.

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

End Church.
End Exercises.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Cprime : Universe, ((wd_ A B /\ (col_ A B Cprime /\ col_ A B C)) -> col_ A Cprime C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import String Omega List FunctionalExtensionality Ensembles
        Computation ADT ADTRefinement ADTNotation BuildADTRefinements
        KVEnsembles.

Open Scope string.

Section CacheSpec.

  Variable Key : Type.
  Variable Value : Type.

  Definition CacheSig : ADTSig :=
    ADTsignature {
        "EmptyCache"  : unit → rep,
        "AddKey" : rep × (Key * Value) → rep × bool,
        "UpdateKey" : rep × (Key * (Value -> Value)) → rep × bool,
        "LookupKey"   : rep × Key → rep × (option Value)
  }.

  Definition CacheSpec : ADT CacheSig :=
    ADTRep (Ensemble (Key * Value)) {
        const "EmptyCache" (_ : unit) : rep :=
          ret (fun _ => False),
        meth "AddKey" (r : rep, kv : Key * Value) : bool :=
            { r' | (SubEnsembleInsert kv r (fst r')) /\
                   ((usedKey r (fst kv) /\ snd r' = false) \/
                    (~ usedKey r (fst kv) /\ snd r' = true))},
        meth "UpdateKey" (r : rep, kv : Key * (Value -> Value)) : bool :=
              { r' |
                (Same_set _ (fst r') (EnsembleUpdateKey (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))},
        meth "LookupKey" (r : rep, k : Key) : option Value :=
                v <- {v | ValidLookup r k v};
        ret (r, v)
      }.

End CacheSpec.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved.
SPDX-License-Identifier: MIT-0 *)

Require Import FCF.
Require Import FCF.PRF.
Require Import FCF.ROM.

Set Implicit Arguments.

Class KeyExchange_ROM (
  PrivateKey
  PublicInit
  PublicResponse
  SharedSecret
  DomainRO RangeRO : Set
  )
  (PublicResponse_EqDec : EqDec PublicResponse)
  (SharedSecret_EqDec : EqDec SharedSecret) := {

  keyGen_ROM : OracleComp DomainRO RangeRO (PrivateKey * PublicInit);
  responseFunc_ROM : PublicInit -> OracleComp DomainRO RangeRO (option (SharedSecret * PublicResponse));

}.

Section KeyExchange_IND_CPA_ROM.

  Context `{KE : KeyExchange_ROM}.

  Variable rndSharedSecret : Comp SharedSecret.

  Variable A : PublicInit -> PublicResponse -> SharedSecret -> OracleComp DomainRO RangeRO bool.

  Hypothesis DomainRO_EqDec : EqDec DomainRO.
  Hypothesis RangeRO_EqDec : EqDec RangeRO.
  Variable rndRange : Comp RangeRO.

  Definition KeyExchangeCPA_ROM_G0 :=
    [sk, P] <--$2 keyGen_ROM;
    r <--$ responseFunc_ROM P;
    match r with
    | None => $ret false
    | Some (k, R) =>
      (A P R k)
    end.

  Definition KeyExchangeCPA_ROM_G1 :=
    [sk, P] <--$2 keyGen_ROM;
    r <--$ responseFunc_ROM P;
    match r with
    | None => $ret false
    | Some (_, R) =>
      k <--$$ rndSharedSecret;
      (A P R k)
    end.

  Definition KeyExchangeCPA_O_Advantage :=
    | Pr[ExpROM _ _ rndRange _ KeyExchangeCPA_ROM_G0] - Pr[ExpROM _ _ rndRange _ KeyExchangeCPA_ROM_G1] |.

End KeyExchange_IND_CPA_ROM.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Coq.Program.Equality.
Require Import Coq.btauto.Btauto.
Require Import Coq.Lists.Streams.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
From Coq.ssr Require Import ssreflect ssrfun ssrbool.
From mathcomp.ssreflect Require Import seq eqtype ssrnat.

Set Implicit Arguments.
Set Boolean Equality Schemes.
Set Decidable Equality Schemes.

Notation new_line := (String "010" EmptyString) (only parsing).
Check new_line.

Inductive player := player_1 | player_2.
Axiom later : forall {T}, T.
Definition cell := option player.
Definition cell_to_string (c : cell) : string :=
match c with
|None => " "
|Some player_1 => "X"
|Some player_2 => "O"
end.
Definition board := seq (seq cell).
(*Scheme Equality for option.
Notation cell_beq := (option_beq player_beq). *)

Lemma player_eqbP : Equality.axiom player_beq.
Proof. intros x y. pose proof (@internal_player_dec_bl x y); pose proof (@internal_player_dec_lb x y).
  destruct player_beq ; constructor ; intuition congruence. Qed.
(*Notation internal_cell_dec_bl := (@internal_option_dec_bl _ _ (@internal_player_dec_bl)).
Notation internal_cell_dec_lb := (@internal_option_dec_lb _ _ (@internal_player_dec_lb)). *)
(*Lemma cell_eqbP : Equality.axiom cell_beq.
Proof. intros x y. pose proof (@internal_cell_dec_bl x y); pose proof (@internal_cell_dec_lb x y).
  destruct cell_beq ; constructor ; intuition congruence. Qed.*)

Canonical player_eqMixin := EqMixin player_eqbP.
Canonical player_eqType := Eval hnf in EqType player player_eqMixin.
(*Canonical cell_eqMixin := EqMixin cell_eqbP.
Canonical cell_eqType := Eval hnf in EqType cell cell_eqMixin.*)
Definition empty : cell := None.
Coercion some_player (p : player) : cell := Some p.
Definition set_cell (b : board) (r : nat) (c : nat) (p : player) : board :=
set_nth [::] b r (set_nth empty (nth [::] b r) c p).
Definition get_cell (b : board) (r : nat) (c : nat) : cell := nth empty (nth [::] b r ) c.
Definition get_column (b : board) (c : nat) : seq cell :=
map (fun r => get_cell b r c) [:: 0 ; 1 ; 2 ].
Definition rows (b: board) : seq (seq cell) := b.
Search seq nat.
Definition columns (b : board) : seq (seq cell) :=
map (fun c => get_column b c) [:: 0 ; 1 ; 2 ].
Definition diagonals (b : board) : seq (seq cell) :=
[:: [:: get_cell b 0 0 ; get_cell b 1 1 ; get_cell b 2 2] ; [:: get_cell b 0 2 ; get_cell b 1 1 ; get_cell b 2 0] ].
Definition cells_same_non_empty (s : seq cell) : bool := foldr andb true (map (fun c => c == nth empty s 0) s)&& (nth empty s 0 != empty).
Definition any_cells_same_non_empty (s : seq (seq cell)) : bool :=
foldr orb false (map cells_same_non_empty s).
Definition any_row (b: board) : bool :=
any_cells_same_non_empty (rows b).
Definition any_column (b : board) : bool :=
any_cells_same_non_empty (columns b).
Definition any_diagonal (b : board) : bool :=
any_cells_same_non_empty (diagonals b).
Definition other_player (current_player : player) : player :=
match current_player with
|player_1 => player_2
|player_2 => player_1
end.
Compute nseq 3 empty.
Definition initial_board : board :=
nseq 3 (nseq 3 empty).
Locate "++".
Definition output_row (s: seq cell) : string :=
foldr String.append ""%string (map cell_to_string s) ++ new_line.
Definition output_board (b : board) : string :=
foldr String.append ""%string (map output_row b).
Compute output_board initial_board.
Definition game_result (state : board * player) : option player :=
let (b, current_player) := state in
if any_row b || any_column b || any_diagonal b then Some (other_player current_player) else None.
Definition initial_state : board * player :=
(initial_board, player_1).
Definition game_result_string (p : option player) : string := later.
Definition game_intro : string := later.
Definition main_game (b : board) : unit := later.
Definition input_and_make_move (current_player : player) (b : board): player * board := later.
Definition make_move (b: board) (current_player : player) (r : nat) (c : nat) : board * bool :=
if (r <= 3) && (c <= 3) then (if get_cell b r c == empty then
 (set_cell b r c current_player, true) else (b, false))
 else (b, false).

Fixpoint make_moves (moves : seq (nat*nat)) (state : board*player) : board*player :=
match moves with
|[::] => state
|(r, c) :: moves => let new_state := (fst (make_move (fst state) (snd state) r c), other_player (snd state)) in
make_moves moves new_state
end.

Compute output_board (fst (make_move initial_board player_1 1 2) ).
Compute output_board (fst (make_move (fst (make_move initial_board player_1 1 2)) player_2 1 1) ).
Compute output_board (fst (make_moves [:: (1, 1) ; (2, 2) ; (1, 0) ; (0,0) ; (1, 2)] initial_state)).
Compute game_result (make_moves [:: (1, 1) ; (2, 2) ; (1, 0) ; (0,0) ; (1, 2)] initial_state).
Search (seq _-> seq _-> bool).


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Strings.String.

Import ListNotations.

Set Printing Parentheses.

Inductive typ : Set :=
| typ_int : typ
| typ_top : typ
| typ_arrow : typ -> typ -> typ
| typ_and : typ -> typ -> typ.

Hint Constructors typ : core.

Notation "A → B" := (typ_arrow A B) (at level 20).
Notation "A & B" := (typ_and A B) (at level 20).

Inductive trm : Set :=
| trm_int : nat -> trm
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_abs : trm -> typ -> typ -> trm
| trm_app : trm -> trm -> trm
| trm_merge : trm -> trm -> trm
| trm_anno : trm -> typ -> trm.

Hint Constructors trm : core.

Fixpoint size_typ (A : typ) {struct A} : nat :=
  match A with
  | typ_int => 1
  | typ_top => 1
  | typ_arrow A1 B1 => 1 + (size_typ A1) + (size_typ B1)
  | typ_and A1 B1 => 1 + (size_typ A1) + (size_typ B1)
  end.

Fixpoint size_trm (e : trm) {struct e} : nat :=
  match e with
  | trm_int n => 1
  | trm_bvar n => 1
  | trm_fvar x => 1
  | trm_abs e1 A B => 1 + (size_trm e1) + (size_typ A) + (size_typ B)
  | trm_app e1 e2 => 1 + (size_trm e1) + (size_trm e2)
  | trm_merge e1 e2 => 1 + (size_trm e1) + (size_trm e2)
  | trm_anno e1 A => 1 + (size_trm e1) + (size_typ A)
  end.

Notation "e ∷ A" := (trm_anno e A) (at level 20).
Notation "ƛ. e A → B" := (trm_abs e A B) (at level 20).

Coercion trm_fvar : atom >-> trm.

Fixpoint subst_exp (z : atom) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_int n => trm_int n
  | trm_bvar i => trm_bvar i
  | trm_fvar x => if x == z then u else (trm_fvar x)
  | trm_abs e1 A B => trm_abs (subst_exp z u e1) A B
  | trm_app e1 e2 => trm_app (subst_exp z u e1) (subst_exp z u e2)
  | trm_merge e1 e2 => trm_merge (subst_exp z u e1) (subst_exp z u e2)
  | trm_anno e1 A => trm_anno (subst_exp z u e1) A
  end.

Notation "{ z ↦ u } e" := (subst_exp z u e) (at level 69).

Fixpoint fv (e : trm) {struct e} : atoms :=
  match e with
  | trm_int n => empty
  | trm_bvar i => empty
  | trm_fvar x => singleton x
  | trm_abs e1 A B => fv e1
  | trm_app e1 e2 => (fv e1) `union` (fv e2)
  | trm_merge e1 e2 => (fv e1) `union` (fv e2)
  | trm_anno e1 A => (fv e1)
  end.

Definition ctx : Set := list (var * typ).

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_int n => trm_int n
  | trm_bvar i => if k == i then u else (trm_bvar i)
  | trm_fvar x => trm_fvar x
  | trm_abs t1 A B => trm_abs (open_rec (S k) u t1) A B
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_merge t1 t2 => trm_merge (open_rec k u t1) (open_rec k u t2)
  | trm_anno t1 A => trm_anno (open_rec k u t1) A
  end.

Definition open t u := open_rec 0 u t.

Inductive lc : trm -> Prop :=
| lc_int : forall (n : nat),
    lc (trm_int n)
| lc_var : forall (x : atom),
    lc (trm_fvar x)
| lc_abs : forall (e : trm) (A B : typ) (L : atoms),
    (forall x : atom, x `notin` L -> lc (open e x)) ->
    lc (trm_abs e A B)
| lc_app : forall (e1 e2 : trm),
    lc e1 -> lc e2 ->
    lc (trm_app e1 e2)
| lc_merge : forall (e1 e2 : trm),
    lc e1 -> lc e2 ->
    lc (trm_merge e1 e2)
| lc_anno : forall (e : trm) (A : typ),
    lc e ->
    lc (trm_anno e A).

Hint Constructors lc : core.

Inductive ordinary : typ -> Prop :=
| ord_top : ordinary typ_top
| ord_int : ordinary typ_int
| ord_arrow : forall (A B : typ),
    ordinary B -> ordinary (typ_arrow A B).

Hint Constructors ordinary : core.

Inductive pvalue : trm -> Prop :=
| pvalue_nat : forall (n : nat), pvalue (trm_int n)
| pvalue_abs : forall (e : trm) (A B : typ),
    lc (trm_abs e A B) -> pvalue (trm_abs e A B).

Inductive value : trm -> Prop :=
| value_anno : forall (A : typ) (e : trm),
    pvalue e -> ordinary A -> value (trm_anno e A)
| value_merge : forall (v1 v2 : trm),
    value v1 -> value v2 -> value (trm_merge v1 v2).

Inductive uvalue : trm -> Prop :=
| uvalue_anno : forall (e : trm) (A : typ),
    lc e ->
    uvalue (trm_anno e A)
| uvalue_merge : forall (u1 u2 : trm),
    uvalue u1 -> uvalue u2 -> uvalue (trm_merge u1 u2).

Hint Constructors pvalue : core.
Hint Constructors value : core.
Hint Constructors uvalue : core.

Inductive toplike : typ -> Prop :=
| tl_top : toplike typ_top
| tl_and : forall (A B : typ), toplike A -> toplike B -> toplike (typ_and A B)
| tl_arrow : forall (A B : typ), toplike B -> toplike (typ_arrow A B).

Hint Constructors toplike : core.

Inductive sub_dec : typ -> typ -> Prop :=
| subd_refl : forall (A : typ),
    sub_dec A A
| subd_trans : forall (A B C : typ),
    sub_dec A B -> sub_dec B C -> sub_dec A C
| subd_top : forall (A : typ),
    sub_dec A typ_top
| subd_top_arr :
    sub_dec typ_top (typ_arrow typ_top typ_top)
| subd_arr : forall (A B C D : typ),
    sub_dec B A -> sub_dec C D ->
    sub_dec (typ_arrow A C) (typ_arrow B D)
| subd_and : forall (A B C : typ),
    sub_dec A B -> sub_dec A C ->
    sub_dec A (typ_and B C)
| subd_and_l : forall (A B : typ),
    sub_dec (typ_and A B) A
| subd_and_r : forall (A B : typ),
    sub_dec (typ_and A B) B
| subd_distri_arr : forall (A B C : typ),
    sub_dec (typ_and (typ_arrow A B)
                     (typ_arrow A C))
            (typ_arrow A
                       (typ_and B C)).

Hint Constructors sub_dec : core.

Inductive splitable : typ -> typ -> typ -> Prop :=
| sp_and : forall (A B : typ),
    splitable (typ_and A B) A B
| sp_arrow : forall (A B C D : typ),
    splitable B C D ->
    splitable (typ_arrow A B) (typ_arrow A C) (typ_arrow A D).

Hint Constructors splitable : core.
Notation "B ↩ A ↪ C" := (splitable A B C) (at level 40).

Inductive sub : typ -> typ -> Prop :=
| sub_int :
    sub typ_int typ_int
| sub_top : forall (A B : typ),
    ordinary B -> toplike B ->
    sub A B
| sub_arrow : forall (A B C D : typ),
    sub B A -> sub C D -> ordinary D ->
    sub (typ_arrow A C) (typ_arrow B D)
| sub_and : forall (A B C D : typ),
    splitable D B C ->
    sub A B -> sub A C -> sub A D
| sub_and_l : forall (A B C : typ),
    sub A C -> ordinary C ->
    sub (typ_and A B) C
| sub_and_r : forall (A B C : typ),
    sub B C -> ordinary C ->
    sub (typ_and A B) C.

Hint Constructors sub : core.

Notation "A <: B" := (sub A B) (at level 40).

Definition arg := option typ.

Inductive auxas : arg -> typ -> Prop :=
| aas_refl : forall (A : typ),
    auxas None A
| aas_fun : forall (A B C : typ),
    sub C A ->
    auxas (Some C) (typ_arrow A B)
| aas_and_l : forall (A B C : typ),
    auxas (Some C) A ->
    auxas (Some C) (typ_and A B)
| aas_and_r : forall (A B C : typ),
    auxas (Some C) B ->
    auxas (Some C) (typ_and A B).

Inductive appsub : arg -> typ -> typ -> Prop :=
| as_refl : forall (A : typ),
    appsub None A A
| as_fun : forall (A B C D : typ),
    sub C A ->
    appsub (Some C) (typ_arrow A B) B
| as_and_l : forall (A B C D: typ),
    appsub (Some C) A D ->
    not (auxas (Some C) B) ->
    appsub (Some C) (typ_and A B) D
| as_and_r : forall (A B C D : typ),
    appsub (Some C) B D ->
    not (auxas (Some C) A) ->
    appsub (Some C) (typ_and A B) D
| as_and_both : forall (A B C D1 D2: typ),
    appsub (Some C) A D1 ->
    appsub (Some C) B D2 ->
    appsub (Some C) (typ_and A B) (typ_and D1 D2).

Hint Constructors auxas : core.
Hint Constructors appsub : core.

Notation "S ⊢ A <: B" := (appsub S A B) (at level 40).
Notation "appsub? S A" := (auxas S A) (at level 40).

Definition disjoint_spec A B :=
  forall (C : typ), sub A C -> sub B C -> toplike C.

Inductive disjoint : typ -> typ -> Prop :=
| disj_top_l : forall (A : typ),
    disjoint typ_top A
| disj_top_r : forall (A : typ),
    disjoint A typ_top
| disjoint_and_l : forall (A1 A2 B : typ),
    disjoint A1 B -> disjoint A2 B ->
    disjoint (typ_and A1 A2) B
| disjoint_and_r : forall (A B1 B2 : typ),
    disjoint A B1 -> disjoint A B2 ->
    disjoint A (typ_and B1 B2)
| disjoint_int_arr : forall (A1 A2 : typ),
    disjoint typ_int (typ_arrow A1 A2)
| disjoint_arr_int : forall (A1 A2 : typ),
    disjoint (typ_arrow A1 A2) typ_int
| disjoint_arr_arr : forall (A1 A2 B1 B2 : typ),
    disjoint B1 B2 ->
    disjoint (typ_arrow A1 B1) (typ_arrow A2 B2).

Hint Constructors disjoint : core.

Inductive typedred : trm -> typ -> trm -> Prop :=
| tred_int_anno : forall (n : nat) (A : typ),
    sub A typ_int ->
    typedred (trm_anno (trm_int n) A) typ_int (trm_anno (trm_int n) typ_int)
| tred_top : forall (A : typ) (v : trm),
    lc v ->
    toplike A -> ordinary A ->
    typedred v A (trm_anno (trm_int 1) A)
| tred_arrow_anno : forall (A B C D E : typ) (e : trm),
    lc (trm_abs e A B) ->
    not (toplike D) -> sub E (typ_arrow C D) ->
    ordinary D ->
    typedred (trm_anno (trm_abs e A B) E)
             (typ_arrow C D)
             (trm_anno (trm_abs e A D) (typ_arrow C D))
| tred_merge_l : forall (v1 v2 v1': trm) (A : typ),
    typedred v1 A v1' -> ordinary A ->
    typedred (trm_merge v1 v2) A v1'
| tred_merge_r : forall (v1 v2 v2': trm) (A : typ),
    typedred v2 A v2' -> ordinary A ->
    typedred (trm_merge v1 v2) A v2'
| tred_and : forall (v1 v2 v : trm) (A B C : typ),
    splitable A B C ->
    typedred v B v1 ->
    typedred v C v2 ->
    typedred v A (trm_merge v1 v2).

Hint Constructors typedred : core.

Notation "e ~->> A e'" := (typedred e A e') (at level 68).

Inductive ptype : trm -> typ -> Prop :=
| ptype_int : forall (n : nat),
    ptype (trm_int n) typ_int
| ptype_arrow : forall (e : trm) (A B : typ),
    lc (trm_abs e A B) ->
    ptype (trm_abs e A B) (typ_arrow A B)
| ptype_anno : forall (e : trm) (A : typ),
    lc e ->
    ptype (trm_anno e A) A
| ptype_merge : forall (e1 e2 : trm) (A B : typ),
    ptype e1 A ->
    ptype e2 B ->
    ptype (trm_merge e1 e2) (typ_and A B).

Hint Constructors ptype : core.

Definition consistency_spec v1 v2 :=
  forall (A : typ) (v1' v2' : trm), ordinary A -> typedred v1 A v1' -> typedred v2 A v2' -> v1' = v2'.

Inductive consistent : trm -> trm -> Prop :=
| con_abs_anno : forall (e : trm) (A B1 B2 C D : typ),
    lc (trm_abs e A B1) ->
    consistent (trm_anno (trm_abs e A B1) C) (trm_anno (trm_abs e A B2) D)
| con_anno : forall (e : trm) (A B : typ),
    lc e ->
    consistent (trm_anno e A) (trm_anno e B)
| con_disjoint : forall (u1 u2 : trm) (A B : typ),
    ptype u1 A -> ptype u2 B -> disjoint A B ->
    consistent u1 u2
| con_merge_l : forall (u u1 u2 : trm),
    consistent u1 u ->
    consistent u2 u ->
    consistent (trm_merge u1 u2) u
| con_merge_r : forall (u u1 u2 : trm),
    consistent u u1 ->
    consistent u u2 ->
    consistent u (trm_merge u1 u2).

Hint Constructors consistent : core.

Inductive typing : ctx -> trm -> typ -> Prop :=
| typing_int : forall (T : ctx) (n : nat),
    uniq T -> typing T (trm_int n) typ_int
| typing_var : forall (T : ctx) (x : var) (A : typ),
    uniq T -> binds x A T -> typing T (trm_fvar x) A
| typing_lam : forall (L : vars) (T : ctx) (A B C : typ) (e : trm),
    (forall x, x \notin L -> (typing ((x ~ A) ++ T) (open e (trm_fvar x)) C)) ->
    sub C B ->
    typing T (trm_abs e A B) (typ_arrow A B)
| typing_anno : forall (T : ctx) (A B C : typ) (e : trm),
    typing T e C -> sub C A ->
    typing T (trm_anno e A) A
| typing_app : forall (T : ctx) (A B C : typ) (e1 e2 : trm),
    typing T e2 A ->
    typing T e1 B ->
    appsub (Some A) B C ->
    typing T (trm_app e1 e2) C
| typing_merge : forall (T : ctx) (A B : typ) (e1 e2 : trm),
    disjoint A B ->
    typing T e1 A ->
    typing T e2 B ->
    typing T (trm_merge e1 e2) (typ_and A B)
| typing_merge_uvalue : forall (T : ctx) (A B : typ) (u1 u2 : trm),
    uniq T ->
    uvalue u1 -> uvalue u2 ->
    consistent u1 u2 ->
    typing nil u1 A ->
    typing nil u2 B ->
    typing T (trm_merge u1 u2) (typ_and A B).

Hint Constructors typing : core.

Notation "T ⊢ e ⇒ A" := (typing T e A) (at level 50).

Inductive papp : trm -> trm -> trm -> Prop :=
| papp_int_toplike : forall (A B : typ) (v vl : trm) (n : nat),
    toplike B ->
    papp (trm_anno (trm_int n) (typ_arrow A B)) vl (trm_anno (trm_int 1) B)
| papp_abs_toplike : forall (A B C D : typ) (e v v' : trm),
    lc (trm_abs e A B) ->
    toplike D ->
    papp (trm_anno (trm_abs e A B) (typ_arrow C D)) v
         (trm_anno (trm_int 1) D)
| papp_abs_anno : forall (A B C D : typ) (e v v' : trm),
    lc (trm_abs e A B) ->
    typedred v A v' ->
    not (toplike D) ->
    papp (trm_anno (trm_abs e A B) (typ_arrow C D)) v
         (trm_anno (open e v') D)
| papp_merge_l : forall (A B C : typ) (v1 v2 vl e: trm),
    ptype v1 A -> ptype v2 B -> ptype vl C ->
    not (auxas (Some C) B) ->
    papp v1 vl e ->
    papp (trm_merge v1 v2) vl e
| papp_merge_r : forall (A B C : typ) (v1 v2 vl e : trm),
    ptype v1 A -> ptype v2 B -> ptype vl C ->
    not (auxas (Some C) A) ->
    papp v2 vl e ->
    papp (trm_merge v1 v2) vl e
| papp_merge_p : forall (A B C : typ) (v1 v2 vl e1 e2 : trm),
    ptype v1 A -> ptype v2 B -> ptype vl C ->
    auxas (Some C) A ->
    auxas (Some C) B ->
    papp v1 vl e1 ->
    papp v2 vl e2 ->
    papp (trm_merge v1 v2) vl (trm_merge e1 e2).

Hint Constructors papp : core.

Notation "v ◐ vl ~-> e" := (papp v vl e) (at level 69).

Inductive step : trm -> trm -> Prop :=
| step_int_anno : forall (n : nat),
    step (trm_int n) (trm_anno (trm_int n) typ_int)
| step_abs_anno : forall (e : trm) (A B : typ),
    step (trm_abs e A B) (trm_anno (trm_abs e A B) (typ_arrow A B))
| step_pvalue_split : forall (A A1 A2 : typ) (p : trm),
    pvalue p ->
    splitable A A1 A2 ->
    step (trm_anno p A) (trm_merge (trm_anno p A1) (trm_anno p A2))
| step_papp : forall (v vl e : trm) (A : typ),
    value v -> value vl ->
    papp v vl e ->
    step (trm_app v vl) e
| step_anno_value : forall (v v' : trm) (A : typ),
    value v -> typedred v A v' ->
    step (trm_anno v A) v'
| step_anno : forall (e e' : trm) (A : typ),
    not (pvalue e) ->
    step e e' -> step (trm_anno e A) (trm_anno e' A)
| step_app_l : forall (e1 e2 e1' : trm),
    lc e2 ->
    step e1 e1' -> step (trm_app e1 e2) (trm_app e1' e2)
| step_app_r : forall (v e2 e2' : trm),
    value v -> step e2 e2' -> step (trm_app v e2) (trm_app v e2')
| step_merge_bcd : forall (e1 e1' e2 e2' : trm),
    step e1 e1' ->
    step e2 e2' ->
    step (trm_merge e1 e2) (trm_merge e1' e2')
| step_merge_l : forall (e1 v2 e1' : trm),
    value v2 ->
    step e1 e1' ->
    step (trm_merge e1 v2) (trm_merge e1' v2)
| step_merge_r : forall (v e2 e2' : trm),
    value v -> step e2 e2' ->
    step (trm_merge v e2) (trm_merge v e2').

Hint Constructors step : core.
Notation "e ~-> e'" := (step e e') (at level 68).

Inductive isomorphic : typ -> typ -> Prop :=
| iso_refl : forall (A : typ),
    isomorphic A A
| iso_and : forall (A1 A2 B B1 B2 : typ),
    splitable B B1 B2 ->
    isomorphic A1 B1 ->
    isomorphic A2 B2 ->
    isomorphic (typ_and A1 A2) B.

Hint Constructors isomorphic : core.

Notation "A ≋ B" := (isomorphic A B) (at level 40).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (atom * typ) => dom x) in
  let D := gather_atoms_with (fun x : trm => fv x) in
  constr:(A `union` B `union` C `union` D).