Inductive List (a : Type) : Type := Nil : List a | Cons : a -> List a -> List a.

Arguments Nil {a}.
Arguments Cons {a} x xs.

Definition pointwise_eq {a : Type} {p : a -> Type} (f g : forall x : a, p x) : Prop :=
 forall x : a, f x = g x.

Notation "f == g" := (pointwise_eq f g) (at level 70, no associativity) : type_scope.

Definition id {A : Type} (x : A) : A := x.

Definition compose {A B C : Type} (f : B -> C) (g : A -> B) (x : A) : C := f (g x).

Notation "f 'o' g" := (compose f g) (at level 40, left associativity) : type_scope.

Fixpoint fmap {a b : Type} (f : a -> b) (x : List a) : List b :=
 match x with Nil => Nil | Cons x xs => Cons (f x) (fmap f xs) end.

Module Type Functor.
 Parameter f : Type -> Type.
 Parameter fmap : forall a b, (a -> b) -> f a -> f b.
 Arguments fmap {a b} f x.

 Axiom functor_law_1 : forall a, @id (f a) == fmap (@id a).
 Axiom functor_law_2 : forall a b c, forall (f_ : b -> c) (g_ : a -> b),
  fmap f_ o fmap g_ == fmap (f_ o g_).
End Functor.

Module Functor_List <: Functor.
 Definition f := List.
 Definition fmap := @fmap.
 Arguments fmap {a b} f x.

 Theorem functor_law_1 : forall a, @id (f a) == fmap (@id a).
 Proof.
  intros a.
  intros x.
  induction x.
  -
   apply eq_refl.
  -
   simpl.
   case IHx.
   apply eq_refl.
 Qed.

 Theorem functor_law_2 : forall a b c, forall (f_ : b -> c) (g_ : a -> b),
  fmap f_ o fmap g_ == fmap (f_ o g_).
 Proof.
  intros a b c f_ g_.
  intros x.
  induction x.
  -
   apply eq_refl.
  -
   simpl.
   case IHx.
   apply eq_refl.
 Qed.
End Functor_List.

Module Type Monad (Functor_Instance : Functor).
 Export Functor_Instance.

 Parameter pure : forall a, a -> f a.
 Parameter join : forall a, f (f a) -> f a.
 Arguments pure {a} x.
 Arguments join {a} x.

 Axiom monad_law_1 : forall a, @id (f a) == join o pure.
 Axiom monad_law_2 : forall a, @id (f a) == join o fmap pure.
 Axiom monad_law_3 : forall a, @join (f a) o join == join o fmap join.
End Monad.

Module Free_Lunch (Monad_Instance : Monad Functor_List).
 Export Monad_Instance.

 Theorem join_nil_to_nil : ~ ~ forall a, @Nil a = join Nil.
 Proof.
  intros ng.
  assert (forall a, exists x xs, @Cons a x xs = join Nil).
  -
   intros a.
   generalize (ng a).
   destruct (join Nil).
   +


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Export LTactics GenEncode.
Require Import Undecidability.Shared.Libs.PSL.Numbers.

Require Import Nat.
From Undecidability.L Require Import Datatypes.LBool Functions.EqBool Datatypes.LProd.
Import GenEncode. Import Nat.
(* ** Encoding of natural numbers *)

MetaCoq Run (tmGenEncodeInj "nat_enc" nat).
Hint Resolve nat_enc_correct : Lrewrite.

Instance termT_S : computableTime' S (fun _ _ => (1,tt)).
Proof.
  extract constructor.
  solverec.
Qed.

Instance termT_pred : computableTime' pred (fun _ _ => (5,tt)).
Proof.
  extract.
  solverec.
Qed.

Definition c__add := 11.
Definition c__add1 := 5.
Definition add_time x := (x + 1) * c__add.
Instance termT_plus' : computableTime' add (fun x xT => (c__add1,(fun y yT => (add_time x,tt)))).
Proof.
  extract.
  fold add. solverec.
  all: unfold add_time, c__add1, c__add; solverec.
Qed.

Definition c__mult1 := 5.
Definition c__mult := c__add + c__add1 + 10.
Definition mult_time x y := x * y * c__mult + c__mult * (x+ 1) .
Instance termT_mult : computableTime' mult (fun x xT => (c__mult1,(fun y yT => (mult_time x y,tt)))).
Proof.
  extract. solverec.
  all: unfold mult_time, c__mult1, c__mult, add_time, c__add1, c__add; solverec.
Qed.

Definition c__sub1 := 5.
Definition c__sub := 14.
Definition sub_time x y := (min x y + 1) * c__sub.
Instance term_sub : computableTime' Nat.sub (fun n _ => (c__sub1,fun m _ => (sub_time n m ,tt)) ).
Proof.
  extract. solverec.
  all: unfold sub_time, c__sub1, c__sub; solverec.
Qed.

Definition c__leb := 14.
Definition c__leb2 := 5.
Definition leb_time (x y : nat) := c__leb * (1 + min x y).
Instance termT_leb : computableTime' leb (fun x xT => (c__leb2,(fun y yT => (leb_time x y,tt)))).
Proof.
  extract.
  solverec. all: unfold leb_time, c__leb, c__leb2; solverec.
Qed.

Definition c__ltb := c__leb2 + 4.
Definition ltb_time (a b : nat) := leb_time (S a) b + c__ltb.
Instance term_ltb : computableTime' Nat.ltb (fun a _ => (1, fun b _ => (ltb_time a b, tt))).
Proof.
  extract. recRel_prettify2.
  - lia.
  - unfold ltb_time, c__ltb. solverec.
Qed.

Instance eqbNat_inst : eqbClass Nat.eqb.
Proof.
  exact Nat.eqb_spec.
Qed.

Instance eqbComp_nat : eqbCompT nat.
Proof.
  evar (c:nat). exists c. unfold Nat.eqb.
  unfold enc;cbn.
  extract.
  solverec.
  [c]:exact 5.
  all:unfold c;try lia.
Qed.
(*Qed.*)

Definition c__min1 := 5.
Definition c__min2 := 15.
Definition min_time x y := (min x y + 1) * c__min2.
Instance termT_nat_min : computableTime' Nat.min (fun x _ => (c__min1, fun y _ => (min_time x y, tt))).
Proof.
  extract. solverec.
  all: unfold min_time, c__min1, c__min2; solverec.
Qed.

Definition c__max1 := 5.
Definition c__max2 := 15.
Definition max_time x y := (min x y + 1) * c__max2.
Instance termT_nat_max : computableTime' Nat.max (fun x _ => (c__max1, fun y _ => (max_time x y, tt))).
Proof.
  extract. solverec.
  all: unfold max_time, c__max1, c__max2; solverec.
Qed.

Definition c__pow1 := 5.
Definition c__pow2 := 10 + c__mult1.
Fixpoint pow_time x n := match n with
  | 0 => c__pow2
  | S n => pow_time x n + mult_time x (x ^n) + c__pow2
end.
Instance termT_pow:
  computableTime' Init.Nat.pow   (fun (x : nat) _ => (c__pow1,fun (n : nat) _ => (pow_time x n, tt))).
Proof.
  extract. fold Nat.pow. solverec.
  all: unfold pow_time, c__pow1, c__pow2; solverec.
Qed.

Definition c__divmod := 20.
Definition divmod_time (x: nat) := c__divmod * (1+x).
Instance termT_divmod :
  computableTime' divmod (fun (x : nat) _ => (5, fun (y : nat) _ => (5, fun (q : nat) _ => (1, fun (u : nat) _ => (divmod_time x, tt))))).
Proof.
  extract. solverec. all: unfold divmod_time, c__divmod; solverec.
Qed.

Definition c__modulo := 21 + c__sub1.
Definition modulo_time (x :nat) (y : nat) := divmod_time x + c__sub * y + c__modulo.
Instance termT_modulo :
  computableTime' Init.Nat.modulo (fun x _ => (1, fun y _ => (modulo_time x y, tt))).
Proof.
  extract. solverec.
  - unfold modulo_time, c__modulo; solverec.
  - unfold sub_time. rewrite Nat.le_min_l. unfold modulo_time, c__modulo. solverec.
Qed.

(* now some more encoding-related properties:*)

Fixpoint nat_unenc (s : term) :=
  match s with
  | lam (lam #1) => Some 0
  | lam (lam (app #0 s)) => match nat_unenc s with Some n => Some (S n) | x=>x end
  | _ => None
  end.

Lemma unenc_correct m : (nat_unenc (nat_enc m)) = Some m.
Proof.
  induction m; simpl; now try rewrite IHm.
Qed.

Lemma unenc_correct2 t n : nat_unenc t = Some n -> nat_enc n = t.
Proof with try solve [Coq.Init.Tactics.easy].
  revert n. eapply (size_induction (f := size) (p := (fun t => forall n, nat_unenc t = Some n -> nat_enc n = t))). clear t. intros t IHt n H.
  destruct t as [ | | t]. easy. easy.
  destruct t as [ | | t]. easy. easy.
  destruct t. 3:easy.
  -destruct n0. easy. destruct n0. 2:easy. inv H. easy.
  -destruct t1. 2-3:easy. destruct n0. 2:easy. simpl in H. destruct (nat_unenc t2) eqn:A.
   +apply IHt in A;simpl;try lia. destruct n. inv H. simpl. congruence.
   +congruence.
Qed.

Lemma dec_enc t : dec (exists n, t = nat_enc n).
Proof.
  destruct (nat_unenc t) eqn:H.
  - left. exists n. now eapply unenc_correct2 in H.
  - right. intros [n A]. rewrite A in H. rewrite unenc_correct in H. inv H.
Qed.

Definition c__natsizeO := 4.
Definition c__natsizeS := 4.
Lemma size_nat_enc (n:nat) :
  size (enc n) = n * c__natsizeS + c__natsizeO.
Proof.
  unfold c__natsizeS, c__natsizeO.
  induction n;cbv [enc encodable_nat_enc] in *. all:cbn [size nat_enc] in *. all:solverec.
Qed.

Lemma size_nat_enc_r (n:nat) :
  n <= size (enc n).
Proof.
    induction n;cbv [enc encodable_nat_enc] in *. all:cbn [size nat_enc] in *. all:solverec.
Qed.

(* This is an example for an function in which the run-time of the fix itself is not constant (in add, the fix on the first argument always returns an function in ~5 steps)*)
(* Instance termT_testId : computableTime' (fix f x := *)
(*                                             match x with *)
(*                                               0 => 0 *)
(*                                             | S x => S (f x) *)
(*                                             end). *)
(* Proof. *)
(*   extract. *)
(*   eexists (fun x xT => (x*9+7,tt)). *)
(*   abstract (repeat (cbn;intros;intuition;try destruct _;try ring_simplify)). *)
(* Qed. *)


Require Export Hoare.

Definition as0: Assertion:= fun st => st X = 3.
Definition s1 := update empty_state X 3.
Definition s2 := update empty_state X 5.

Example chk_as0_s1 :  (as0 s1).
Proof. reflexivity. Qed.

Example chk_as0_s2 :  ~(as0 s2).
Proof. unfold not. unfold as0.
intros. inversion H. Qed.


(** * POPLmark Part 1

    The #POPLmark#
    challenge is a set of benchmark problems to evaluate approaches to the
    formalization of syntactic theories.  We solve part 1, that is,
    progress and preservation of System F with subtyping.  *)

Require Import Program.Equality List Lia.
Require Import Autosubst.Autosubst.
Require Import Size Decidable Context.

Inductive type : Type :=
| TyVar (x : var)
| Top
| Arr (A1 A2 : type)
| All (A1 : type) (A2 : {bind type}).

Instance Ids_type : Ids type. derive. Defined.
Instance Rename_type : Rename type. derive. Defined.
Instance Subst_type : Subst type. derive. Defined.

Instance SubstLemmas_type : SubstLemmas type. derive. Qed.

Instance size_type : Size type.
  assert(Size var). exact(fun _ => 0). derive.
Defined.

Inductive term :=
| TeVar (x : var)
| Abs (A : type) (s : {bind term})
| App (s t : term)
| TAbs (A : type) (s : {bind type in term})
| TApp (s : term) (A : type).

Instance hsubst_term : HSubst type term. derive. Defined.

Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.

Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed.

Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed.

Instance SubstLemmas_term : SubstLemmas term. derive. Qed.

Instance size_term : Size term.
  assert(Size var). exact(fun _ => 0). derive.
Defined.

Lemma ren_size_inv (A : type) : forall xi, size A.[ren xi] = size A.
Proof.
  induction A; intros; sizesimpl; repeat(asimpl; try autorew); slia.
Qed.

Fixpoint wf_ty Delta A := match A with
  | TyVar x => exists B, atnd Delta x B
  | Top => True
  | Arr A B => wf_ty Delta A /\ wf_ty Delta B
  | All A B => wf_ty Delta A /\ wf_ty (A :: Delta) B
end.

Reserved Notation "'SUB' Delta |- A <: B"
  (at level 68, A at level 99, no associativity).
Inductive sub (Delta : list type) : type -> type -> Prop :=
| SA_Top A :
    wf_ty Delta A -> SUB Delta |- A <: Top
| SA_Refl x :
    wf_ty Delta (TyVar x) -> SUB Delta |- TyVar x <: TyVar x
| SA_Trans x A B :
    atnd Delta x A -> SUB Delta |- A <: B -> SUB Delta |- TyVar x <: B
| SA_Arrow A1 A2 B1 B2 :
    SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 ->
    SUB Delta |- Arr A1 A2 <: Arr B1 B2
| SA_All A1 A2 B1 B2 :
    SUB Delta |- B1 <: A1 -> wf_ty Delta B1 -> SUB (B1 :: Delta) |- A2 <: B2 ->
    SUB Delta |- All A1 A2 <: All B1 B2
where "'SUB' Delta |- A <: B" := (sub Delta A B).

Lemma wf_weak Delta1 Delta2 A xi :
  wf_ty Delta1 A ->
  (forall x B, atnd Delta1  x B -> exists B', atnd Delta2 (xi x) B') ->
  wf_ty Delta2 A.[ren xi].
Proof.
  autorevert A. induction A; intros; ainv; simpl; eauto.
  asimpl. split; eauto.
  eapply IHA0. eassumption.
  intros. ainv (asimpl; eauto using @atnd).
  edestruct H0; eauto. eauto using @atnd.
Qed.

Lemma wf_weak1 Delta A A' B :
  wf_ty Delta A -> A' = A.[ren(+1)] -> wf_ty (B :: Delta) A'.
Proof. intros. subst. eapply wf_weak; eauto using @atnd. Qed.

Corollary wf_weak' Delta1 Delta2 A :
  wf_ty Delta1 A ->
  (length Delta1 <= length Delta2) ->
  wf_ty Delta2 A.
Proof.
  intros. replace A with A.[ren id] by now autosubst.
  eapply wf_weak; eauto.
  intros. apply atnd_defined.
  cut(id x < length Delta1). lia.
  apply atnd_defined. eauto.
Qed.

Lemma sub_refl Delta A : wf_ty Delta A -> SUB Delta |- A <: A.
Proof.
  revert Delta. induction A; simpl; intuition;
  constructor; simpl; eauto using sub.
Qed.

Lemma sub_weak Delta1 Delta2 A1 A2 A1' A2' xi : SUB Delta1 |- A1 <: A2 ->
  (forall x B, atnd Delta1 x B -> atnd Delta2 (xi x) B.[ren xi]) ->
  A1' = A1.[ren xi] -> A2' = A2.[ren xi] ->
  SUB Delta2 |- A1' <: A2' .
Proof.
   intros H. intros. subst. autorevert H.
   induction H; intros; simpl; try now (econstructor; simpl; ainv eauto).
   - eauto using sub, wf_weak.
   - econstructor; asimpl; eauto using wf_weak.
     apply IHsub2.
     intros [|]; intros; asimpl; ainv; econstructor; eauto; now autosubst.
Qed.

Lemma sub_weak1 Delta A A' B B' C :
  SUB Delta |- A <: B ->  A' = A.[ren(+1)] ->  B' = B.[ren(+1)] ->
  SUB (C :: Delta) |- A' <: B'.
Proof.  intros. eapply sub_weak; eauto using @atnd. Qed.

Lemma sub_wf {Delta A B} :
  SUB Delta |- A <: B -> wf_ty Delta A /\ wf_ty Delta B.
Proof.
  intros H. induction H; ainv; simpl; eauto using wf_weak'.
Qed.

Lemma sub_wf_1 Delta A B : SUB Delta |- A <: B -> wf_ty Delta A.
Proof. apply sub_wf. Qed.

Lemma sub_wf_2 Delta A B : SUB Delta |- A <: B -> wf_ty Delta B.
Proof. apply sub_wf. Qed.

Lemma conj' (A B : Prop) : A -> (A -> B) -> A /\ B.
Proof. tauto. Qed.

Lemma sub_trans' n :
  (forall Delta A B C, n = size B ->
     SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C) /\
  (forall Delta' Delta B B' A C, n = size B ->
     SUB Delta' ++ B :: Delta |- A <: C ->
     SUB Delta |- B' <: B ->
     SUB Delta' ++ B' :: Delta |- A <: C).
Proof.
  induction n as [n IH] using (size_rec (fun x => x)).
  apply conj'.
  {
    intros Delta A B C ? H_AB H_BC. subst.
    revert C H_BC.
    induction H_AB; intros; ainv; eauto using sub.
    - inv H_BC.
      + constructor. simpl. split; eauto using sub_wf_1, sub_wf_2.
      + constructor; eapply IH; eauto; slia.
    - inv H_BC.
      + constructor; constructor.
        * eapply sub_wf; now eauto.
        * eapply wf_weak'. now eapply (sub_wf H_AB2). now simpl.
      + rename B0 into C1. rename B3 into C2.
        constructor; eauto.
        * eapply IH; eauto; slia.
        * eapply IH; eauto; try slia.
          (refine (proj2 (IH _ _) nil _ B1 _ _ _ _ _ _)); eauto; simpl; lia.
  }
  {
    intros H_trans Delta' Delta B B' A C ? H H_B'B. subst.
    revert B' H_B'B.
    depind H; intros; simpl in *.
    - constructor.
      eapply wf_weak'. eassumption.
      repeat rewrite app_length. simpl. lia.
    - constructor. simpl.
      apply atnd_defined. apply atnd_defined in H.
      repeat rewrite -> app_length in *. simpl in *. lia.
    - decide (x = length Delta').
      + subst.
        econstructor. { apply atnd_repl. }
        apply atnd_steps' with (x := 0) in H.
        destruct H as [? [? H]]. inv H.
        eapply H_trans;[idtac | eapply sub_weak;
          try reflexivity; try eassumption | idtac].
        * now rewrite ren_size_inv.
        * intros. change (B' :: Delta) with ((B' :: nil) ++ Delta).
          rewrite app_assoc.
          cutrewrite (S (length Delta') = length (Delta' ++ B' :: nil)).
          now apply atnd_steps.
          rewrite app_length. simpl. lia.
        * asimpl in IHsub.
          eapply IHsub; now eauto.
      + econstructor; eauto.
        eapply atnd_repl; now eauto.
    - constructor; now eauto.
    - constructor.
      + now eauto.
      + eapply wf_weak'. eassumption.
        repeat rewrite app_length. simpl. lia.
      + change (B1 :: Delta' ++ B' :: Delta)
          with ((B1 :: Delta') ++ B' :: Delta).
        eapply IHsub2; eauto.
  }
Qed.

Corollary sub_trans Delta A B C:
  SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C.
Proof. intros. eapply sub_trans'; eauto. Qed.

Corollary sub_narrow Delta' Delta B B' A C :
     SUB Delta' ++ B :: Delta |- A <: C ->
     SUB Delta |- B' <: B ->
     SUB Delta' ++ B' :: Delta |- A <: C.
Proof. intros. eapply sub_trans'; eauto. Qed.

Inductive value : term -> Prop :=
| Value_Abs A s : value(Abs A s)
| Value_TAbs A s : value(TAbs A s).

Reserved Notation "'TY' Delta ; Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Delta ; Gamma  |-  A  :  B").
Inductive ty (Delta Gamma : list type) : term -> type -> Prop :=
| T_Var A x :
    atn Gamma x A ->
    TY Delta;Gamma |- TeVar x : A
| T_Abs A B s:
    TY Delta;A::Gamma |- s : B   ->   wf_ty Delta A   ->
    TY Delta;Gamma |- Abs A s : Arr A B
| T_App A B s t:
    TY Delta;Gamma |- s : Arr A B   ->   TY Delta;Gamma |- t : A   ->
    TY Delta;Gamma |- App s t : B
| T_TAbs A B s :
    TY A::Delta ; Gamma..[ren(+1)] |- s : B   ->   wf_ty Delta A   ->
    TY Delta;Gamma |- TAbs A s : All A B
| T_TApp A B A' s B' :
    TY Delta;Gamma |- s : All A B ->
    SUB Delta |- A' <: A -> B' = B.[A'/] ->
    TY Delta;Gamma |- TApp s A' : B'
| T_Sub A B s :
    TY Delta;Gamma |- s : A   ->   SUB Delta |- A <: B   ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (ty Delta Gamma s A).

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'   s  =>  t").
Inductive eval : term -> term -> Prop :=
| E_AppAbs A s t : EV App (Abs A s) t => s.[t/]
| E_TAppTAbs A s B : EV TApp (TAbs A s) B => s.|[B/]
| E_AppFun s s' t :
     EV s => s' ->
     EV App s t => App s' t
| E_AppArg s s' v:
     EV s => s' -> value v ->
     EV App v s => App v s'
| E_TypeFun s s' A :
     EV s => s' ->
     EV TApp s A => TApp s' A
where "'EV' s => t" := (eval s t).

Lemma ty_weak  xi zeta Delta1 Delta2 Gamma1 Gamma2 s A :
  TY Delta1;Gamma1 |- s : A ->
  (forall x B, atnd Delta1 x B -> atnd Delta2 (xi x) B.[ren xi]) ->
  (forall x B, atn Gamma1 x B -> atn Gamma2 (zeta x) B.[ren xi]) ->
  TY Delta2;Gamma2 |- s.|[ren xi].[ren zeta] : A.[ren xi] .
Proof.
   intros H. autorevert H. induction H; intros; simpl.
   - econstructor; now eauto.
   - asimpl. econstructor.
     + apply IHty; eauto. intros x C H_C.
       destruct x; simpl in *; subst; eauto.
     + eauto using wf_weak.
   - asimpl; econstructor; simpl; eauto; apply IHty1; eauto.
   - asimpl. econstructor. apply IHty.
     + intros. now eapply up_atnd; eauto.
     + intros. eapply up_mmap_atn; eauto.
     + eauto using wf_weak.
   - econstructor.
     + simpl in IHty. apply IHty; eauto.
     + eauto using sub_weak.
     + subst. autosubst.
   - eauto using ty, sub_weak.
Qed.

Lemma ty_weak_ty  xi Delta1 Delta2 Gamma1 Gamma2 s s' A A':
  TY Delta1;Gamma1 |- s : A ->
  (forall x B, atnd Delta1 x B -> atnd Delta2 (xi x) B.[ren xi]) ->
  (forall x B, atn Gamma1 x B -> atn Gamma2 x B.[ren xi]) ->
  A' = A.[ren xi] ->
  s' = s.|[ren xi] ->
  TY Delta2;Gamma2 |- s' : A'.
Proof.
  intros. subst. cutrewrite(s.|[ren xi] = s.|[ren xi].[ren id]).
  eapply ty_weak; eauto. now autosubst.
Qed.

Lemma ty_weak_ty' Delta Gamma s s' A A' B:
  TY Delta;Gamma |- s : A ->
  A' = A.[ren (+1)] ->
  s' = s.|[ren (+1)] ->
  TY B::Delta ; Gamma..[ren(+1)] |- s' : A'.
Proof.
  intros. eapply ty_weak_ty; eauto; intros.
  - econstructor; eauto.
  - eapply atn_mmap; eauto.
Qed.

Lemma ty_weak_ter xi Delta Gamma1 Gamma2 s A :
  TY Delta;Gamma1 |- s : A ->
  (forall x B, atn Gamma1 x B -> atn Gamma2 (xi x) B) ->
  TY Delta;Gamma2 |- s.[ren xi] : A.
Proof.
  intros.
  cutrewrite (s = s.|[ren id]).
  cutrewrite (A = A.[ren id]).
  eapply ty_weak; eauto; intros; asimpl; now eauto.
  autosubst. autosubst.
Qed.

Lemma ty_weak_ter1 Delta Gamma s s' A B :
  TY Delta;Gamma |- s : A ->
  s' = s.[ren(+1)] ->
  TY Delta ; B::Gamma |- s' : A.
Proof.
  intros. subst. eapply ty_weak_ter; eauto.
Qed.

Lemma ty_narrow Delta2 Delta1 Gamma A B C s:
  TY Delta2 ++ B :: Delta1 ; Gamma |- s : C  ->
  SUB Delta1 |- A <: B  ->
  TY Delta2 ++ A :: Delta1 ; Gamma |- s : C.
Proof.
  intros H. depind H; econstructor; eauto using ty.
  - eapply wf_weak'. eassumption. repeat rewrite app_length. simpl. lia.
  - change (A0 :: Delta2 ++ A :: Delta1) with ((A0 :: Delta2) ++ A :: Delta1).
    eapply IHty. reflexivity. assumption.
  - eapply wf_weak'. eassumption. repeat rewrite app_length. simpl. lia.
  - now eapply sub_narrow; eauto.
  - now eapply sub_narrow; eauto.
Qed.

Lemma wf_subst Delta1 Delta2 A sigma :
  wf_ty Delta1 A ->
  (forall x B, atnd Delta1 x B -> wf_ty Delta2 (sigma x)) ->
  wf_ty Delta2 A.[sigma].
Proof.
  intros H. autorevert A. induction A; eauto; intros; asimpl.
  - ainv; eauto.
  - ainv; eauto.
  - split. ainv; eauto. ainv. eapply IHA0. eassumption.
    intros [|]; intros.
    + simpl. eauto using @atnd.
    + ainv. asimpl. eapply wf_weak; eauto using @atnd.
Qed.

Lemma sub_subst Delta1 Delta2 A B sigma:
  SUB Delta1 |- A <: B ->
  (forall x C, atnd Delta1 x C -> SUB Delta2 |- sigma x <: C.[sigma]) ->
  SUB Delta2 |- A.[sigma] <: B.[sigma].
Proof.
  intros H. autorevert H.
  induction H; intros; simpl; try econstructor; asimpl;
  eauto using sub, wf_subst, sub_wf_1.
  - inv H. eauto using sub_refl, wf_subst, sub_wf_1.
  - eauto using sub_trans.
  - apply IHsub2. intros. inv H3.
    + econstructor. eauto using @atnd.
      asimpl. apply sub_refl.
      eapply wf_weak1; eauto using sub_wf_1. autosubst.
    + asimpl. eapply sub_weak1; try reflexivity; eauto. autosubst.
Qed.

Lemma ty_subst Delta1 Delta2 Gamma1 Gamma2 s A sigma tau:
  TY Delta1;Gamma1 |- s : A ->
  (forall x B, atnd Delta1 x B -> SUB Delta2 |- sigma x <: B.[sigma] ) ->
  (forall x B, atn Gamma1 x B -> TY Delta2;Gamma2 |- tau x : B.[sigma]) ->
  TY Delta2;Gamma2 |- s.|[sigma].[tau] : A.[sigma].
Proof.
  intros H.
  autorevert H. induction H; intros; asimpl.
  - now eauto.
  - econstructor.
    + apply IHty; eauto.
      intros ? ? H_get. destruct x; asimpl in *; subst;
      eauto using ty_weak_ter1. now constructor.
    + eauto using wf_subst, sub_wf_1.
  - econstructor; eauto.
  - econstructor. apply IHty.
    + intros ? ? H_get. inv H_get; asimpl.
      * econstructor. constructor; eauto.
        asimpl. apply sub_refl.
        eapply wf_weak1; eauto using wf_subst, sub_wf_1.
        autosubst.
      * eapply sub_weak; eauto using @atnd. now autosubst.
    + intros.
      apply mmap_atn in H3. ainv.
      eapply ty_weak_ty'; eauto. now autosubst.
    + eauto using wf_subst, sub_wf_1.
  - subst. simpl in *. econstructor; eauto using sub_subst. now autosubst.
  - eauto using ty, sub_subst.
Qed.

Corollary ty_subst_term Delta Gamma1 Gamma2 s A sigma:
  TY Delta;Gamma1 |- s : A ->
  (forall x B, atnd Delta x B -> wf_ty Delta B) ->
  (forall x B, atn Gamma1 x B -> TY Delta;Gamma2 |- sigma x : B) ->
  TY Delta;Gamma2 |- s.[sigma] : A.
Proof.
  intros.
  cutrewrite(s = s.|[ids]);[idtac|autosubst].
  cutrewrite (A = A.[ids]);[idtac|autosubst].
  eapply ty_subst; eauto; intros.
  - asimpl; eauto using sub, sub_refl.
  - asimpl; eauto using sub, sub_refl.
Qed.

Lemma can_form_arr {s A B}:
  TY nil;nil |- s : Arr A B -> value s -> exists C t, s = Abs C t.
Proof.
  intros H.
  depind H; intros; eauto; ainv.
  inv H0. ainv. eauto. (* JK: With the 8.6 Goal matching default hypothesis order (newest first) this would break with the old ainv version! *)
Qed.

Lemma can_form_all {s A B}:
  TY nil;nil |- s : All A B -> value s -> exists C t, s = TAbs C t.
Proof.
  intros H.
  depind H; intros; eauto; ainv.
  inv H0. ainv. eauto.
Qed.

Theorem ev_progress s A:
  TY nil;nil |- s : A -> value s \/ exists t,  EV s => t.
Proof.
  intros. depind H. (* depind appears to not remove generated trivial equality guards any longer *)
  - inv H.
  - left; constructor.
  - right. destruct IHty1 as [? | [? ?]]; trivial.
    + edestruct (can_form_arr H H1) as [? [? ?]]; subst. eauto using eval.
    + eauto using eval.
  - left; constructor.
  - right. destruct IHty as [? | [? ?]]; trivial.
    + edestruct (can_form_all H H1) as [? [? ?]]; subst. eauto using eval.
    + eauto using eval.
  - auto.
Qed.

Lemma ty_inv_abs {Delta Gamma A A' B C s}:
  TY Delta;Gamma |- Abs A s : C   ->   SUB Delta |- C <: Arr A' B   ->
  (SUB Delta |- A' <: A /\
    exists B', TY Delta;A::Gamma |- s : B' /\ SUB Delta |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H1. split; eauto.
  - eauto using sub_trans.
Qed.

Lemma ty_inv_tabs {Delta Gamma A A' B C s}:
  TY Delta;Gamma |- TAbs A s : C   ->   SUB Delta |- C <: All A' B   ->
  (SUB Delta |- A' <: A /\ exists B',
   TY A'::Delta;Gamma..[ren(+1)] |- s : B' /\ SUB A'::Delta |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H1. split; eauto.
    eexists. split; eauto. eapply (ty_narrow nil); eauto.
  - eauto using sub_trans.
Qed.

Theorem preservation Delta Gamma s t A :
  TY Delta;Gamma |- s : A -> EV s => t ->
  (forall x B, atnd Delta x B -> wf_ty Delta B) ->
  TY Delta;Gamma |- t : A.
Proof.
  intros H_ty H_ev.
  autorevert H_ev. induction H_ev; intros; depind H_ty; eauto using ty.
  - inv H_ty1.
    + eapply ty_subst_term; eauto. intros [|] ? ?; simpl in *;
      subst; eauto using ty.
    + pose proof (ty_inv_abs H0 H1) as [? [B' [? ?]]].
      eapply ty_subst_term; eauto using ty.
      intros [|] ? ?; simpl in *; subst; eauto using ty.
  - cutrewrite (s.|[B/] = s.|[B/].[ids]);[idtac|autosubst].
    inv H_ty; [idtac | pose proof (ty_inv_tabs H1 H2) as [? [B' [? ?]]]];
    (eapply ty_subst; eauto using ty; [
        now intros ? ? H_atnd; inv H_atnd; asimpl; eauto using sub, sub_refl
      | now intros [|] ? H_atn; simpl in *; subst; apply mmap_atn in H_atn;
        destruct H_atn as [? [? ?]]; subst; asimpl; eauto using ty ]).
Qed.

(* Local Variables: *)
(* coq-load-path: (("." "Plain") ("../../theories" "Autosubst")) *)
(* End: *)


From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun zmodp ssrbool ssrnat ssralg seq fintype finfun finalg tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import Program.

Section Sigma_1_1_Internal.

Inductive PolyTerm : Type :=
| PolyVar : nat -> PolyTerm
| PolyFun : nat -> seq PolyTerm -> PolyTerm
| PolyMinusOne : PolyTerm
| PolyPlusOne : PolyTerm
| PolyZero : PolyTerm
| PolyPlus : PolyTerm -> PolyTerm -> PolyTerm
| PolyTimes : PolyTerm -> PolyTerm -> PolyTerm
| PolyInd : PolyTerm -> PolyTerm -> PolyTerm.

Inductive ZerothOrderFormula : Type :=
| ZONot : ZerothOrderFormula -> ZerothOrderFormula
| ZOAnd : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOOr : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOImp : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOEq : PolyTerm -> PolyTerm -> ZerothOrderFormula.

Inductive QuantifiedFormula : Type :=
| ZO : ZerothOrderFormula
    -> QuantifiedFormula
| QExists : forall (bs : seq (PolyTerm))
                   (y : PolyTerm),
            QuantifiedFormula
         -> QuantifiedFormula
| QForall : PolyTerm
         -> QuantifiedFormula
         -> QuantifiedFormula.

End Sigma_1_1_Internal.

Section Sigma_1_1_Denotation.

Record Sigma11Model : Type :=
  mkSigma11Model {
      p : nat;
      V_F : nat -> 'F_p;
      F_S : nat -> { a & {ffun a.-tuple 'F_p -> option 'F_p }};
  }.

Definition indFun {p} (x y : 'F_p) : 'F_p := if (x < y) then 1%R else 0%R.

Theorem FinFieEq {p} {a b : 'F_p} (e : a == b = true) : a = b.
Proof.
  destruct a, b.
  apply EEConvert in e; simpl in e.
  destruct e.
  by replace i with i0;[|apply eq_irrelevance].
Qed.

Fixpoint option_seq {A} (s : seq (option A)) : option (seq A) :=
  match s with
  | [::] => Some [::]
  | (x :: xs) =>
    obind (fun x => obind (fun xs => Some (x :: xs)) (option_seq xs)) x
  end.

Fixpoint option_tuple {n A} : n.-tuple (option A) -> option (n.-tuple A) :=
  match n with
  | 0 => fun _ => Some (nil_tuple A)
  | n.+1 => fun t =>
    obind (fun x => obind (fun xs => Some (cons_tuple x xs)) (option_tuple (behead_tuple t))) (thead t)
  end.

Program Fixpoint PolyDepth (r : PolyTerm) : nat :=
  match r with
  | PolyVar m => 0
  | PolyFun i t => (List.list_max (map PolyDepth t)).+1
  | PolyMinusOne => 0
  | PolyPlusOne => 0
  | PolyZero => 0
  | PolyPlus r1 r2 => (max (PolyDepth r1) (PolyDepth r2)).+1
  | PolyTimes r1 r2 => (max (PolyDepth r1) (PolyDepth r2)).+1
  | PolyInd r1 r2 =>(max (PolyDepth r1) (PolyDepth r2)).+1
  end.

Program Fixpoint Poly_Denote_WF (M : Sigma11Model)
  (n : nat) (r : PolyTerm) : option ('F_(p M)) :=
  match n with
  | 0 => None
  | n.+1 =>
    match r with
    | PolyVar m => Some (V_F M m)
    | PolyFun i t =>
      let ds := option_tuple (map_tuple (Poly_Denote_WF M n) (in_tuple t)) in
      (if size t == projT1 (F_S M i) as b return (size t == projT1 (F_S M i) = b -> option ('F_(p M)))
      then fun e => (
            obind (fun u : (size t).-tuple 'F_(p M) => projT2 (F_S M i) u) ds)
      else fun _ => None) (erefl _)
    | PolyMinusOne => Some (-1)%R
    | PolyPlusOne => Some 1%R
    | PolyZero => Some 0%R
    | PolyPlus r1 r2 =>
      let d1 := Poly_Denote_WF M n r1 in
      let d2 := Poly_Denote_WF M n r2 in
      obind (fun r1 => obind (fun r2 => Some (r1 + r2)%R) d2) d1
    | PolyTimes r1 r2 =>
      let d1 := Poly_Denote_WF M n r1 in
      let d2 := Poly_Denote_WF M n r2 in
      obind (fun r1 => obind (fun r2 => Some (r1 * r2)%R) d2) d1
    | PolyInd r1 r2 =>
      let r1 := Poly_Denote_WF M n r1 in
      let r2 := Poly_Denote_WF M n r2 in
      obind (fun r1 => obind (fun r2 => Some (indFun r1 r2)) r2) r1
    end
  end.
Next Obligation. by apply EEConvert in e. Qed.

Definition Poly_Denote M r := Poly_Denote_WF M (PolyDepth r).+1 r.

Fixpoint ZerothOrder_Denote (M : Sigma11Model)
  (f : ZerothOrderFormula) : option bool :=
  match f with
  | ZONot f =>
    let d := ZerothOrder_Denote M f in
    obind (fun d => Some (negb d)) d
  | ZOAnd f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 && r2)) d2) d1
  | ZOOr f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 || r2)) d2) d1
  | ZOImp f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 ==> r2)) d2) d1
  | ZOEq r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 == r2)) d2) d1
  end.

Definition AddModelV (M : Sigma11Model) (r : 'F_(p M)) : Sigma11Model :=
  {| V_F := ExtendAt0 r (V_F M); F_S := F_S M |}.

Definition AddModelExiF  (M : Sigma11Model) (f : { newA & {ffun (newA.-tuple 'F_(p M)) -> option ('F_(p M))}})  :
  Sigma11Model := {| V_F := V_F M; F_S := ExtendAt0 f (F_S M) |}.

(* Program Fixpoint FunBounds
  (M : Sigma11Model) {a}
  (ins : a .-tuple 'F_(p M)) (out : 'F_(p M))
  (insB : a .-tuple PolyTerm) (outB : PolyTerm) : option bool :=
  match a with
  | 0 =>
    let oB := Poly_Denote M outB in
    obind (fun oB : 'F_(p M) => Some (out < oB)) oB
  | n.+1 =>
    let iB := Poly_Denote M (thead insB) in
    let rB := @FunBounds (AddModelV M (thead ins)) n (behead_tuple ins) out (behead_tuple insB) outB in
    obind (fun rB => obind (fun iB : 'F_(p M) => Some ((thead ins < iB) && rB)) iB) rB
  end. *)

Program Fixpoint FunBounds
  (M : Sigma11Model) {a}
  (ins : a .-tuple 'F_(p M)) (out : option 'F_(p M))
  (insB : a .-tuple PolyTerm) (outB : PolyTerm) : bool :=
  match a with
  | 0 =>
    match out with
    | None => true
    | Some out =>
      match Poly_Denote M outB with
      | None => false
      | Some oB => out < oB
      end
    end
  | n.+1 =>
    match Poly_Denote M (thead insB) with
    | None => false
    | Some iB => (thead ins < iB) &&
      @FunBounds (AddModelV M (thead ins)) n (behead_tuple ins) out (behead_tuple insB) outB
    end
  end.

Definition Fun_Bound_Check
  (M : Sigma11Model)
  {n : nat}
  (bs : n .-tuple PolyTerm)
  (y : PolyTerm)
  (f : {ffun (n.-tuple 'F_(p M)) -> option ('F_(p M))}) : bool :=
all [pred x | FunBounds M (projT1 x) (projT2 x) bs y] (tfgraph f).

(*
Note: there's no way to get this to coherently return an undefined value.
Consider the statement "exists F, P F" where "P F" may be undefined.
Because the outside is "exists" the overall expression must return a bool,
but because the "F" is bound by "exists", we can't take "P" outside of
"F"'s scope to see if "P F" would give an undefined value. So the potential
undefined value must be interpreted as a bool if it comes up in order to
evaluate the expression at all.

To handle this, I check that "P F == Some true" which will be false when
"P F" is undefined.
*)

Fixpoint QuantifiedFormula_Denote (M : Sigma11Model) (f : QuantifiedFormula) : option bool :=
  match f with
  | ZO z => ZerothOrder_Denote M z
  | QExists bs y f => Some
    [exists F, Fun_Bound_Check M (in_tuple bs) y F
            && (QuantifiedFormula_Denote (AddModelExiF M (existT _ (size bs) F)) f == Some true)]
  | QForall B f => obind (fun B : 'F_(p M) => Some
    [forall r, ((r : 'F_(p M)) < B) ==> (QuantifiedFormula_Denote (AddModelV M r) f == Some true)]
  ) (Poly_Denote M B)
  end.

Fixpoint QuantifiedFormula_Denote_B (M : Sigma11Model) (f : QuantifiedFormula) : bool :=
  match f with
  | ZO z => ZerothOrder_Denote M z == Some true
  | QExists bs y f =>
    [exists F, Fun_Bound_Check M (in_tuple bs) y F
            && (QuantifiedFormula_Denote_B (AddModelExiF M (existT _ (size bs) F)) f == true)]
  | QForall B f =>
    match Poly_Denote M B with
    | None => false
    | Some B =>
      [forall r, ((r : 'F_(p M)) < B) ==> (QuantifiedFormula_Denote_B (AddModelV M r) f == true)]
    end
  end.

End Sigma_1_1_Denotation.


(* Full safety for STLC *)

(* copied from nano0.v *)

(* This version prohibits recursion, and we prove that   *)
(* evaluation always terminates with a well-typed value. *)
(* From this follows both type soundness and strong      *)
(* normalization for STLC.                               *)

(* copied from nano0-total.v *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : list vl -> tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint length {X: Type} (l : list X): nat :=
  match l with
    | [] => 0
    | _::l' => 1 + length l'
  end.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if eq_nat_dec n (length l') then Some a else index n l'
  end.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
           has_type env ttrue TBool
| t_false: forall env,
           has_type env tfalse TBool
| t_var: forall x env T1,
           index x env = Some T1 ->
           has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
           has_type env f (TFun T1 T2) ->
           has_type env x T1 ->
           has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
           has_type (T1::env) y T2 ->
           has_type env (tabs y) (TFun T1 T2)
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ef with
            | None => None
            | Some None => Some None
            | Some (Some (vbool _)) => Some None
            | Some (Some (vabs env2 ey)) =>
              match teval n env ex with
                | None => None
                | Some None => Some None
                | Some (Some vx) =>
                  teval n (vx::env2) ey
              end
          end
      end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

(* need to use Fixpoint because of positivity restriction *)
Fixpoint val_type v T : Prop := match v, T with
| vbool b, TBool => True
| vabs env y, TFun T1 T2 =>
  (forall H tx vx, tevaln H tx vx /\ val_type vx T1 -> (* R H tx vx T1 *)
     exists vy, tevaln (vx::env) y vy /\ val_type vy T2) (* R (vx:env) y vy T2 *)
| _,_ => False
end.

Definition R H t v T := tevaln H t v /\ val_type v T.

Definition R_env venv tenv :=
  length venv = length tenv /\
 forall x T1, index x tenv = Some T1 ->
   exists v : vl, R venv (tvar x) v T1.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
(* Hint Constructors val_type. *)

Hint Constructors option.
Hint Constructors list.

(* if well-typed, then result is an actual value (not stuck and not a timeout),
   for large enough n *)

Theorem full_total_safety : forall e tenv T,
  has_type tenv e T -> forall venv, R_env venv tenv ->
  exists v, R venv e v T.

Proof.
  intros ? ? ? W.
  induction W; intros ? WFE.

  - Case "True". eexists. split.
    exists 0. intros. destruct n. omega. simpl. eauto. simpl. eauto.
  - Case "False". eexists. split.
    exists 0. intros. destruct n. omega. simpl. eauto. simpl. eauto.

  - Case "Var".
    eapply WFE. eauto.

  - Case "App".
    destruct (IHW1 venv0 WFE) as [vf [IW1 HVF]].
    destruct (IHW2 venv0 WFE) as [vx [IW2 HVX]].
    destruct vf. solve [inversion HVF].
    simpl in HVF.
    specialize (HVF venv0 x vx (conj IW2 HVX)).
    destruct HVF as [vy [IW3 HVY]].
    exists vy. split.
    destruct IW1 as [n1 IW1].
    destruct IW2 as [n2 IW2].
    destruct IW3 as [n3 IW3].
    exists (S (n1+n2+n3)).
    intros.
    destruct n. omega. simpl. rewrite IW1. rewrite IW2. rewrite IW3. eauto.
    omega. omega. omega.
    eauto.

  - Case "Abs".
    eexists. split. exists 0. intros. destruct n. omega. simpl. eauto. simpl.
    intros.

    assert (exists v : vl, R (vx::venv0) y v T2).
    eapply IHW. unfold R_env.
    split. simpl. destruct WFE. eauto.
    intros.
    simpl in H1.
    destruct (eq_nat_dec x (length env)).
    inversion H1. subst T0.
    exists vx. split.
    exists 0. intros. destruct n. omega. simpl.
    destruct WFE. subst. rewrite H3.
    destruct (eq_nat_dec (length env) (length env)). eauto. contradiction n0. eauto.
    eauto.
    destruct H0. eauto.
    destruct WFE.
    specialize (H3 _ _ H1). destruct H3. destruct H3. destruct H3.
    exists x0. split. exists x1. intros. destruct n0. omega. simpl.
    rewrite H2. destruct (eq_nat_dec x (length env)). contradiction. specialize (H3 (S n0) H5).
    simpl in H3. eapply H3.
    eauto.

    eapply H1.
Qed.

End STLC.


(****************************************************************

   Huffmanitive.v

 ****************************************************************)

(* Standard Libraries *)
Require Import List.
Require Import Relations.

(* By L.Thery *)
Require Import Huffman.BTree.
Require Import Huffman.WeightTree.
Require Import Huffman.Cover.
Require Import Huffman.Build.

(* append by me *)
Require Import SiblProp.Tacs.
Require Import SiblProp.BTree_appendix.
Require Import SiblProp.Wrapper.

Set Implicit Arguments.

Section SiblProp.
  Variables (A: Set)(f: A -> nat).
  Hypothesis eq_A_dec: forall a b: A, {a=b}+{a<>b}.
  Notation "[ X ]" := (leaf X).
  Infix "/-\" := node (at level 60, no associativity).

  Definition gsp t c w :=
    wrapper c w t/\ordered_siblist f w.

  Definition sibling_property (t: btree A) :=
    exists w,
      gsp t (leaves t) w.
End SiblProp.

Section HuffmanTree.
  Variables (A: Set)(f: A -> nat).
  Hypothesis eq_A_dec: forall a b: A, {a=b}+{a<>b}.
  Notation "[ X ]" := (leaf X).
  Infix "/-\" := node (at level 60, no associativity).

  (* Huffmanized Step Property *)
  Definition wone_step (ml1 pl1 ml2 pl2: list (btree A)) :=
    exists t1, exists t2, exists ml,
      ordered (sum_order f) (t1::t2::ml)/\
      permutation ml1 (t1::t2::ml)/\
      permutation ml2 (node t1 t2::ml)/\
      pl1 = (t1/-\t2::pl2).

  Ltac dest_hp :=
    let t1 := fresh "ht1" in
      let t2 := fresh "ht2" in
        let l := fresh "hml" in
      intros [ht1 [ht2 [html
        [Hord [Hperm1 [Hperm2 Heq_pl]]]]]].

  Ltac intro_dest_hp :=
    intros ml1 pl1 ml2 pl2; dest_hp.

  (* Some Properties of wone_step *)
  Section HuffProp.
    Variables ml1 pl1 ml2 pl2: list (btree A).
    Hypothesis hp: wone_step ml1 pl1 ml2 pl2.

    Ltac hp_dest := genc hp; dest_hp.

    Lemma wone_step_pl_all_well_sibl:
      all_well_sibl f pl2 -> all_well_sibl f pl1.
    Proof.
      hp_dest; subst; unfold all_well_sibl.
      simpl; intros IH x [Heq | HIn]; subst.
      inversion Hord; subst.
      unfold sum_order in H1.
      simpl; unfold sum_order; assumption.
      apply IH; assumption.
    Qed.

    Lemma wone_step_pl_all_node:
      all_node pl2 -> all_node pl1.
    Proof.
      hp_dest; subst.
      unfold all_node; simpl; intros H x [Heq | HIn];
        subst.
      simpl; tauto.
      apply H; assumption.
    Qed.

    Definition ml_pl_wrapper (ml pl: list (btree A)) :=
      forall tl tr,
        In (tl/-\tr) pl ->
        ((In tl ml/\In tr ml)\/In tl pl\/In tr pl).

    Lemma wone_step_ml_pl_wrapper:
      ml_pl_wrapper ml2 pl2 -> ml_pl_wrapper ml1 pl1.
    Proof.
      hp_dest; subst; unfold ml_pl_wrapper; simpl.
      intros Hgpw tl tr [Heq | HIn];
        [inject_subst; left; split;
          apply permutation_sym in Hperm1;
            apply (permutation_in _ _ _ _ Hperm1); simpl;
              [| right]; left; reflexivity |].
      destruct (Hgpw _ _ HIn)
        as [[HIn_l HIn_r] | [HIn_l | HIn_r]].
      apply (permutation_in _ _ _ _ Hperm2) in HIn_l.
      simpl in HIn_l; destruct HIn_l as [Heq_l | HIn_l]; subst.
      right; left; left; reflexivity.
      apply (permutation_in _ _ _ _ Hperm2) in HIn_r.
      simpl in HIn_r; destruct HIn_r as [Heq_r | HIn_r]; subst.
      right; right; left; reflexivity.
      left; split; apply permutation_sym in Hperm1;
        apply (permutation_in _ _ _ _ Hperm1); simpl;
          right; right; assumption.
      right; left; right; assumption.
      right; right; right; assumption.
    Qed.

  End HuffProp.

  (*******)
  Lemma wone_step_one_step:
    forall ml1 pl1 ml2 pl2,
      wone_step ml1 pl1 ml2 pl2 ->
      one_step f ml1 ml2.
  Proof.
    unfold wone_step, one_step.
    intro_dest_hp.
    exists html, ht1, ht2; repeat split; try assumption.
  Qed.
  (*******)

  Inductive wbuild: list (btree A) -> list (btree A) -> btree A -> Prop :=
  | wbuild_one:
    forall t, wbuild (t::nil) nil t
  | wbuild_step:
    forall ml1 pl1 ml2 pl2,
      wone_step ml1 pl1 ml2 pl2 ->
      forall t,
        wbuild ml2 pl2 t -> wbuild ml1 pl1 t.

  (* Some Properties of Wbuild *)
  Section Wbuild.
    Variables (t: btree A)(ml pl: list (btree A)).
    Hypothesis Hwb: wbuild ml pl t.

    Ltac ind_huff := elim Hwb; clear Hwb ml pl t.

    Lemma wbuild_wrapper:
      wrapper ml pl t.
    Proof.
      ind_huff.
      apply wrapper_one.
      intros.
      genc H; dest_hp; subst.
      eapply wrapper_node.
      unfold wrapper_prop.
      exists ht1, ht2, html; repeat split.
      assumption.
      apply permutation_refl.
      eapply wrapper_perm; try eassumption.
      apply permutation_refl.
    Qed.

    Lemma wbuild_pl_all_well_sibl:
      all_well_sibl f pl.
    Proof.
      ind_huff.
      unfold all_well_sibl.
      simpl; intros; contradiction.
      intros.
      apply (wone_step_pl_all_well_sibl H H1).
    Qed.

    Lemma wbuild_pl_all_node:
      all_node pl.
    Proof.
      unfold all_node.
      ind_huff.
      simpl; intros; contradiction.
      intros.
      apply (wone_step_pl_all_node H H1 _ H2).
    Qed.

    Lemma wbuild_ml_pl_wrapper:
      ml_pl_wrapper ml pl.
    Proof.
      ind_huff; simpl.
      unfold ml_pl_wrapper; intros; contradiction.
      intros; eapply wone_step_ml_pl_wrapper; eassumption.
    Qed.
  End Wbuild.

  Lemma wbuild_pl_os:
    forall ml pl t,
      wbuild ml pl t -> ordered_siblist f pl.
  Proof.
    intros ml pl t Hwb; elim Hwb; clear Hwb ml pl t.
    intro; apply os_nil.
    intro_dest_hp; subst; intros t Hwb Hos.
    apply os_cons.
    assumption.
    simpl; tauto.
    inversion Hord; subst.
    simpl; unfold sum_order.
    unfold sum_order in H1; assumption.
    intros t' HIn.
    generalize (wbuild_pl_all_node Hwb).
    intro Han; generalize (Han _ HIn).
    intro Hin; apply is_node_exists in Hin;
      destruct Hin as [tl [tr Heq]]; subst.
    apply wbuild_wrapper in Hwb.
    destruct (wrapper_child_reached_cover f Hwb _ _ HIn) as
      [[tcl [HInl Hlel]] [tcr [HInr Hler]]].
    simpl.
    apply (permutation_in _ _ _ _ Hperm2) in HInl.
    simpl in HInl; destruct HInl as [Heq | HInl]; subst.
    unfold sum_order in Hlel; simpl in Hlel.
    unfold sum_order; eauto with arith.
    inversion Hord; subst a b l.
    cut (forall a b c : btree A, sum_order f a b -> sum_order f b c -> sum_order f a c).
    intro sum_order_trans'.
    generalize (ordered_trans _ (sum_order f) sum_order_trans' _ tcl _ H3 HInl).
    intro; apply sum_order_trans with tcl; assumption.
    apply sum_order_trans.
  Qed.

  Lemma wbuild_perm:
    forall ml pl t,
      wbuild ml pl t ->
      forall ml',
        permutation ml ml' ->
        wbuild ml' pl t.
  Proof.
    intros ml pl t Hwb; elim Hwb; clear Hwb ml pl t.
    intros t ml' Hperm.
    apply permutation_one_inv in Hperm; subst.
    apply wbuild_one.
    intro_dest_hp; subst.
    intros t Hwb IH ml' Hperm.
    genc Hwb; apply wbuild_step.
    exists ht1, ht2, html; repeat split; try assumption.
    apply permutation_sym in Hperm.
    apply (permutation_trans _ _ _ _ Hperm); assumption.
  Qed.

  (********)
  Lemma wbuild_build:
    forall ml pl t,
      wbuild ml pl t ->
      build f ml t.
  Proof.
    intros ml pl t Hwb; elim Hwb; clear ml pl t Hwb.
    apply build_one.
    intros ml1 pl1 ml2 pl2 Hhp t Hwb IH.
    apply wone_step_one_step in Hhp.
    apply (build_step _ f _ _ _ Hhp IH).
  Qed.
  (********)

  Lemma build_wbuild:
    forall ml t,
      build f ml t ->
      exists pl,
        wbuild ml pl t.
  Proof.
    intros ml t Hbuild; elim Hbuild; clear Hbuild ml t.
    intro t; exists nil; apply wbuild_one.
    intros t ml1 ml2 [ml [t1 [t2 [Hord [Hperm1 Hperm2]]]]].
    intros Hbuild [pl2 Hwb].
    exists (t1/-\t2::pl2).
    eapply wbuild_step.
    exists t1, t2, ml; repeat split; try eassumption.
    assumption.
  Qed.

  Theorem wbuild_gsiblprop:
    forall ml pl t,
      wbuild ml pl t ->
      gsp f t ml pl.
  Proof.
    intros ml pl t Hwb.
    split;
      [genc Hwb; apply wbuild_wrapper
        | genc Hwb; apply wbuild_pl_os].
  Qed.

  Theorem build_gsiblprop:
    forall ml t,
      build f ml t ->
      exists pl,
        gsp f t ml pl.
  Proof.
    intros ml t Hb.
    destruct (build_wbuild Hb) as [pl Hwb].
    exists pl; split;
      [genc Hwb; apply wbuild_wrapper
        | genc Hwb; apply wbuild_pl_os].
  Qed.

  Definition huffman_tree' (t: btree A) :=
    build f (leaves t) t.

  Definition huffman_tree (t: btree A) :=
    exists w,
      wbuild (leaves t) w t.

  Lemma build_equiv_huffman_tree:
    forall t,
      build f (leaves t) t <-> huffman_tree t.
  Proof.
    intro t; split.
    apply build_wbuild.
    intros [pl Hwb].
    apply (wbuild_build Hwb).
  Qed.

  Theorem huffman_tree_siblprop:
    forall t, huffman_tree t -> sibling_property f t.
  Proof.
    intros t [w Hwb];
      exists w; genc Hwb; apply wbuild_gsiblprop.
  Qed.

  Theorem huffman_tree'_siblprop:
    forall t, huffman_tree' t -> sibling_property f t.
  Proof.
    intros t Hb.
    destruct (build_wbuild Hb) as [w Hwb].
    exists w; genc Hwb; apply wbuild_gsiblprop.
  Qed.

  Theorem gsiblprop_build:
    forall ml pl t,
      distinct_leaves t ->
      strict_parent f t ->
      gsp f t ml pl ->
      build f ml t.
  Proof.
    intros ml pl t Hdl Hsp [Hw Hos].
    generalize ml t Hdl Hsp Hw.
    clear ml t Hdl Hsp Hw.
    elim Hos; clear Hos pl.

    intros.
    apply wrapper_nil_inv in Hw; subst; apply build_one.

    intros ph pl Hos IH Hin Hws Hnl ml t Hdl Hsp Hw.
    apply is_node_exists in Hin.
    destruct Hin as [tl [tr Heq]]; subst.
    generalize
      (wrapper_min_child_in_cover Hw
        (aws_cons Hws (os_all_well_sibl Hos))
        Hsp (permutation_refl _ _) Hnl);
      simpl; intros [HIn_l HIn_r].
    apply in_to_perm in HIn_l;
      destruct HIn_l as [mll Hperm_l].
    apply in_to_perm in HIn_r;
      destruct HIn_r as [mlr Hperm_r].
    generalize
      (perm_2_1 (wrapper_no_twin Hw Hdl (or_introl _ (eq_refl _))) Hperm_l Hperm_r);
      intros [ml' Hperm].
    generalize
      (wrapper_inv Hw Hdl Hperm
        (permutation_refl _ _));
      intro Hw'.
    generalize (IH _ _ Hdl Hsp Hw'); intro Hb.
    eapply build_step in Hb.
    apply permutation_sym in Hperm.
    apply (build_permutation _ _ _ _ _ Hb Hperm).
    destruct (ordered_perm_ex (sum_order f) (sum_order_dec f) ml') as [ml'' [Hperm' Hord']].
    exists ml'', tl, tr; repeat split.
    apply ordered_cons.
    simpl in Hws; assumption.
    apply ordered_in_ordered.
    assumption.
    intros y HIn.
    apply (permutation_in _ _ _ _ (permutation_sym _ _ _ Hperm')) in HIn.
    generalize (wrapper_cover_parent_in_wrapper Hw' Hdl _ (or_intror _ HIn)).
    intros [Heq | [tl' [tr' [HIn' [Heqy | Heqy]]]]]; subst.
    apply inb_sum_order.
    apply inb_trans with (tl/-\tr).
    apply innodeR; apply inleaf.
    apply (wrapper_cover_In_inb Hw'); simpl; left; reflexivity.
    generalize (Hnl _ HIn'); simpl; tauto.
    generalize (Hnl _ HIn'); simpl; intro Hord.
    apply sum_order_trans with tl'.
    assumption.
    apply (os_all_well_sibl Hos) in HIn'; simpl in HIn'; assumption.
    repeat apply permutation_skip; assumption.
    apply permutation_skip; assumption.
  Qed.

  Theorem gsiblprop_wbuild:
    forall ml pl t,
      distinct_leaves t ->
      strict_parent f t ->
      gsp f t ml pl ->
      wbuild ml pl t.
  Proof.
    intros ml pl t Hdl Hsp [Hw Hos].

    (*****)
    generalize ml t Hdl Hsp Hw.
    clear ml t Hdl Hsp Hw.
    elim Hos; clear Hos pl.

    intros.
    apply wrapper_nil_inv in Hw; subst; apply wbuild_one.

    intros ph pl Hos IH Hin Hws Hnl ml t Hdl Hsp Hw.
    apply is_node_exists in Hin.
    destruct Hin as [tl [tr Heq]]; subst.
    generalize
      (wrapper_min_child_in_cover Hw
        (aws_cons Hws (os_all_well_sibl Hos))
        Hsp (permutation_refl _ _) Hnl);
      simpl; intros [HIn_l HIn_r].
    apply in_to_perm in HIn_l;
      destruct HIn_l as [mll Hperm_l].
    apply in_to_perm in HIn_r;
      destruct HIn_r as [mlr Hperm_r].
    generalize
      (perm_2_1 (wrapper_no_twin Hw Hdl (or_introl _ (eq_refl _))) Hperm_l Hperm_r);
      intros [ml' Hperm].

    inversion Hw.
    unfold wrapper_prop in H; subst.

    generalize
      (wrapper_inv Hw Hdl Hperm
        (permutation_refl _ _));
      intro Hw'.
    generalize (IH _ _ Hdl Hsp Hw');
      intros Hwb.
    eapply wbuild_step in Hwb.
    apply permutation_sym in Hperm.
    apply (wbuild_perm Hwb Hperm).
    destruct (ordered_perm_ex (sum_order f) (sum_order_dec f) ml') as [ml'' [Hperm' Hord']].
    exists tl, tr, ml''; repeat split.
    apply ordered_cons.
    simpl in Hws; assumption.
    apply ordered_in_ordered.
    assumption.
    intros y HIn.
    apply (permutation_in _ _ _ _ (permutation_sym _ _ _ Hperm')) in HIn.
    generalize (wrapper_cover_parent_in_wrapper Hw' Hdl _ (or_intror _ HIn)).
    intros [Heq | [tl' [tr' [HIn' [Heqy | Heqy]]]]]; subst.
    apply inb_sum_order.
    apply inb_trans with (tl/-\tr).
    apply innodeR; apply inleaf.
    apply (wrapper_cover_In_inb Hw'); simpl; left; reflexivity.
    generalize (Hnl _ HIn'); simpl; tauto.
    generalize (Hnl _ HIn'); simpl; intro Hord.
    apply sum_order_trans with tl'.
    assumption.
    apply (os_all_well_sibl Hos) in HIn'; simpl in HIn'; assumption.
    repeat apply permutation_skip; assumption.
    apply permutation_skip; assumption.
  Qed.

  Theorem siblprop_huffman_tree:
    forall t,
      distinct_leaves t ->
      strict_parent f t ->
      sibling_property f t ->
      huffman_tree t.
  Proof.
    intros t Hdl Hsp [w Hgs].
    exists w;
      apply (gsiblprop_wbuild Hdl Hsp Hgs).
  Qed.

  Theorem siblprop_huffman_tree':
    forall t,
      distinct_leaves t ->
      strict_parent f t ->
      sibling_property f t ->
      huffman_tree' t.
  Proof.
    intros t Hdl Hsp [w Hgs].
    apply (gsiblprop_build Hdl Hsp Hgs).
  Qed.

  Theorem build_equiv_gsiblprop:
    forall c t,
      distinct_leaves t ->
      strict_parent f t ->
      (build f c t <-> exists w, gsp f t c w).
  Proof.
    intros c t Hdl Hsp; split;
      [apply build_gsiblprop |
        intros [w Hgsp]; genc Hgsp;
          apply (gsiblprop_build Hdl Hsp)].
  Qed.

  Theorem wbuild_equiv_gsiblprop:
    forall c w t,
      distinct_leaves t ->
      strict_parent f t ->
      (wbuild c w t <-> gsp f t c w).
  Proof.
    intros c w t Hdl Hsp; split;
      [apply wbuild_gsiblprop |
        apply (gsiblprop_wbuild Hdl Hsp)].
  Qed.

  (** t is Huffman Treee <-> t satisfies SiblingProperty *)
  Theorem huffman_tree_equiv_sibling_property:
    forall t,
      distinct_leaves t ->
      strict_parent f t ->
      (huffman_tree t <-> sibling_property f t).
  Proof.
    intros t Hdl Hsp; split;
      [apply huffman_tree_siblprop
        | apply (siblprop_huffman_tree Hdl Hsp)].
  Qed.

  Theorem huffman_tree'_equiv_sibling_property:
    forall t,
      distinct_leaves t ->
      strict_parent f t ->
      (huffman_tree' t <-> sibling_property f t).
  Proof.
    intro t; apply build_equiv_gsiblprop.
  Qed.
End HuffmanTree.


From Coq Require Import Strings.String.
Require Import Maps.
Require Import UVM.

(** * Singleton Ringoid *)
Inductive singleton := u.
Definition sadd  (_ _: singleton): singleton := u.
Definition smul  (_ _: singleton): singleton := u.
Definition smeet (_ _: singleton): singleton := u.

Lemma sadd_comm: forall a b, sadd a b = sadd b a.
Proof. auto. Qed.

Lemma sadd_assoc: forall a b c, sadd a (sadd b c) = sadd (sadd a b) c.
Proof. auto. Qed.

Lemma szero_add_idr: forall a, sadd a u = a.
Proof. destruct a; auto. Qed.

Lemma szero_add_idl: forall a, sadd u a = a.
Proof. destruct a; auto. Qed.

Lemma smul_assoc: forall a1 a2 a3, smul a1 (smul a2 a3) = smul (smul a1 a2) a3.
Proof. auto. Qed.

Lemma sone_mul_idr: forall a, smul a u = a.
Proof. destruct a; auto. Qed.

Lemma sone_mul_idl: forall a, smul u a = a.
Proof. destruct a; auto. Qed.

Lemma smul_add_distl: forall p q r, smul p (sadd q r) = sadd (smul p q) (smul p r).
Proof. auto. Qed.

Lemma smul_add_distr: forall p q r, smul (sadd p q) r = sadd (smul p r) (smul q r).
Proof. auto. Qed.

Lemma szero_absorbl: forall a, smul a u = u.
Proof. auto. Qed.

Lemma szero_absorbr: forall a, smul u a = u.
Proof. auto. Qed.

Lemma smeet_assoc: forall a1 a2 a3, smeet a1 (smeet a2 a3) = smeet (smeet a1 a2) a3.
Proof. auto. Qed.

Lemma smeet_comm: forall a1 a2, smeet a1 a2 = smeet a2 a1.
Proof. auto. Qed.

Lemma smeet_idem: forall a1 a2, smeet a1 (smeet a1 a2) = smeet a1 a2.
Proof. auto. Qed.

Lemma smul_meet_distl: forall p q r, smul p (smeet q r) = smeet (smul p q) (smul p r).
Proof. auto. Qed.

Lemma smul_meet_distr: forall p q r, smul (smeet p q) r = smeet (smul p r) (smul q r).
Proof. auto. Qed.

Lemma sadd_meet_dist: forall p q r, sadd (smeet p q) r = smeet (sadd p r) (sadd q r).
Proof. auto. Qed.

Instance r_singleton : Ringoid singleton :=
 {
   r0 := u;
   r1 := u;
   radd := sadd;
   rmul := smul;
   rmeet := smeet;

   radd_comm       := sadd_comm;
   radd_assoc      := sadd_assoc;
   rzero_add_idr   := szero_add_idr;
   rzero_add_idl   := szero_add_idl;
   rmul_assoc      := smul_assoc;
   rone_mul_idr    := sone_mul_idr;
   rone_mul_idl    := sone_mul_idl;
   rmul_add_distl  := smul_add_distl;
   rmul_add_distr  := smul_add_distr;
   rzero_absorbl   := szero_absorbl;
   rzero_absorbr   := szero_absorbr;
   rmeet_assoc     := smeet_assoc;
   rmeet_comm      := smeet_comm;
   rmeet_idem      := smeet_idem;
   rmul_meet_distl := smul_meet_distl;
   rmul_meet_distr := smul_meet_distr;
   radd_meet_dist  := sadd_meet_dist;
 }.

(** * STLC *)

(* Instantiating the framework with a singleton ringoid should just
   recover the standard STLC (with sum and products types, etc.)
 *)

Definition s_mctx0 := @mctx0 singleton r_singleton.

Lemma dup_smctx0: s_mctx0 = s_mctx0 ::+:: s_mctx0.
Proof. auto. Qed.

(* \x. (x, x) : T -> (T, T) *)
Example prod_abs: forall T, s_mctx0 ;; empty |-
                       tm_abs u "x" (tm_prod (tm_var "x") (tm_var "x")) \in
                       ty_arrow u T (ty_prod T T).
Proof.
  intros.
  apply t_abs.
  rewrite dup_smctx0.
  apply t_prod_intro;
    apply t_var; auto.
Qed.


(**
unit_eqType, unit_choiceType, unit_countType, unit_finType を求める。
 *)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import perm.

(**
## eqType
 *)
Check @EqMixin : forall (T : Type) (op : rel T),
    Equality.axiom (T:=T) op -> Equality.mixin_of T.

Definition eqUnit (_ _ : unit) := true.     (* op *)

(* boolean とのリフレクションが成り立つ *)
Lemma unit_eqP : @Equality.axiom unit eqUnit. (* axiom *)
Proof.
    by do 2!case; left.
Qed.

Definition unit_eqMixin := @EqMixin unit eqUnit unit_eqP.
(* Definition unit_eqMixin := EqMixin unit_eqP. *)
Canonical unit_eqType := Eval hnf in EqType unit unit_eqMixin.

(**
## choiceType
 *)
Check @CanChoiceMixin : forall (T : choiceType) (sT : Type) (f : sT -> T) (f' : T -> sT),
    cancel f f' -> choiceMixin sT.

(* boolによるピックアップができること。 *)
Definition pickUnit : unit -> bool := xpredT.
Definition unpickUnit : bool -> unit := fun _ => tt.

(* pickとunpickで消せること。 *)
Lemma bool_of_unitK : cancel pickUnit unpickUnit.
Proof.
    by case.
Qed.

Definition unit_choiceMixin := @CanChoiceMixin bool_choiceType unit
                                               pickUnit unpickUnit
                                               bool_of_unitK.
(* Definition unit_choiceMixin := CanChoiceMixin bool_of_unitK. *)
Canonical unit_choiceType := Eval hnf in ChoiceType unit unit_choiceMixin.

(**
## countType
 *)
Check @CanCountMixin : forall (T : countType) (sT : Type) (f : sT -> T) (f' : T -> sT),
    cancel f f' -> Countable.mixin_of sT.

Definition unit_countMixin := @CanCountMixin bool_countType unit
                                             pickUnit unpickUnit
                                             bool_of_unitK.
(* Definition unit_countMixin := CanCountMixin bool_of_unitK. *)
Canonical unit_countType := Eval hnf in CountType unit unit_countMixin.

(**
## finType
 *)
Check @FinMixin : forall (T : countType) (e : seq T),
    Finite.axiom (T:=T) e -> Finite.mixin_of T.

Definition enumUnit := [:: tt].             (* enum *)

(* enum のなかに 型の要素がひとつづつ存在する。 *)
Lemma unit_enumP : @Finite.axiom unit_eqType enumUnit.   (* axiom *)
Proof.
    by case.
Qed.

Definition unit_finMixin := @FinMixin unit_countType enumUnit unit_enumP.
(* Definition unit_finMixin := Eval hnf in FinMixin unit_enumP. *)
Canonical unit_finType := Eval hnf in FinType unit unit_finMixin.

Lemma card_unit : #|{: unit}| = 1.
Proof.
    by rewrite cardT enumT unlock.
Qed.

(* END *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(** THIS FILE IS DEPRECATED. Use [ZBinary.Z] instead. *)

Require Export BinInt Zcompare Zorder ZBinary.

Open Local Scope Z_scope.

(** Definition [Zmax] is now [BinInt.Zmax]. *)

(** * Characterization of maximum on binary integer numbers *)

Definition Zmax_case := Z.max_case.
Definition Zmax_case_strong := Z.max_case_strong.

Lemma Zmax_spec : forall x y,
  x >= y /\ Zmax x y = x  \/ x < y /\ Zmax x y = y.
Proof.
 intros x y. rewrite Zge_iff_le. destruct (Z.max_spec x y); auto.
Qed.

Lemma Zmax_left : forall n m, n>=m -> Zmax n m = n.
Proof. intros x y. rewrite Zge_iff_le. apply Zmax_l. Qed.

Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := Zmax_r.

(** * Least upper bound properties of max *)

Definition Zle_max_l : forall n m, n <= Zmax n m := Z.le_max_l.
Definition Zle_max_r : forall n m, m <= Zmax n m := Z.le_max_r.

Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p
 := Z.max_lub.

Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p
 := Z.max_lub_lt.

(** * Compatibility with order *)

Definition Zle_max_compat_r : forall n m p, n <= m -> Zmax n p <= Zmax m p
 := Z.max_le_compat_r.

Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m
 := Z.max_le_compat_l.

(** * Semi-lattice properties of max *)

Definition Zmax_idempotent : forall n, Zmax n n = n := Z.max_id.
Definition Zmax_comm : forall n m, Zmax n m = Zmax m n := Z.max_comm.
Definition Zmax_assoc : forall n m p, Zmax n (Zmax m p) = Zmax (Zmax n m) p
 := Z.max_assoc.

(** * Additional properties of max *)

Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}.
Proof. exact Z.max_dec. Qed.

Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m
 := Z.max_le.

(** * Operations preserving max *)

Definition Zsucc_max_distr :
  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m)
 := Z.succ_max_distr.

Definition Zplus_max_distr_l : forall n m p:Z, Zmax (p + n) (p + m) = p + Zmax n m
 := Z.add_max_distr_l.

Definition Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p
 := Z.add_max_distr_r.

(** * Maximum and Zpos *)

Lemma Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q).
Proof.
 intros; unfold Zmax, Pmax; simpl; generalize (Pcompare_Eq_eq p q).
 destruct Pcompare; auto.
 intro H; rewrite H; auto.
Qed.

Lemma Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p.
Proof.
  intros; unfold Zmax; simpl; destruct p; simpl; auto.
Qed.

(** * Characterization of Pminus in term of Zminus and Zmax *)

Lemma Zpos_minus : forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q).
Proof.
  intros; simpl. destruct (Pcompare p q Eq) as [ ]_eqn:H.
  rewrite (Pcompare_Eq_eq _ _ H).
  unfold Pminus; rewrite Pminus_mask_diag; reflexivity.
  rewrite Pminus_Lt; auto.
  symmetry. apply Zpos_max_1.
Qed.

(* begin hide *)
(* Compatibility *)
Notation Zmax1 := Zle_max_l (only parsing).
Notation Zmax2 := Zle_max_r (only parsing).
Notation Zmax_irreducible_inf := Zmax_irreducible_dec (only parsing).
Notation Zmax_le_prime_inf := Zmax_le_prime (only parsing).
(* end hide *)


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive term :=
  | S : term
  | K : term
  | App : term -> term -> term.
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint is_value (t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.

(* Why3 assumption *)
Inductive context :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context.
Axiom context_WhyType : WhyType context.
Existing Instance context_WhyType.

(* Why3 assumption *)
Fixpoint is_context (c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.

(* Why3 assumption *)
Fixpoint subst (c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.

(* Why3 assumption *)
Inductive infix_mnmngt: term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR: term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Hint Constructors infix_mnmngt.
Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 5; admit.

(* Why3 goal *)
Theorem reducible_or_value : forall (t:term), (exists t':term, (infix_mnmngt
  t t')) \/ (is_value t).
(* Why3 intros t. *)
induction t; intuition.
right; simpl; auto.
right; simpl; auto.
left.
destruct H as (t1',h1).
exists (App t1' t2); intuition. ae.
left.
destruct H as (t1',h1).
exists (App t1' t2); intuition. ae.
left.
destruct H0 as (t2',h2).
exists (App t1 t2'); intuition. ae.
(* is_value t1 && is_value t2 *)
destruct t1; intuition.
destruct t1_1; intuition.
simpl in H.
right; red; intuition.
simpl in H.
left; intuition.
exists t1_2; intuition.
apply (red_K Hole); auto. ae.
simpl in H.
destruct t1_1_1; intuition.
left.
rename t1_1_2 into v1. rename t1_2 into v2. rename t2 into v3.
exists (App (App v1 v3) (App v2 v3)); intuition.
apply (red_S Hole); auto.
ae.
Admitted.


Require Import Classical.
Require Import List.
From mathcomp Require Import ssreflect seq.

Class Sem (CFG : Type) (RCFG : Type) :=
  {
  rule : seq (prod CFG RCFG) -> (prod CFG RCFG) -> Prop
  }.

Definition Spec (PARAM : Type) (CFG : Type) (RCFG : Type)
           (param : PARAM) :=
  CFG -> (RCFG -> Prop) -> Prop.

Inductive deriv {CFG} {RCFG} {sem : Sem CFG RCFG}
  : (prod CFG RCFG)->Prop :=
  Der:
    forall c r lst,
      rule lst (c, r) ->
      (forall i p, nth_error lst i = Some p -> deriv p) ->
      deriv (c, r).

(* definition of "res" inlined into definition of "infer" *)
Inductive infer {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}
          (param : PARAM) (phi : Spec PARAM CFG RCFG param)
  : (prod CFG RCFG) -> Prop :=
  Inf:
    forall c r crs,
      rule crs (c, r) ->
      (forall i p,
          nth_error crs i = Some p ->
          (((~(exists P, phi (fst p) P)) /\ infer param phi p) \/
           (exists P, phi (fst p) P /\ P (snd p)))
      ) ->
      infer param phi (c, r).

(* Perhaps due to the positioning of the subterm "infer param phi p",
   the generated ind principle is unusable.
   We prove a custome induction principle for infer. *)
Fixpoint infer_ind'
         (PARAM CFG RCFG: Type)
         (sem: Sem CFG RCFG)
         (param: PARAM)
         (phi: Spec PARAM CFG RCFG param)
         (P: (prod CFG RCFG) -> Prop)
         (eInf: forall c r crs,
             rule crs (c, r) ->
             (forall i p',
                 nth_error crs i = Some p' ->
                 (((~(exists P', phi (fst p') P')) /\ infer param phi p') \/
                  (exists P', phi (fst p') P' /\ P' (snd p')))) ->
             (forall i p', nth_error crs i = Some p' ->
                          (((~(exists P', phi (fst p') P')) /\ P p') \/
                           (exists P', phi (fst p') P' /\ P' (snd p')))
             ) ->
             P (c, r)
         )
         (p: prod CFG RCFG)
         (e: infer param phi p)
  :
    P p.
  refine (match e with
          | Inf c r crs H_rule H' => _
          end).
  apply eInf with (crs:=crs)=>//.
  move=> i p' H_ip'.
  move: H'=>/(_ i p' H_ip')=> H'.
  elim H'=> H'_case.
  - left. case H'_case =>[H_ne H_infer]. apply: conj=>//.
    apply infer_ind' with
        (PARAM:=PARAM) (sem:=sem) (param:=param) (phi:=phi)=>//.
  - right=>//.
Defined.

Definition verif {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}
           (param : PARAM)
  : (Spec PARAM CFG RCFG param) -> Prop :=
  (fun phi =>
     (forall c r P,
         infer param phi (c, r) -> phi c P -> P r)).

Definition valid {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}
           (param : PARAM)
  : (Spec PARAM CFG RCFG param) -> Prop :=
  (fun phi =>
     (forall c r P,
         deriv (c, r) -> phi c P -> P r)).

Lemma deriv_impl_infer {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}:
  forall (param: PARAM) (phi: Spec PARAM CFG RCFG param) c r,
    verif param phi -> deriv (c, r) -> infer param phi (c, r).
Proof.
  move=> param phi c r H_ver.
  move En: (c, r)=> p0 H_deriv.
  move: H_deriv c r En.
  elim.
  move=> c r lst H_rule H_der_i IH c0 r0 H_eq.
  apply: Inf. apply: H_rule.
  move=> i p' H_ip'.
  move: IH =>/(_ i p' H_ip' (fst p') (snd p')).
  rewrite -surjective_pairing=>/(_ (eq_refl _))=>IH.
  have H_or: (exists P, phi (fst p') P) \/ ~(exists P, phi (fst p') P)
    by apply: classic.
  case H_or=> H_exnex.
  - right.
    case: H_exnex => [P H_phicP].
    rewrite /verif in H_ver.
    exists P=>/=. apply: conj=>//.
    move: H_ver=>/(_ (fst p') (snd p') P).
    rewrite -surjective_pairing.
    move=> H_ver; apply: H_ver=>//=.
  - left. apply: conj=>//.
Qed.

Theorem soundness {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}:
  forall (param: PARAM) phi, verif param phi -> valid param phi.
Proof.
  move=> param phi H_ver.
  have H'_ver: verif param phi by done.
  rewrite /verif in H'_ver. rewrite /valid.
  move=> c r P H_der H_phic.
  have H_inf: infer param phi (c, r) by apply: deriv_impl_infer=>//.
  move: H'_ver=> /(_ c r P H_inf H_phic)=>//.
Qed.

Inductive phi_valid {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG} (param: PARAM):
  (Spec PARAM CFG RCFG param) :=
  PV c: phi_valid param c (fun r => deriv (c, r)).

Lemma phi_valid_infer_deriv {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}:
  forall (param: PARAM) c r,
    infer param (phi_valid param) (c, r) -> deriv (c, r).
Proof.
  move=> param c r.
  move En: (c, r)=> p.
  move En': (phi_valid param)=> phiprm.
  move=> H_infer. move: H_infer c r En.
  elim /infer_ind'.
  move=> c r crs H_rule H_i IH c0 r0 H_eq.
  apply: Der. apply: H_rule.
  move=> i p0 H_ip0.
  move: IH=>/(_ i p0 H_ip0)=> IH.
  case IH=> [H_nex | H_ex].
  - case H_nex=> [H_ne H_inf].
    move: H_inf=>/(_ (fst p0) (snd p0)).
    rewrite -surjective_pairing=>/(_ (eq_refl _))=>//.
  - case H_ex=> [P' [H_phiprm H']].
    rewrite <- En' in H_phiprm.
    inversion H_phiprm; subst.
    rewrite -surjective_pairing in H'=>//.
Qed.

Lemma phi_valid_verifiable {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}:
  forall (param: PARAM), verif param (phi_valid param).
Proof.
  move=> param.
  rewrite /verif.
  move=> c r P H_infer H_phi_v.
  inversion H_phi_v; subst.
  apply phi_valid_infer_deriv with (param0:=param)=>//.
Qed.

Definition spec_le {PARAM} {CFG} {RCFG}
           (param: PARAM) (phi phi' : Spec PARAM CFG RCFG param) : Prop
  :=
  (forall c P, (phi c P ->
                (exists (P': RCFG->Prop),
                    (forall r, P' r -> P r) /\ phi' c P'))).

Lemma valid_phi_le_phi_valid {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG} :
  forall (param: PARAM) phi,
    valid param phi -> spec_le param phi (phi_valid param).
Proof.
  rewrite /valid /spec_le.
  move=> param phi H_all c P H_phic.
  exists (fun r => deriv (c, r)).
  apply: conj. move=> r H_der.
  move: H_all=> /(_ c r P H_der H_phic)=>//.
  by apply: PV.
Qed.

Theorem completeness {PARAM} {CFG} {RCFG} {sem : Sem CFG RCFG}:
  forall (param: PARAM) (phi : Spec PARAM CFG RCFG param),
    valid param phi ->
    (exists phi', valid param phi' /\
                  spec_le param phi phi' /\
                  verif param phi').
Proof.
  move=> param phi H_valid.
  exists (phi_valid param).
  apply: conj.
  rewrite /valid.
  move=> c r P H_der H_phi_valid.
  inversion H_phi_valid; subst=>//.
  apply: conj;
    [apply: valid_phi_le_phi_valid | apply: phi_valid_verifiable]=>//.
Qed.


Require Import Coq.Vectors.Vector.
Require Import Coq.ZArith.ZArith.

Require Import UkModulo.Notations.Vector.

Open Scope Z.
Open Scope vector_scope.

Definition digit : Set := {n : Z | 0 <= n <= 9}.

Definition digit_value (d : digit) : Z := proj1_sig d.

Definition t : Set := Vector.t digit 14.

Definition as_vector_z (d : t) : {r : Vector.t Z 14 | forall m : Fin.t 14, r[@m] = digit_value d[@m]}.
  refine (exist _ (map digit_value d) _).
  intros m; now apply VectorSpec.nth_map.
Defined.

Section Digits.

  Definition digit_check (n : Z) : Prop := 0 <= n <= 9.

  Ltac digit_proof := split; compute; discriminate.

  Lemma digit_0 : 0 <= 0 <= 9. digit_proof. Qed.
  Lemma digit_1 : 0 <= 1 <= 9. digit_proof. Qed.
  Lemma digit_2 : 0 <= 2 <= 9. digit_proof. Qed.
  Lemma digit_3 : 0 <= 3 <= 9. digit_proof. Qed.
  Lemma digit_4 : 0 <= 4 <= 9. digit_proof. Qed.
  Lemma digit_5 : 0 <= 5 <= 9. digit_proof. Qed.
  Lemma digit_6 : 0 <= 6 <= 9. digit_proof. Qed.
  Lemma digit_7 : 0 <= 7 <= 9. digit_proof. Qed.
  Lemma digit_8 : 0 <= 8 <= 9. digit_proof. Qed.
  Lemma digit_9 : 0 <= 9 <= 9. digit_proof. Qed.

  Definition _0 : digit := exist digit_check 0 digit_0.
  Definition _1 : digit := exist digit_check 1 digit_1.
  Definition _2 : digit := exist digit_check 2 digit_2.
  Definition _3 : digit := exist digit_check 3 digit_3.
  Definition _4 : digit := exist digit_check 4 digit_4.
  Definition _5 : digit := exist digit_check 5 digit_5.
  Definition _6 : digit := exist digit_check 6 digit_6.
  Definition _7 : digit := exist digit_check 7 digit_7.
  Definition _8 : digit := exist digit_check 8 digit_8.
  Definition _9 : digit := exist digit_check 9 digit_9.

End Digits.

Section Proofs.

  Theorem digit_value_correct :
       digit_value _0 = 0
    /\ digit_value _1 = 1
    /\ digit_value _2 = 2
    /\ digit_value _3 = 3
    /\ digit_value _4 = 4
    /\ digit_value _5 = 5
    /\ digit_value _6 = 6
    /\ digit_value _7 = 7
    /\ digit_value _8 = 8
    /\ digit_value _9 = 9.
  Proof.
    repeat (split; auto).
  Qed.

  Definition a : t :=
    [ _0; _8; _9; _9; _9; _9;
      _6; _6; _3; _7; _4; _9; _5; _8 ].

End Proofs.