(*
Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  split.
  destruct H0.
 *)

Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  assert (forall (X Y : Prop), X /\ Y -> Y /\ X).
  intros.
  destruct H1.
  split.
  apply H2.
  apply H1.
  split.
  apply (H1 S P H).
  apply (H1 Q R H0).
Qed.

Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  cut (forall (X Y : Prop), X /\ Y -> Y /\ X).
  intro.
  split.
  apply (H1 S P).
  apply H.
  apply (H1 Q R).
  apply H0.
  intros.
  destruct H1.
  split.
  apply H2.
  apply H1.
Qed.

Require Import List.
Theorem app_eq_nil : forall (A : Type)(l l' : list A), l ++ l' = nil -> l = nil /\ l' = nil.
  intros.
  split.
  destruct l.
  reflexivity.
  discriminate.
  destruct l'.
  reflexivity.
  destruct l.
  discriminate.
  discriminate.
Qed.

Require Import List.
Goal forall (A : Type)(a : A), nil <> a :: nil.
  discriminate.
Qed.

Goal forall (n m : nat)(f : nat -> nat), f n = n -> S (f (f n)) = S m -> n = m.
  intros.
  congruence.
Qed.

Goal forall (A : Type)(x y : A), x :: y :: nil <> x :: nil.
  intros.
  congruence.
Qed.

(*
Require Import Arith.
Goal forall (P Q : nat -> Prop)(a : nat), P (a * 2) \/ Q (a * 2).
  intros.
  (*rewrite mult_comm.*)
  replace (Q (a * 2)) with (Q (2 * a)).
  simpl.
 *)

(*
Require Import List.
Lemma removelast_app : forall (A : Type)(l l' : list A), l' <> nil -> removelast (l ++ l') = l ++ removelast l'.
  intros.
  induction l.
  reflexivity.
  simpl.
  destruct (l ++ l').
  remember (l ++ l').
  destruct l0.
  apply False_ind.
  apply H.
  destruct (app_eq_nil l l').
  rewrite Heql0.
  reflexivity.
  apply H1.
  f_equal.
  apply IHl.
 *)

Require Import List.
Inductive InList (A : Type)(a : A) : list A -> Prop :=
  | headIL : forall xs, InList A a (a :: xs)
  | consIL : forall x xs, InList A a xs -> InList A a (x :: xs).

Goal forall (A : Type)(l : list A)(a a' : A), InList A a (a' :: l) -> a = a' \/ InList A a l.
  intros.
  inversion H.
  left.
  reflexivity.
  right.
  apply H1.
Qed.
(*
Goal forall (n : nat), (exists m, n = 2 * m) \/ (exists m, n = 2 * m + 1).
  intros.
  left.
  exists n.
  induction n.
    reflexivity.
    simpl.
    f_equal.
    inversion IHn.
      f_equal.
      intros.
      simpl.
  *)

(*
Require Import Omega.
Goal forall (n : nat), (exists m, n = 2 * m) \/ (exists m, n = 2 * m + 1).
  intros.
  constructor.
  exists n.
  induction n.
  simpl.
  omega.
  simpl.
  induction n.
  simpl.
  apply False_ind.
 *)

(*
Goal forall (A : Type)(l m:list A) (a:A), InList A a (l ++ m) -> InList A a l \/ InList A a m.
  intros.
  left.
  destruct l.
 *)


From Nominal Require Export Group Swap Permutation.

(* Permutation Type *)
Class PermAction X := action: Perm → X → X.
#[export] Hint Mode PermAction ! : typeclass_instances.

(* CAUSA PROBLEMAS COM REESCRITA ENVOLVENDO action (- p)
  Instance: Params (@action) 2 := {}. *)

Infix "•" := action (at level 60, right associativity): nominal_scope.
Notation "(•)" := action (only parsing): nominal_scope.
Notation "(• x )" := (action x) (only parsing): nominal_scope.
Notation "( x •)" := (λ y, action y x) (only parsing): nominal_scope.

(* Permutation type is a type with a permutation group (left) action *)
Class PermT (X : Type) `{Act: PermAction X, Equiv X}: Prop := {
  gact_setoid :> Equivalence(≡@{X});
  gact_proper :> Proper ((≡@{Perm}) ==> (≡@{X}) ==> (≡@{X})) (•);

  gact_id: ∀ (x: X), ɛ • x ≡@{X} x;
  gact_compat: ∀ (p q: Perm) (x: X), p • (q • x) ≡@{X} (q + p) • x
}.

#[export] Hint Mode PermT ! - - : typeclass_instances.
#[export] Existing Instance gact_setoid.
#[export] Existing Instance gact_proper.

(* Arguments gact_id {_ _ _ _ _ Grp _ _ _ GAct} : rename.
Arguments gact_compat {_ _ _ _ _ Grp _ _ _ GAct} : rename.
Arguments gact_proper {_ _ _ _ _ Grp _ _ _ GAct} : rename. *)

Section PermTypeProperties.
  Context `{PermT X}.

  Corollary perm_left_inv (x: X) p: (-p) • p • x ≡ x.
  Proof. rewrite gact_compat, grp_right_inv, gact_id; auto. Qed.

  Corollary perm_rigth_inv (x: X) p: p • (-p) • x ≡ x.
  Proof. rewrite gact_compat, grp_left_inv, gact_id; auto. Qed.

  Lemma perm_iff (x y: X) p: p • x ≡ y ↔ x ≡ (-p) • y.
  Proof. split; intros A;
    [rewrite <-A, perm_left_inv | rewrite A, perm_rigth_inv]; auto.
  Qed.

  Lemma perm_inj (x y: X) p: p • x ≡ p • y ↔ x ≡ y.
  Proof. split; intros A;
    [apply perm_iff in A; rewrite <-(perm_left_inv y p) | rewrite A]; auto.
  Qed.

  Lemma perm_inv_empty_act (x: X): (-ɛ) • x ≡ x.
  Proof. rewrite grp_inv_neutral; apply gact_id. Qed.

  Lemma perm_action_duplicate a b (x: X): ⟨a,b⟩ • ⟨a,b⟩ • x ≡ x.
  Proof. rewrite gact_compat, perm_duplicate; apply gact_id. Qed.

  Lemma perm_action_equal a (x: X): ⟨a,a⟩ • x ≡ x.
  Proof. rewrite perm_equiv_neutral; apply gact_id. Qed.

  Lemma perm_comm a b p (x: X): a ∉ perm_dom p → b ∉ perm_dom p → ⟨a,b⟩ • p • x ≡ p • ⟨a,b⟩ • x.
  Proof. intros; rewrite gact_compat, <-perm_notin_dom_comm, <-gact_compat; auto. Qed.

  Lemma perm_swap_distr a b p (x: X): p • ⟨a,b⟩ • x ≡ ⟨perm_swap p a, perm_swap p b⟩ • p • x.
  Proof. rewrite 2gact_compat, perm_comm_distr; auto. Qed.
End PermTypeProperties.

(* #[global] Instance action_perm_proper `{Perm A}: Proper ((≡@{perm}) ⟹ (≡@{A}) ⟹ (≡@{A})) action.
Proof. apply gact_proper. Qed. *)


Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros [] c H.
  apply H. discriminate H.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [| n] .
  - reflexivity.
  - reflexivity.
Qed.

(* ------------------------------- *)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f x b.
  rewrite -> x.
  rewrite -> x.
  reflexivity.
Qed.

From Coq Require Export String.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition manual_grade_for_negation_fn_applied_twice : option (nat*string) := None.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f x b.
  rewrite -> x.
  rewrite -> x.
  destruct b eqn:Eb.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b eqn:Eb.
     - destruct c eqn:Ec.
     reflexivity.
     discriminate.
     - destruct c eqn:Ec.
     discriminate.
     reflexivity.
Qed.

Theorem andb_eq_orb' :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros a b H.
  destruct a.
  rewrite <- (andb_true_elim2 true b).
  reflexivity.
  apply H.
  apply H.
Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
  match m with
  | Z => B Z
  | B m' => A ( incr m')
  | A m' => B m'
  end.

Example test_inc1: (incr Z) = B Z.
Proof. simpl. reflexivity. Qed.
Example test_inc2: (incr (B Z)) = A (B Z).
Proof. simpl. reflexivity. Qed.
Example test_inc3: (incr (A (B (B Z)))) = B (B (B Z)).
Proof. simpl. reflexivity. Qed.
Example test_inc4: (incr (B (B (B Z)))) = A(A (A (B Z))).
Proof. simpl. reflexivity. Qed.


From Undecidability.L Require Export L Encodings Interpreter Choose.

(** * Results obtained with self-interpreters *)

(** ** Step-indexed self-interpreter *)

(** *** Encoding of options *)

Definition none : term := .\"s", "n"; "n".
Definition some : term := .\"t", "s", "n"; "s" "t".

Hint Unfold some none : cbv.

Definition oenc t :=
  match t with
  | Some t => lambda(lambda (1 (tenc t)))
  | None => none
  end.

Lemma oenc_cls s: closed (oenc s).
Proof.
  destruct s; simpl; value.
Qed.

Lemma oenc_lambda s: lam (oenc s).
Proof.
  destruct s; simpl; value.
Qed.

Hint Resolve oenc_cls oenc_lambda: cbv.

Lemma some_correct s : some (tenc s) ≡ oenc (Some s).
Proof.
  solveeq.
Qed.

Lemma some_correct_r s t t' : proc t -> proc t' -> oenc (Some s) t t' ≡ t (tenc s).
Proof.
  intros. solveeq.
Qed.

Lemma none_correct s t : proc s -> proc t  -> none s t ≡ t.
Proof.
  intros. solveeq.
Qed.

Lemma oenc_correct_some s v : lam v -> oenc (Some s) ≡ some v -> v ≡ tenc s.
Proof.
  intros lam_v H.
  symmetry in H. eapply eqTrans with (s := lambda(lambda(1 v))) in H. eapply unique_normal_forms in H; value. inv H. reflexivity.
  symmetry; clear H; solvered.
Qed.

Lemma oenc_inj o1 o2 : oenc o1 ≡ oenc o2 -> o1 = o2.
Proof.
  intros H; eapply unique_normal_forms in H; value.
  destruct o1, o2; try congruence; cbn in H; repeat inv H.
  eapply tenc_injective in H1. now subst.
Qed.

Lemma none_equiv_some v : ~ oenc None ≡ some v.
Proof.
  intros H. assert (eva v) as (w & [Hw Hl] % evaluates_equiv) by (eapply app_eva; eexists (oenc None); eapply evaluates_equiv; split; value; eauto using equiv).
  rewrite Hw in H. symmetry in H. eapply eqTrans with (s := (lambda (lambda (1 w)))) in H.
  eapply unique_normal_forms in H; value. inv H. symmetry. unfold some. clear H. solvered.
Qed.

(** *** Equality of encoded natural numbers *)
Definition EqN := rho (.\"EqN", "n", "m"; "n" ("m" !T !(lambda F)) (.\"n"; "m" !F (.\"m"; "EqN" "n" "m"))).

Hint Unfold EqN: cbv.

Lemma EqN_correct m n : EqN (enc m) (enc n) ≡ benc (Nat.eqb m n).
Proof with eauto.
  revert n; induction m; intros.
  - destruct n. repeat redL. repeat redL.
  - destruct n.
    + repeat redL.
    + transitivity (EqN (enc m) (enc n)). repeat redL. now rewrite IHm.
Qed.

(** *** Substitution *)

Definition Subst := rho (.\ "Subst", "s", "k", "u"; "s" (.\"n"; !EqN "n" "k" "u" (!Var "n"))
                                                     (.\"s1", "s2"; !App ("Subst" "s1" "k" "u") ("Subst" "s2" "k" "u"))
                                                     (.\"s1"; !Lam ("Subst" "s1" (!Succ "k") "u")) ).

Hint Unfold Subst : cbv.

Lemma Subst_correct s k u :
  Subst (tenc s) (enc k) (tenc u) ≡ tenc (subst s k u).
Proof.
  revert k; induction s; intros k.
  - transitivity (EqN (enc n) (enc k) (tenc u) (Var (enc n))). solveeq.
    rewrite EqN_correct.
    destruct (Nat.eqb_spec n k); cbn; decide (n = k); try congruence; solveeq.
  - specialize (IHs1 k). specialize (IHs2 k). solveeq.
  - transitivity (Lam (((Subst (tenc s)) (Succ (enc k))) (tenc u))). solveeq.
    rewrite Succ_correct, IHs;value. solveeq.
Qed.

(** *** Step-indexed self-interpreter *)

Definition E := Eval cbv in
                 rho (.\ "Eval","n","u";"u"
                   (.\"";!none)
                   (.\"s","t"; "n" !none
                                   (.\"n"; "Eval" "n" "s"
                                           (.\"s"; "Eval" "n" "t"
                                                 (.\"t"; "s"
                                                           (.\""; !none)
                                                           (.\"",""; !none)
                                                           (.\"s"; "Eval" "n" (!Subst "s" !Zero "t")))
                                                 !none)
                                           !none))
                   (.\"s"; !some (!Lam "s"))).

Definition cLam s := lambda(lambda(lambda(0 s))).
Hint Unfold cLam : cbv.

Lemma E_rec_app_Sn_1 s t n s1 t1 :
   proc s1 ->
   proc t1 ->
   E (enc n) (tenc s) ≡ some (cLam s1) ->
   E (enc n) (tenc t) ≡ some (cLam t1) ->
   E (enc (S n)) (tenc (app s t)) ≡ E (enc n) (Subst s1 Zero (cLam t1)).
Proof.
  intros. solveeq.
Qed.

Lemma E_rec_app_Sn_2 s t n : E (enc n) (tenc s) ≡ none -> E (enc (S n)) (tenc (s t)) ≡ none.
Proof.
  intros H. solveeq.
Qed.

Lemma E_rec_app_Sn_3 s t n t1 : proc t1
                                   -> E (enc n) (tenc s) ≡ some (cLam t1)
                                   -> E (enc n) (tenc t) ≡ none
                                   -> E (enc (S n)) (tenc (s t)) ≡ none.
Proof.
  intros [clsT1 lamT1] Hs Ht. solveeq.
Qed.

Lemma E_correct k s : E (enc k) (tenc s) ≡ oenc (eval k s).
Proof with value.
  revert s; induction k; intros s.
  - destruct s; solveeq.
  - destruct s.
    + solveeq.
    + destruct (eval k s1) eqn:Hs1.
      * destruct (eval_lambda Hs1); subst t. {
        destruct (eval k s2) eqn:Hs2.
        - destruct (eval_lambda Hs2); subst t.
          eapply eqTrans.
          eapply E_rec_app_Sn_1 with (s1 := tenc x) (t1 := tenc ( x0));
            eauto with cbv...
          rewrite IHk, Hs1. symmetry. solveeq.
          rewrite IHk, Hs2. symmetry. solveeq.
          assert (Subst (tenc x) Zero (tenc (lambda x0)) ≡ tenc (subst x 0 (lambda x0))).
          change Zero with (enc 0). eapply Subst_correct.
          rewrite H, IHk. simpl. now rewrite Hs1, Hs2.
       -  rewrite E_rec_app_Sn_3 with (t1 := tenc x); eauto with cbv...
          simpl. rewrite Hs1, Hs2. reflexivity.
          rewrite IHk. rewrite Hs1. symmetry. solveeq.
          rewrite IHk. rewrite Hs2. symmetry. solveeq.
        }
      * simpl. rewrite Hs1. eapply E_rec_app_Sn_2.
        change none with (oenc (None)). rewrite <- Hs1. eapply IHk.
    + solveeq.
Qed.

Lemma E_S n s t : E (enc n) (tenc s) ▷ oenc (Some t) -> E (enc (S n)) (tenc s) ▷ oenc (Some t).
Proof.
  rewrite !E_correct. intros [? % oenc_inj ?] % evaluates_equiv; value.
  erewrite eval_S; eauto using evaluates.
Qed.

Lemma E_sound n s : E (enc n) (tenc s) ▷ oenc (None) \/ exists t, E (enc n) (tenc s) ▷ oenc (Some t) /\ s ▷ t.
Proof.
  destruct (eval n s) eqn:Eq.
  - right. exists t. rewrite E_correct, Eq. eauto using evaluates, eval_evaluates.
  - left. rewrite E_correct, Eq. econstructor.
Qed.

Lemma E_complete s t : s ▷ t -> exists n, E (enc n) (tenc s) ▷ oenc (Some t).
Proof.
  intros [n H] % evaluates_eval. exists n. rewrite E_correct, H. econstructor.
Qed.

(** ** Class of total procedures is unrecognisable *)

Require Import DecidableRecognisable Rice.

Lemma totality : ~ recognisable (fun s => proc s /\ forall t, eva(s (tenc t))).
Proof.
  pose (f := fun s : term => lambda (0 (lambda (E 0 (tenc (s (tenc s))) D I)) F I)).
  pose (v := lambda (Lam (App (App (App (tenc 0) (Lam (App (App (App (App (tenc E) (tenc 0)) (Q (App 0 (Q 0)))) (tenc D)) (tenc I)))) (tenc F)) (tenc I)))).

  eapply (@Reduction _ f v).
  - value.
  - intros.
    assert (forall t, f s (tenc t) ≡ (tenc t) (lambda (E 0 (tenc (s (tenc s))) D I)) F I) by (intros; solveeq).
    intuition.
    + eapply eva_Omega.
      destruct H2 as [s' [n H2] % evaluates_eval].
      specialize (H4 n).
      rewrite H0 in H4.
      eapply eva_proper; try eassumption. symmetry.
      transitivity (E (enc n) (tenc (s (tenc s))) D I). solveeq.
      rewrite E_correct, H2. solveeq.
    + value.
    + destruct t.
      * destruct (eval n (s (tenc s))) eqn:Hs.
        -- destruct H1. exists t. firstorder using eval_evaluates.
        -- rewrite H0. eapply eva_proper.
           transitivity (E (enc n) (tenc (s (tenc s))) D I). solveeq.
           rewrite E_correct, Hs. transitivity I. solveeq. reflexivity.
           exists I; repeat econstructor.
      * exists (tenc t2). solveeq.
      * exists (tenc t). solveeq.
  - intros s.
    transitivity (Lam (App (App (App (tenc 0) (Lam (App (App (App (App (tenc E) (tenc 0)) (Q (App (tenc s) (Q (tenc s))))) (tenc D)) (tenc I)))) (tenc F)) (tenc I))). solveeq.
    now rewrite Q_correct, !App_correct, Q_correct, !App_correct, Lam_correct, !App_correct, Lam_correct.
Qed.

Theorem totality_hard : ~ recognisable (fun s => forall t, pi s t) /\ ~ recognisable (fun s => ~ forall t, pi s t).
Proof.
  split.
  - intros H. eapply totality.
    eapply recognisable_intersection; eauto. eapply dec_recognisable, decidable_proc.
  - eapply rec_total.
Qed.

(** ** Self-interpreter *)

Definition H s : term := Eval cbv in (.\ "y"; !E "y" !s !(lambda T) !F).
Definition U : term := Eval cbv in .\ "x"; !E !(C (H 1)) "x" !I !I.

Lemma U_rec s : U (tenc s) ≡ E (C (H (tenc s))) (tenc s) I I.
Proof.
  solvered.
Qed.

Lemma H_test s : test (H (tenc s)).
Proof.
  intros n.
  assert ((lambda (E 0 (tenc s) (lambda T) F)) (enc n) ≡ E (enc n) (tenc s) (lambda T) F) by solveeq.
  destruct (eval n s) eqn:Eq; [ left | right]; rewrite H0, E_correct, Eq; solveeq.
Qed.

Lemma H_inv n s : satis ( H (tenc s) ) n -> eval n s <> None.
Proof.
  intros. destruct (eval n s) eqn:Eq.
  - congruence.
  - exfalso.
    assert (H (tenc s) (enc n) ≡ E (enc n) (tenc s) (lambda T) F) by solvered. unfold satis in H0.
    rewrite H1, E_correct, Eq, none_correct in H0; value. inv H0.
Qed.

Lemma H_proc s : proc (H (tenc s)).
Proof.
  value.
Qed.

Lemma U_complete s t : s ▷ t -> U (tenc s) ▷ tenc t.
Proof.
  intros [n H0] % evaluates_eval.
  rewrite U_rec. edestruct (C_complete (n := n) (H_proc s) (H_test s)) as [? []].
  - eapply evaluates_equiv; split; value.
    transitivity ( E (enc n) (tenc s) (lambda T) F). cbn. solveeq.
    rewrite E_correct, H0. solveeq.
  - assert ((lambda (E 0 (tenc s) (lambda T) F)) (enc x) ≡ E (enc x) (tenc s) (lambda T) F) by solveeq.
    unfold satis in H2. eapply H_inv in H2.
    destruct (eval x s) eqn:Eq.
    + enough (t = t0). subst. rewrite H1, E_correct, Eq. solveeq.
      eapply eval_evaluates, evaluates_equiv in H0.  eapply eval_evaluates, evaluates_equiv in Eq.
      eapply unique_normal_forms; firstorder. now rewrite <- H0, <- H4.
    + congruence.
Qed.

Lemma U_sound s : eva (U (tenc s)) -> eva s.
Proof with eauto.
  rewrite U_rec. intros H0.
  assert (eva (C (H (tenc s)))) by
      now eapply app_eva in H0 as [[[H % app_eva ?] %app_eva ?] %app_eva ?].
  eapply C_sound in H1 as [n H1 % H_inv].
  destruct (eval n s) eqn:Eq; try congruence. eapply eval_evaluates in Eq. firstorder. value.
  eapply H_test.
Qed.

Lemma U_eva s : eva s <-> eva (U (tenc s)).
Proof.
  split.
  - intros [v Hv % U_complete]. eauto.
  - eauto using U_sound.
Qed.

Lemma recognisable_eva : recognisable eva.
Proof.
  exists U. split; value. intros. now rewrite U_eva.
Qed.


(** * Example on monoids. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)
(**
This file contains the definition of the signature of monoids and the way to turn
a monoid (as defined in [UniMath.Algebra.Monoids]) into an algebra.
*)

Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Algebra.Monoids.

Require Import UniMath.Algebra.Universal.EqAlgebras.

Local Open Scope stn.

(** Signature. *)

Definition monoid_signature := make_signature_simple_single_sorted [2; 0].

(** Algebra of monoids without equations. *)

Definition monoid_algebra (M: monoid)
  : algebra monoid_signature
  := make_algebra_simple_single_sorted monoid_signature M
  [(
    λ p, op (pr1 p) (pr12 p) ;
    λ _, unel M
  )].

Module Eqspec.

(** Free algebra of open terms. *)

Definition monoid_varspec : varspec monoid_signature
  := make_varspec monoid_signature natset (λ _, tt).

Definition Mon : UU := term monoid_signature monoid_varspec tt.
Definition mul : Mon → Mon → Mon := build_term_curried (●0: names monoid_signature).
Definition id  : Mon := build_term_curried (●1: names monoid_signature).

Definition x : Mon := varterm (0: monoid_varspec).
Definition y : Mon := varterm (1: monoid_varspec).
Definition z : Mon := varterm (2: monoid_varspec).

Definition monoid_equation : UU
  := equation monoid_signature monoid_varspec.

Definition monoid_mul_assoc : monoid_equation :=
  tt,, make_dirprod (mul (mul x y) z) (mul x (mul y z)).

Definition monoid_mul_lid : monoid_equation
  := tt,, make_dirprod (mul id x) x.

Definition monoid_mul_rid : monoid_equation
  := tt,, make_dirprod (mul x id) x.

Definition monoid_axioms : eqsystem monoid_signature monoid_varspec
  := ⟦ 3 ⟧,, three_rec monoid_mul_assoc monoid_mul_lid monoid_mul_rid.

Definition monoid_eqspec : eqspec.
Proof.
  use tpair. { exact monoid_signature. }
  use tpair. { exact monoid_varspec. }
  exact monoid_axioms.
Defined.

Definition monoid_eqalgebra := eqalgebra monoid_eqspec.

(** Every monoid is a monoid eqalgebra. *)

Section Make_Monoid_Eqalgebra.

Variable M : monoid.

Lemma holds_monoid_mul_lid : holds (monoid_algebra M) monoid_mul_lid.
Proof.
  intro. cbn in α.
  change (fromterm (ops (monoid_algebra M)) α tt (mul id x) = α 0).
  change (op (unel M) (α 0) = α 0).
  apply lunax.
Qed.

Lemma holds_monoid_mul_rid : holds (monoid_algebra M) monoid_mul_rid.
Proof.
  intro.
  change (op (α 0) (unel M) = α 0).
  apply runax.
Qed.

Lemma holds_monoid_mul_assoc : holds (monoid_algebra M) monoid_mul_assoc.
Proof.
  intro.
  change (op (op (α 0) (α 1)) (α 2) = op (α 0) (op (α 1) (α 2))).
  apply assocax.
Qed.

Definition is_eqalgebra_monoid :
  is_eqalgebra (σ := monoid_eqspec) (monoid_algebra M).
Proof.
  red. simpl.
  apply three_rec_dep; cbn.
  - exact holds_monoid_mul_assoc.
  - exact holds_monoid_mul_lid.
  - exact holds_monoid_mul_rid.
Defined.

Definition make_monoid_eqalgebra : monoid_eqalgebra.
  use make_eqalgebra.
  - exact (monoid_algebra M).
  - exact is_eqalgebra_monoid.
Defined.

End Make_Monoid_Eqalgebra.

End Eqspec.


Require Import List Lia.
Import ListNotations.

Require Import Undecidability.PCP.PCP.

Set Implicit Arguments.
Unset Strict Implicit.

Set Default Proof Using "Type".

Module PCPListNotation.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
Notation "| A |" := (length A) (at level 65).
End PCPListNotation.

Import PCPListNotation.

Ltac inv H := inversion H; subst; try clear H.

(* *Some basic things concerning lists *)

Lemma list_prefix_inv X (a : X) x u y v :
  ~ a el x -> ~ a el u -> x ++ a :: y = u ++ a :: v -> x = u /\ y = v.
Proof.
  intro. revert u.
  induction x; intros; destruct u; inv H1; try now firstorder.
    eapply IHx in H4; try now firstorder. intuition congruence.
Qed.

Lemma split_inv X (u z x y : list X) (s : X) :
  u ++ z = x ++ s :: y -> ~ s el u -> exists x' : list X, x = u ++ x'.
Proof.
  revert u. induction x; cbn; intros.
  - destruct u. cbn. eauto. inv H. firstorder.
  - destruct u. cbn. eauto.
    inv H. edestruct IHx. cbn. rewrite H3. reflexivity. firstorder. subst. cbn. eauto.
Qed.

Lemma in_split X (a : X) (x : list X) :
  a el x -> exists y z, x = y ++ [a] ++ z.
Proof.
  induction x; cbn; intros.
  - firstorder.
  - destruct H as [-> | ].
    + now exists [], x.
    + destruct (IHx H) as (y & z & ->).
      now exists (a0 :: y), z.
Qed.

Definition is_cons X (l : list X) :=
  match l with
  | [] => false
  | _ => true
  end.

Lemma is_cons_true_iff X (l : list X) :
  is_cons l = true <-> l <> [].
Proof.
  destruct l; cbn; firstorder congruence.
Qed.

(* *** Fresh symbols *)

Fixpoint fresh (l : list nat) :=
  match l with
  | [] => 0
  | x :: l => S x + fresh l
  end.

Lemma fresh_spec' l a : a el l -> a < fresh l.
Proof.
  induction l.
  - firstorder.
  - cbn; intros [ | ]; firstorder lia.
Qed.

Lemma fresh_spec (a : nat) (l : list nat) : a el l -> fresh l <> a.
Proof.
  intros H % fresh_spec'. intros <-. lia.
Qed.

Section neList.

  Variable X : Type.
  Variable P : list X -> Prop.

  Hypothesis B : (forall x : X, P [x]).
  Hypothesis S : (forall x A, P A -> P (x :: A)).

  Lemma list_ind_ne A : A <> [] -> P A.
  Proof using S B.
    intros H. destruct A. congruence. clear H.
    revert x. induction A; eauto.
  Qed.

End neList.

Fixpoint omap X Y (f : X -> option Y) l :=
  match l with
  | nil => nil
  | x :: l => match f x with Some y => y :: omap f l | None => omap f l end
  end.

Lemma in_omap_iff X Y (f : X -> option Y) l y : y el omap f l <-> exists x, x el l /\ f x = Some y.
Proof.
  induction l; cbn.
  - firstorder.
  - destruct (f a) eqn:E; firstorder (subst; firstorder congruence).
Qed.

Section Positions.
  Variables (X: Type) (d: forall x y : X, {x = y} + {x <> y}).
  Implicit Types (x y: X) (A B : list X).

  Fixpoint pos x A : option nat :=
    match A with
    | nil => None
    | y :: A' => if d x y then Some 0
                else match pos x A' with
                     | Some n => Some (S n)
                     | None => None
                     end
    end.

  Lemma el_pos x A :
    x el A -> { n | pos x A = Some n }.
  Proof.
    induction A as [|y A IH]; cbn; intros H.
    - destruct H as [].
    - destruct (d x y) as [<-|H1].
      + now exists 0.
      + destruct IH as [n IH].
        * destruct H as [->|H]; tauto.
        * rewrite IH. now exists (S n).
  Qed.

  Notation nthe n A := (nth_error A n).

  Lemma nthe_length A n :
    length A > n -> { x | nthe n A = Some x }.
  Proof.
    revert n.
    induction A as [|y A IH]; cbn; intros n H.
    - exfalso. lia.
    - destruct n as [|n]; cbn.
      + now exists y.
      + destruct (IH n) as [x H1]. lia. now exists x.
  Qed.

 Lemma pos_nthe x A n :
    pos x A = Some n -> nthe n A = Some x.
 Proof.
   revert n.
   induction A as [|y A IH]; cbn; intros n.
    - intros [=].
    - destruct (d x y) as [<-|H1].
      + now intros [= <-].
      + destruct (pos x A) as [k|]; intros [= <-]; cbn.
        now apply IH.
  Qed.

  Lemma nthe_app_l x n A B :
    nthe n A = Some x -> nthe n (A ++ B) = Some x.
  Proof.
    revert n.
    induction A as [|y A IH]; cbn; intros k H.
    - destruct k; discriminate H.
    - destruct k as [|k]; cbn in *. exact H.
      apply IH, H.
  Qed.

End Positions.

Notation nthe n A := (nth_error A n).

Lemma pos_nth X d (x : X) l n def : pos d x l = Some n -> nth n l def = x.
Proof.
  revert n; induction l; cbn; intros; try congruence.
  destruct (d x a); try destruct (pos d x l) eqn:E; inv H; eauto.
Qed.

Lemma pos_length X d (x : X) l n : pos d x l = Some n -> n < | l |.
Proof.
  revert n; induction l; cbn; intros; try congruence.
  destruct (d x a).
  - inv H. lia.
  - destruct (pos d x l) eqn:E; inv H; try lia. specialize (IHl _ eq_refl). lia.
Qed.

Lemma cons_incl X (a : X) (A B : list X) : a :: A <<= B -> A <<= B.
Proof.
  intros ? ? ?. eapply H. firstorder.
Qed.

Lemma app_incl_l X (A B C : list X) :
  A ++ B <<= C -> A <<= C.
Proof.
  intros H x Hx. eapply H. eapply in_app_iff. now left.
Qed.

Lemma app_incl_R X (A B C : list X) :
  A ++ B <<= C -> B <<= C.
Proof.
  intros H x Hx. eapply H. eapply in_app_iff. now right.
Qed.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Vectors.Fin.
Require Export Category.Lib.Foundation.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Class Setoid A := {
  equiv : crelation A;
  setoid_equiv : Equivalence equiv
}.
#[export] Existing Instance setoid_equiv.

Coercion setoid_equiv : Setoid >-> Equivalence.

Notation "f ≈ g" := (equiv f g) (at level 79) : category_theory_scope.

Definition eq_equivalence@{t u} {A : Type@{t}} : @Equivalence@{t u} A (@eq A) :=
  @Build_Equivalence@{t u} A
    (@eq A) (@eq_Reflexive A)
    (@eq_Symmetric A)
    (@eq_Transitive A).

Inductive poly_unit@{u} : Type@{u} := ttt.

Definition unit_setoid@{t u} : Setoid@{t u} poly_unit@{t} :=
  {| equiv := @eq poly_unit@{t}
   ; setoid_equiv := @eq_equivalence@{t u} poly_unit@{t} |}.

Definition eq_Setoid@{u} (A : Type@{u}) : Setoid@{u u} A :=
  Build_Setoid@{u _} A (λ f g, eq f g) eq_equivalence@{u u}.

#[export]
Program Instance funext_Setoid
        {T : Type} (t : T → Type) (a b : T) `{Setoid (t b)} :
  Setoid (t a → t b) | 9 := {|
  equiv := λ f g, ∀ x, f x ≈ g x
|}.
Next Obligation.
  constructor; repeat intro.
  - reflexivity.
  - symmetry.
    now apply X.
  - now rewrite X, X0.
Qed.

#[export]
Program Instance Fin_Setoid {n} : Setoid (Fin.t n) := {|
  equiv := eq
|}.

Class Unique `{S : Setoid A} (P : A → Type) := {
  unique_obj : A;
  unique_property : P unique_obj;
  uniqueness      : ∀ v : A, P v → unique_obj ≈ v;
}.

Arguments unique_obj {_ _ _} _.
Arguments unique_property {_ _ _} _.
Arguments uniqueness {_ _ _} _.

Notation "∃! x .. y , P" := (Unique (fun x => .. (Unique (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity) : category_theory_scope.


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

   Based on code written by:
     Brian Aydemir *)

(** A type class-based library for working with decidable equality. *)

Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Logic.Decidable.

(* *********************************************************************** *)
(** * Hints for [equiv] *)

Hint Extern 0 (?x === ?x) => reflexivity.
Hint Extern 1 (_ === _) => (symmetry; trivial; fail).
Hint Extern 1 (_ =/= _) => (symmetry; trivial; fail).

(* *********************************************************************** *)
(** * Facts about [EqDec] *)

(** The [EqDec] class is defined in Coq's standard library. *)
Section CoqEqDecSec.
  Variable A:Type.

  Lemma equiv_reflexive' : forall `{EqDec A} (x : A),
                             x === x.
  Proof. intros. apply equiv_reflexive. Qed.

  Lemma equiv_symmetric' : forall `{EqDec A} (x y : A),
                             x === y ->
                             y === x.
  Proof. intros. apply equiv_symmetric; assumption. Qed.

  Lemma equiv_transitive' : forall `{EqDec A} (x y z : A),
                              x === y ->
                              y === z ->
                              x === z.
  Proof. intros. eapply @equiv_transitive; eassumption. Qed.

  Lemma equiv_decidable : forall `{EqDec A} (x y : A),
                            decidable (x === y).
  Proof. intros. unfold decidable. destruct (x == y); auto. Defined.
End CoqEqDecSec.

(* *********************************************************************** *)
(** * Specializing [EqDec] *)

(** It is convenient to be able to use a single notation for decidable
    equality on types.  This can naturally be done using a type class.
    However, the definition of [EqDec] in the EquivDec library is
    overly general for cases where the equality is [eq]: the extra
    layer of abstraction provided by abstracting over the equivalence
    relation gets in the way of smooth reasoning.  To get around this,
    we define a version of that class where the equivalence relation
    is hard-coded to be [eq].

    Implementation note: One should not declare an instance for
    [EqDec_eq A] directly.  First, declare an instance for [@EqDec A
    eq eq_equivalence].  Second, let class inference build an instance
    for [EqDec_eq A] using the instance declaration below.

    Implementation note (BEA): Specifying [eq_equivalence] explicitly
    is important.  Following Murphy's Law, if type class inference can
    find multiple ways of inferring the [@Equivalence A eq] argument,
    it will do so in the most inconvenient way possible.
    Additionally, I choose to infer [EqDec_eq] instances from [EqDec]
    instances because the standard library already defines instances
    for [EqDec]. *)

Class EqDec_eq (A : Type) :=
  eq_dec : forall (x y : A), {x = y} + {x <> y}.

Instance EqDec_eq_of_EqDec {A} (qa: @EqDec A eq eq_equivalence) : EqDec_eq A.
Proof. trivial. Defined.

(*
Existing Class EqDec_eq.
Existing Instance EqDec_eq_of_EqDec.
*)


Require Export ZArith.
Require Export Uint63.
Require Import List.
Import ListNotations.

Open Scope uint63.

Class Hashable (A : Type) : Type :=
{
  hash : A -> int;
}.

#[export] Instance Hashable_Empty_set : Hashable Empty_set :=
{
  hash e := match e with end;
}.

#[export] Instance Hashable_unit : Hashable unit :=
{
  hash _ := 147852369;
}.

#[export] Instance Hashable_bool : Hashable bool :=
{
  hash b := if b then 789654123 else 123654789;
}.

#[export] Instance Hashable_int : Hashable int :=
{
  hash i := i;
}.

#[export] Instance Hashable_nat : Hashable nat :=
{
  hash n := Uint63.of_Z (Z.of_nat n);
}.

#[export] Instance Hashable_sum
  {A B : Type} `{Hashable A} `{Hashable B} : Hashable (A + B) :=
{
  hash x :=
    match x with
    | inl a => add (mul 123456789 (hash a)) 987654321
    | inr b => add (mul 987654321 (hash b)) 123456789
    end;
}.

#[export] Instance Hashable_prod
  {A B : Type} `{Hashable A} `{Hashable B} : Hashable (A * B) :=
{
  hash '(a, b) :=
    let x := hash a in
    let y := hash b in
      div (add (mul x x) (add (mul 3 x) (add (mul 2 (mul x y)) (add y (mul y y))))) 2
}.

Fixpoint hash_list {A : Type} `{Hashable A} (l : list A) : int :=
match l with
| [] => hash tt
| h :: t => hash (hash h, hash_list t)
end.

#[export] Instance Hashable_list (A : Type) `{Hashable A} : Hashable (list A) :=
{
  hash := hash_list;
}.

Compute hash (inl false).
Compute hash (inl true).
Compute hash (inr false).
Compute hash (inr true).

Compute hash (inl (inl false)).
Compute hash (inl (inr false)).
Compute hash (inr (inl false)).
Compute hash (inr (inr false)).

Compute hash (true, false).
Compute hash (false, true).
Compute hash (true, true).
Compute hash (false, false).

Compute hash [true; false; true].


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