Set Implicit Arguments.
Require Import List Lia Program.Program.
From Undecidability.HOU Require Import std.std axioms.
Require Import RelationClasses Morphisms Init.Wf Init.Nat Setoid.
From Undecidability.HOU Require Import calculus.calculus second_order.goldfarb.encoding.
Require Import FinFun Coq.Arith.Wf_nat.
Import ListNotations.

Set Default Proof Using "Type".

Section Multiplication.

  Variable (n: nat).
  Implicit Type (X Y: list (nat * nat)).

  Lemma Cons_subst sigma s t:
    sigma • (s ::: t) = (sigma • s) ::: (sigma • t).
  Proof. reflexivity. Qed.
  Hint Rewrite Cons_subst : asimpl.

  Lemma Cons_injective s s' u u': s ::: u = s' ::: u' -> s = s' /\ u = u'.
  Proof. injection 1; eauto. Qed.

  Lemma Pair_subst sigma s t: sigma • ⟨s, t⟩ = ⟨sigma • s, sigma • t⟩.
  Proof. reflexivity. Qed.
  Hint Rewrite Pair_subst : asimpl.

  Lemma Pair_injective s s' u u': ⟨s, u⟩ = ⟨s', u'⟩ -> s = s' /\ u = u'.
  Proof. injection 1; eauto. Qed.

  Notation r := (var 2).
  Notation A := (var 1).
  Notation B := (var 0).

  Let σ p q :=  B .: A .: ⟨enc p A, enc q B⟩ ::: Nil .: (add 2) >> var.
  Let τ :=  Succ B .: enc n A .: Nil .:((add 2) >> var).

  Definition t k := ⟨enc (k * n) A, enc k B⟩.
  Definition T k := lambda lambda lambda lin (tab t k) r.

  Lemma T_subst m sigma: sigma • (T m) = T m.
  Proof.
    unfold T; cbn; asimpl. rewrite !map_id_list; eauto.
    rewrite tab_map_nats.
    intros; mapinj. unfold t; cbn; now asimpl.
  Qed.

  Lemma T_ren m delta: ren delta (T m) = T m.
  Proof.
    asimpl; now rewrite T_subst.
  Qed.

  Hint Rewrite T_subst T_ren : asimpl.

  Section G_subst.
  Lemma G_left_subst m p q: (T m) (⟨ enc p A, enc q B⟩ ::: Nil) A B ≡ σ p q • (lin (tab t m) r).
  Proof.
    rewrite <-T_ren with (delta := add 2).
    unfold T. eapply equiv_join.
    cbn. do 3 (dostep; cbn). unfold beta. rewrite rinstInst_exp, !compComp_exp. reflexivity.
    eapply refl_star. eapply ext_exp.
    intros [|[|[]]]; cbn; eauto. now asimpl.
  Qed.

  Lemma G_right_subst m: (T m) Nil (enc n A) (Succ B) ≡ τ • lin (tab t m) r.
  Proof.
    rewrite <-T_ren with (delta := add 2).
    unfold T. eapply equiv_join.
    cbn. do 3 (dostep; cbn). unfold beta. rewrite rinstInst_exp, !compComp_exp. reflexivity.
    eapply refl_star. eapply ext_exp.
    intros [|[|[]]]; cbn; eauto. now asimpl.
  Qed.
  End G_subst.

  Section t_subst.
  Lemma hat_t_sigma p q k: σ p q • t k = t k.
  Proof. cbn; now asimpl. Qed.

  Lemma hat_t_tau k: τ • t k = t (S k).
  Proof.
    cbn; asimpl; cbn; simplify.
    rewrite <-!enc_app.
    now replace (k * n + n) with (n + k * n) by lia.
  Qed.
  End t_subst.
  Hint Rewrite hat_t_sigma hat_t_tau : asimpl.

  Section G_reduce.
  Lemma G_left_reduce m p q:
    (T m) (⟨ enc p A, enc q B⟩ ::: Nil) A B ≡ lin (tab t m) (⟨ enc p A, enc q B⟩ ::: Nil).
  Proof.
    rewrite G_left_subst. asimpl. rewrite map_id_list; eauto.
   rewrite tab_map_nats.
   intros; mapinj. unfold t; cbn; now asimpl.
  Qed.

  Lemma G_right_reduce m:
    (T m) Nil (enc n A) (Succ B) ≡ lin (tab (S >> t) m) Nil.
  Proof.
    rewrite G_right_subst. asimpl. eapply eq_equiv. f_equal.
    rewrite tab_map. eapply tab_ext.
    intros ?; unfold funcomp, t; cbn; asimpl. unfold Pair, τ; cbn.
    f_equal. f_equal. rewrite <-enc_app. f_equal; lia.
    now simplify.
  Qed.
  End G_reduce.

  Definition Grel m p G :=
    lambda lambda (ren (add 2) G) (⟨ enc p A, enc m B⟩ ::: Nil) A B ≡
    lambda lambda ⟨ A, B ⟩ ::: (ren (add 2) G) Nil (enc n A) (Succ B).

  Lemma G_forward m: Grel m (m * n) (T m).
  Proof.
    unfold Grel. asimpl. do 2 eapply equiv_lam_proper.
    unfold Cons at 2. rewrite G_left_reduce, G_right_reduce.
    rewrite <-lin_cons. change (⟨ A, B ⟩) with (t 0). rewrite <-tab_S.
    change (_ ::: _) with (lin [t m] Nil). now rewrite <-lin_app.
  Qed.

  Lemma multiplication_lambdas M m p:
    normal M -> Grel m p M -> (exists M', M = (lambda lambda lambda M') /\ σ p m • M' =  t 0 ::: (τ • M')).
  Proof.
    unfold  Grel, Pair, Cons. cbn. intros Nu EQ.
    remember (fun m : nat => S (S m)) as delta. rename M into u.
    assert (normal (ren delta u)) as N' by (subst; eapply normal_ren; eauto).
    do 2 apply equiv_lam_elim in EQ.
    destruct u as [| | u' | ]; unfold funcomp; cbn in EQ.
    4: eapply head_atom in N'; eauto.
    1, 2, 4: Injection EQ; Injection H; Discriminate.
    rewrite stepBeta in EQ; eauto.  asimpl in EQ.
    rewrite stepBeta in EQ; eauto.  asimpl in EQ.
    destruct u' as  [[]| | u' | ]; cbn in EQ.
    1 - 3: Injection EQ; Injection H; Discriminate.
    - do 2 (rewrite stepBeta in EQ; eauto; asimpl in EQ; cbn in EQ).
      destruct u' as [[|[]] | | u' | u1 u2 ]; cbn in EQ.
      1 - 4: Injection EQ; unfold funcomp in *; Discriminate.
      + exists u'. intuition. do 2 (rewrite stepBeta in EQ; eauto; asimpl in EQ; cbn in EQ).
        repeat eapply normal_lam_elim in Nu.
        eapply equiv_unique_normal_forms; [eauto | eauto |idtac..]. subst delta; exact EQ.
        2: eapply normal_app_intro; cbn; intuition.
        2: repeat eapply normal_app_intro; eauto.
        all: eapply normal_subst; try eassumption.
        all: intros [|[|[]]]; cbn; eauto 2.
        all: unfold funcomp, Nil; (repeat eapply normal_app_intro); eauto 2.
        destruct n; simplify; eauto.
      + exfalso. repeat eapply normal_lam_elim in Nu.
        eapply head_atom in Nu as H'; eauto.
        eapply atom_head_lifting
          with (sigma := A .: g (g (enc p A) (enc m B)) (id Nil) .: delta >> var) in H' as H4.
        2: intros [|[]]; cbn; eauto.
        cbn in H4. Injection EQ. Injection H.
        destruct u1 as [[|[]]|[]| |]; cbn in H1; try Injection EQ; try Discriminate.
    - eapply normal_lam_elim in Nu.
      eapply head_atom in Nu; eauto.
      eapply atom_head_lifting with (sigma := g (g (enc p A) (enc m B)) Nil .: delta >> var) in Nu; cbn in Nu.
      2: intros []; cbn; eauto.
      Injection EQ. Injection H. Discriminate.
  Qed.

  Section InvertSubstitution.

    Variable (p q: nat).

    Lemma subst_var_a s':
      σ p q • s' = A -> s' = A.
    Proof.
      intros H4. destruct s'; try discriminate. cbn in H4.
      destruct f as [|[|[]]]; cbn in H4; try discriminate; eauto.
    Qed.

    Lemma subst_var_b s':
      σ p q • s' = B -> s' = B.
    Proof.
      intros H4. destruct s'; try discriminate. cbn in H4.
      destruct f as [|[|[]]]; cbn in H4; try discriminate; eauto.
    Qed.

    Lemma subst_enc k e u:
      σ p q • e = enc k u -> exists e', e = enc k e' /\ σ p q  • e' = u.
    Proof using τ n.
      induction k in e |-*; cbn.
      - intros; eexists; intuition; eauto.
      - intros. simplify in *.
        destruct e as [ [| [| []]] | | | e1 e3 ]; try discriminate.
        destruct e1 as [ [| [| []]] | | | e1 e2 ]; try discriminate.
        destruct e1 as [ [| [| []]] | [] | | ]; try discriminate.
        destruct e2 as [ [| [| []]] | [[]|] | | ]; try discriminate.
        simplify in H.
        injection H as H.
        destruct (IHk _ H) as [e']; intuition; subst.
        exists e'. simplify. intuition.
    Qed.

    Lemma subst_t e k:
      σ p q • e = t k -> e = t k.
    Proof.
      unfold t; intros.
      destruct e as [ [| [| []]] | | | e1 e3 ] ; try discriminate.
      { cbn in *. asimpl in H. cbn in *.
        injection H as ?. destruct k; discriminate. }
      destruct e1 as [ [| [| []]] | | | e1 e2 ]; try discriminate.
      destruct e1 as [ [| [| []]] | [] | | ]; try discriminate.
      cbn -[add] in *. f_equal; injection H as H H'.
      asimpl in H. asimpl in H'. cbn in H, H'. unfold funcomp in H, H'.
      eapply subst_enc in H as [? []]; eauto.
      eapply subst_enc in H' as [? []]; eauto. subst.
      eapply subst_var_a in H0. eapply subst_var_b in H2.
      now subst.
    Qed.

  End InvertSubstitution.

  Section RecoverStructure.

    Lemma step_u u p q k:
      σ p q • u = t k ::: (τ • u) ->
      u = r \/ (exists u', u = t k ::: u').
    Proof.
      intros EQ. destruct u as [| | | t1 t3]; try discriminate; eauto.
      - cbn in *. asimpl in EQ.
        destruct f as [|[|[]]]; try discriminate. now left.
      - destruct t1 as [[|[|[]]]| | | t1 t2]; cbn in *; try discriminate; eauto.
        destruct t1 as [[|[|[]]]| [] | |]; cbn in *; try discriminate; eauto.
        injection EQ as EQ1 EQ2. intros. asimpl in EQ1.
        eapply subst_t in EQ1; subst; eauto.
        right. now (exists t3).
    Qed.

    Fixpoint size_exp {Z} (s: exp Z) :=
      match s with
      | var _ => 0
      | const c => 0
      | app s t => S (size_exp s + size_exp t)
      | lambda s => S (size_exp s)
      end.

    Lemma steps_u u p q k:
      σ p q • u = t k ::: (τ • u) ->
      exists l, u = lin (tab (fun i => t (i + k)) l) r.
    Proof.
      specialize (well_founded_ind (measure_wf lt_wf (@size_exp ag))) as ind.
      revert k. induction u as [u IH] using ind; intros k EQ.
      destruct (step_u _ _ _ EQ) as [H1|H1].
      - subst. exists 0. reflexivity.
      - destruct H1 as [u' H1]. rewrite H1 in EQ.
        rewrite !Cons_subst in EQ. asimpl in EQ.
        eapply Cons_injective in EQ as [_ EQ].
        eapply IH in EQ as [l]; [|subst u; hnf; cbn; lia].
        exists (S l). rewrite tab_S, H1, H.
        simplify. unfold Cons. f_equal. f_equal. rewrite !tab_map_nats. eapply map_ext.
        intros. f_equal; lia.
    Qed.

  End RecoverStructure.

  Lemma G_backward_exists m p M: normal M -> Grel m p M -> exists l, M = T l.
  Proof.
    intros N [M' [-> [l ->] % steps_u]] % multiplication_lambdas; eauto.
    exists l; erewrite tab_ext; now eauto.
  Qed.

  Lemma G_backward_equations m p l: Grel m p (T l) -> m = l /\ m * n = p.
  Proof.
    unfold Grel. rewrite <-G_forward.
    rewrite !T_ren. rewrite !G_left_reduce.
    intros H % equiv_lam_elim % equiv_lam_elim.
    eapply equiv_unique_normal_forms in H; [|eauto| |].
    eapply lin_injective in H as [_ H]; eauto.
    eapply Cons_injective in H as [[H1 H2] % Pair_injective _].
    eapply eq_equiv, enc_injective in H1; eauto.
    eapply eq_equiv, enc_injective in H2; eauto.
    intuition; subst; lia.
    all:  eapply lin_normal.
    1, 3: rewrite tab_map_nats; intros; mapinj; unfold t; cbn.
    all: repeat eapply normal_app_intro; eauto.
  Qed.

  Lemma G_iff m p G: normal G -> ((m * n = p /\ G = T m) <-> Grel m p G).
  Proof.
    intros N. split.
    - intros [<- ->]. apply G_forward.
    - intros H. specialize (G_backward_exists N H) as [l ->].
      eapply G_backward_equations in H; intuition.
  Qed.

End Multiplication.


(*
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     Structures.OrderedType
     Structures.OrderedTypeEx
.

From SPICY Require Import
     MyPrelude
     Tactics
     Maps.

Inductive channel_id :=
| Single (n : nat)
| Intersection (ch1 ch2 : nat)
.

Module ChannelType <: UsualOrderedType.

  (* Module Import Nat_as_OT. *)

  Definition t := channel_id.

  Definition eq := @eq t.

  Definition lt ch1 ch2 : Prop :=
    match (ch1, ch2) with
    | (Single n, Single n') => n < n'
    | (Intersection _ _, Single _) => True
    | (Intersection n1 n2, Intersection n1' n2') => (n1 = n1' /\ n2 < n2') \/ n1 < n1'
    | (Single _, Intersection _ _) => False
    end.

  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Lemma lt_trans :
    forall x y z, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros; destruct x, y, z; try Nat.order; try propositional;
      [> left; split | right | right | right ]; Nat.order.
  Qed.

  Lemma lt_not_eq :
    forall x y, lt x y -> ~ eq x y.
  Proof.
    intros * H; destruct x, y; unfold lt in H; unfold not, eq;
      intro EQ; invert EQ; split_ors; subst; try Nat.order.
  Qed.

  Lemma compare :
    forall( x y : t), Compare lt eq x y.
  Proof.
    intros.
    destruct x, y.
    case_eq (Nat.compare n n0); intro.
    apply EQ; unfold eq; f_equal; now apply nat_compare_eq.
    apply LT; unfold lt; now apply nat_compare_lt.
    apply GT; unfold lt; now apply nat_compare_gt.
    apply GT; unfold lt; eauto.
    apply LT; unfold lt; eauto.
    case_eq (Nat.compare ch1 ch0).
    case_eq (Nat.compare ch2 ch3); intros.
    apply EQ. unfold eq; f_equal; now apply nat_compare_eq.
    apply LT; unfold lt; f_equal; left.
    split; [ now apply nat_compare_eq
           | now apply nat_compare_lt].
    apply GT; unfold lt; left. split. apply Nat.eq_sym. now apply nat_compare_eq. now apply nat_compare_gt.

    intros; apply LT. unfold lt. right. now apply nat_compare_lt.
    intros; apply GT. unfold lt. right. now apply nat_compare_gt.
  Defined.

  Lemma eq_dec :
    forall x y, { eq x y } + { ~ eq x y }.
  Proof.
    unfold eq; destruct x, y.
    - destruct (eq_dec n n0); subst; eauto.
      right; intros H; invert H; contradiction.
    - right; unfold not; intros; discriminate.
    - right; unfold not; intros; discriminate.

    - cases (ch1 ==n ch0); cases (ch2 ==n ch3); cases (ch1 ==n ch3); cases (ch2 ==n ch0); subst;
        eauto; right; unfold not; intros H; invert H; contradiction.
  Qed.

End ChannelType.

Definition combine (ch1 ch2 : channel_id) :=
  match (ch1, ch2) with
  | (Single n, Single n') => if n <? n'
                            then Some (Intersection n' n)
                            else Some (Intersection n n')
  | _ => None
  end.

Module Import ChMap := MyOrderedMap( ChannelType ).

Module ChNotation.
  Notation "# x" := (Single x) (at level 50, left associativity).
  Notation "x #& y" := (Intersection x y) (at level 50, left associativity).
End ChNotation.

Export ChNotation.

Module ChMapNotation.
  Notation "#0" := (empty _).
  Notation "m #+ ( k , v )" := (add k v m) (at level 50, left associativity).
  Notation "m #- k" := (remove k m) (at level 50, left associativity).
  Notation "m #? k" := (find k m) (at level 50, left associativity).
End ChMapNotation.

Export ChMapNotation.

Ltac m_equal :=
  repeat match goal with
         | [ |- context[_ #+ (?k,_) #? ?k ] ]  =>
           rewrite add_eq_o by (simple apply @eq_refl)
         | [ |- context[_ #+ (?k',_) #? ?k] ] =>
           rewrite add_neq_o by ( (unfold not; intros ?SIMPLEQ; invert SIMPLEQ) || intuition idtac )
         | [ |- (_ #+ (_,_)) = _ ] => unfold Map.add, Map.Raw.add; simpl
         | [ |- {| Map.this := _ ; Map.sorted := _ |} = _ ] => eapply map_eq_fields_eq
         | [ H : Map.Empty ?m |- #0 = ?m ] => eapply Empty_eq_empty; exact H
         | [ H : Map.Empty ?m |- ?m = #0 ] => symmetry
         | [ |- Map.empty _ = _ ] => unfold Map.empty, Map.Raw.empty, remove, Map.Raw.remove; simpl
         end.

Section ConcreteMaps.

  Definition next_key_nat {V} (m : ChMap.t V) : nat :=
    match O.max_elt m with
    | None => 0
    | Some (Single k, v) => S k
    | Some (k1 #& k2, v) => 0
    end.

  Lemma next_key_not_in :
    forall {V} (m : ChMap.t V) k,
      k = # (next_key_nat m)
      -> m #? k = None.
  Proof.
    unfold next_key_nat; intros.
    cases (O.max_elt m); subst.
    - destruct p; simpl.
      destruct k.
      + cases (m #? (# S n)); eauto.
        exfalso.

        assert (O.Above (# n) (m #- (# n))) by eauto using O.max_elt_Above.
        specialize (H (# S n)).

        assert (In (# S n) (m #- (# n))).
        rewrite in_find_iff; unfold not; intros.
        rewrite remove_neq_o in H0 by eauto using E.lt_not_eq; clean_map_lookups.

        specialize (H H0); simpl in H.
        assert (n < S n) by eauto using Nat.lt_succ_diag_r.
        Nat.order.

      + cases (m #? (# 0)); eauto.
        exfalso.

        assert (O.Above (ch1 #& ch2) (m #- (ch1 #& ch2))) by eauto using O.max_elt_Above.
        specialize (H (# 0)).

        assert (In (# 0) (m #- (ch1 #& ch2))).
        rewrite in_find_iff; unfold not; intros.
        rewrite remove_neq_o in H0 by clean_map_lookups; clean_map_lookups.
        specialize (H H0); simpl in H; contradiction.

    - apply O.max_elt_Empty in Heq.
      apply Empty_eq_empty in Heq; subst.
      apply lookup_empty_none.
  Qed.

End ConcreteMaps.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Export Crypto.Util.FixCoqMistakes.
Import ListNotations.
Local Set Implicit Arguments.
Local Open Scope list_scope.

Module List.
  Lemma filter_Forall_eq A f ls : @Forall A (fun x => f x = true) ls -> filter f ls = ls.
  Proof.
    induction 1; cbn; [ reflexivity | destruct f ]; try congruence.
  Qed.

  Lemma filter_length_le A f ls : List.length (@filter A f ls) <= List.length ls.
  Proof. induction ls; cbn; [ reflexivity | destruct f ]; cbn; auto with arith. Qed.

  Lemma filter_eq_length_eq A f ls : List.length (filter f ls) = List.length ls -> @filter A f ls = ls.
  Proof.
    induction ls; cbn; [ reflexivity | destruct f ]; cbn; intro; try apply f_equal; eauto with arith.
    pose proof (filter_length_le f ls).
    lia.
  Qed.

  Lemma Forall2_filter_same A B P f g lsA lsB
    : @Forall2 A B (fun a b => match f a, g b with
                               | true, true => P a b
                               | false, false => True
                               | true, false | false, true => False
                               end)
              lsA lsB
      -> Forall2 P (filter f lsA) (filter g lsB).
  Proof.
    induction 1; cbn; [ constructor | ].
    destruct f, g; try constructor; auto; try (exfalso; assumption).
  Qed.

  #[export] Instance filter_Proper {A} : Proper (pointwise_relation _ eq ==> eq ==> eq) (@List.filter A).
  Proof.
    cbv [pointwise_relation]; intros f g Hfg ls ls' ?; subst ls'.
    induction ls as [|l ls IHls]; cbn [filter]; rewrite ?IHls, ?Hfg; reflexivity.
  Qed.

  #[export] Instance Proper_filter_eq {A} : Proper ((eq ==> eq) ==> eq ==> eq) (@filter A).
  Proof. repeat intro; subst; apply filter_Proper; repeat intro; eauto. Qed.
End List.

Export (hints) List.


From iris.proofmode Require Import proofmode.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

(** A library defining binary [minimum] and [maximum] functions, together with
their expected specs. These operations come up often when working manipulating
array indices (checking for bounds). *)

Definition minimum : val :=
  λ: "m" "n", if: "m" < "n" then "m" else "n".

Definition maximum : val :=
  λ: "m" "n", if: "m" < "n" then "n" else "m".

Lemma minimum_spec `{!heapGS Σ} s E (Φ : val → iProp Σ) (m n : Z) :
  ▷ Φ #(m `min` n) -∗
  WP minimum #m #n @ s;E {{ Φ }}.
Proof.
  iIntros "HΦ". wp_lam. wp_pures. case_bool_decide; wp_pures.
  - rewrite Z.min_l; [ done | by lia ].
  - rewrite Z.min_r; [ done | by lia ].
Qed.

Lemma minimum_spec_nat `{!heapGS Σ} s E (Φ : val → iProp Σ) (m n : nat) :
  ▷ Φ #(m `min` n)%nat -∗
  WP minimum #m #n @ s;E {{ Φ }}.
Proof. iIntros "HΦ". iApply minimum_spec. by rewrite Nat2Z.inj_min. Qed.

Lemma maximum_spec `{!heapGS Σ} s E (Φ : val → iProp Σ) (m n : Z) :
  ▷ Φ #(m `max` n) -∗
  WP maximum #m #n @ s;E {{ Φ }}.
Proof.
  iIntros "HΦ". wp_lam. wp_pures. case_bool_decide; wp_pures.
  - rewrite Z.max_r; [ done | by lia ].
  - rewrite Z.max_l; [ done | by lia ].
Qed.

Lemma maximum_spec_nat `{!heapGS Σ} s E (Φ : val → iProp Σ) (m n : nat) :
  ▷ Φ #(m `max` n)%nat -∗
  WP maximum #m #n @ s;E {{ Φ }}.
Proof. iIntros "HΦ". iApply maximum_spec. by rewrite Nat2Z.inj_max. Qed.


Require Coq.funind.Recdef.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Require Import msl.Coqlib2.

Lemma power_nat_one_divede_other: forall n m : nat,
  (two_power_nat n | two_power_nat m) \/ (two_power_nat m | two_power_nat n).
Proof.
  intros.
  pose proof Zle_0_nat n.
  pose proof Zle_0_nat m.
  rewrite !two_power_nat_two_p.
  destruct (zle (Z.of_nat n) (Z.of_nat m)).
  + left.
    exists (two_p (Z.of_nat m - Z.of_nat n)).
    rewrite <- two_p_is_exp by omega.
    f_equal.
    omega.
  + right.
    exists (two_p (Z.of_nat n - Z.of_nat m)).
    rewrite <- two_p_is_exp by omega.
    f_equal.
    omega.
Qed.

Lemma multiple_divide_mod: forall a b c, b > 0 -> ((a | b) \/ (b | a)) -> (a | (c * a mod b)).
Proof.
  intros.
  destruct H0.
  + apply Z.divide_add_cancel_r with (b * (c * a / b))%Z.
    apply Z.divide_mul_l; auto.
    rewrite <- Z_div_mod_eq; auto.
    apply Z.divide_mul_r, Z.divide_refl.
  + destruct H0.
    subst.
    rewrite Z.mul_assoc, Z_mod_mult.
    apply Z.divide_0_r.
Qed.

Lemma divide_align: forall x y: Z, x > 0 -> Zdivide x y -> align y x = y.
Proof.
  intros.
  unfold align.
  destruct H0.
  rewrite H0.
  pose proof Zdiv_unique (x0 * x + x - 1) x x0 (x - 1).
  assert (x0 * x + x - 1 = x0 * x + (x - 1)) by omega.
  assert (0 <= x - 1 < x) by omega.
  rewrite (H1 H2 H3).
  reflexivity.
Qed.

Lemma Z2Nat_neg: forall i, i < 0 -> Z.to_nat i = 0%nat.
Proof.
  intros.
  destruct i; try reflexivity.
  pose proof Zgt_pos_0 p; omega.
Qed.

Lemma Int_unsigned_repr_le: forall a, 0 <= a -> Int.unsigned (Int.repr a) <= a.
Proof.
  intros.
  rewrite Int.unsigned_repr_eq.
  apply Z.mod_le; auto.
  cbv.
  auto.
Qed.

Lemma arith_aux00: forall a b, b <= a -> 0%nat = nat_of_Z (a - b) -> a - b = 0.
Proof.
  intros.
  pose proof Z2Nat.id (a - b).
  unfold nat_of_Z in H0.
  rewrite <- H0 in H1.
  simpl Z.of_nat in H1.
  omega.
Qed.

Lemma arith_aux01: forall a b n, S n = nat_of_Z (a - b) -> b < a.
Proof.
  intros.
  destruct (zlt a b); auto.
  + rewrite Z2Nat_neg in H by omega.
    inversion H.
  + pose proof Z2Nat.id (a - b).
    unfold nat_of_Z in H; rewrite <- H in H0.
    spec H0; [omega |].
    rewrite Nat2Z.inj_succ in H0.
    omega.
Qed.

Lemma arith_aux02: forall n a b, S n = nat_of_Z (a - b) -> n = nat_of_Z (a - Z.succ b).
Proof.
  intros.
  pose proof arith_aux01 _ _ _ H.
  unfold nat_of_Z in *.
  pose proof Z2Nat.id (a - b).
  spec H1; [omega |].
  rewrite <- H in H1.
  replace (a - Z.succ b) with (a - b - 1) by omega.
  rewrite <- H1.
  rewrite Nat2Z.inj_succ.
  replace (Z.succ (Z.of_nat n) - 1) with (Z.of_nat n) by omega.
  rewrite Nat2Z.id.
  auto.
Qed.

Lemma arith_aux03: forall a b c,
  0 <= b ->
  0 <= a + b * c ->
  0 <= a + b * Z.succ c.
Proof.
  intros.
  assert (b * c <= b * Z.succ c) by (apply Zmult_le_compat_l; omega).
  omega.
Qed.

Lemma arith_aux04: forall a b c,
  0 <= b <= c ->
  (a | b) ->
  (a | b mod c).
Proof.
  intros.
  destruct (zlt b c).
  + rewrite Zmod_small by omega.
    auto.
  + assert (b = c) by omega.
    subst.
    rewrite Z_mod_same_full.
    apply Z.divide_0_r.
Qed.

Lemma arith_aux05: forall lo hi, 0 <= lo -> 0 <= hi ->
  0 <= Z.max 0 (hi - lo) <= hi.
Proof.
  intros.
  destruct (zle lo hi).
  + rewrite Z.max_r by omega.
    omega.
  + rewrite Z.max_l by omega.
    omega.
Qed.

Lemma arith_aux06: forall lo hi n, 0 <= lo <= n -> 0 <= hi <= n -> 0 <= lo + Z.max 0 (hi - lo) <= n.
Proof.
  intros.
  destruct (zle lo hi).
  + rewrite Z.max_r by omega.
    omega.
  + rewrite Z.max_l by omega.
    omega.
Qed.

Ltac inv_int i :=
  let ofs := fresh "ofs" in
  let H := fresh "H" in
  let H0 := fresh "H" in
  let H1 := fresh "H" in
  pose proof Int.repr_unsigned i as H;
  pose proof Int.unsigned_range i as H0;
  remember (Int.unsigned i) as ofs eqn:H1;
  rewrite <- H in *;
  clear H H1; try clear i.

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

Solve_mod_modulus

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

Definition modm x := x mod Int.modulus.

Lemma modm_mod_eq: forall x y, Int.eqmod Int.modulus x y -> x mod Int.modulus = modm y.
Proof.
  intros.
  apply Int.eqmod_mod_eq; auto.
  apply Int.modulus_pos.
Qed.

Lemma modm_mod_elim: forall x y, Int.eqmod Int.modulus x y -> Int.eqmod Int.modulus (x mod Int.modulus) y.
Proof.
  intros.
  eapply Int.eqmod_trans; eauto.
  apply Int.eqmod_sym, Int.eqmod_mod.
  apply Int.modulus_pos.
Qed.

Definition reprm := Int.repr.

Lemma modm_repr_eq: forall x y, Int.eqmod Int.modulus x y -> Int.repr x = reprm y.
Proof.
  intros.
  apply Int.eqm_samerepr; auto.
Qed.

Ltac simpl_mod A H :=
  let H0 := fresh "H" in
  let H1 := fresh "H" in
  match A with
  | (?B + ?C)%Z =>
    simpl_mod B H0; simpl_mod C H1;
    pose proof Int.eqmod_add Int.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (?B - ?C)%Z =>
    simpl_mod B H0; simpl_mod C H1;
    pose proof Int.eqmod_sub Int.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (?B * ?C)%Z =>
    simpl_mod B H0; simpl_mod C H1;
    pose proof Int.eqmod_mult Int.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (- ?B)%Z =>
    simpl_mod B H0;
    pose proof Int.eqmod_neg Int.modulus _ _ H0 as H;
    clear H0
  | ?B mod Int.modulus =>
    simpl_mod B H0;
    pose proof modm_mod_elim B _ H0 as H;
    clear H0
  | modm ?B =>
    simpl_mod B H0;
    pose proof modm_mod_elim B _ H0 as H;
    clear H0
  | _ =>
    pose proof Int.eqmod_refl Int.modulus A as H
  end.

Ltac solve_mod_modulus :=
  try unfold Int.add; try rewrite !Int.unsigned_repr_eq;
  repeat
  match goal with
  | |- context [?A mod Int.modulus] =>
         let H := fresh "H" in simpl_mod A H;
         rewrite (modm_mod_eq A _ H);
         clear H
  | |- context [Int.repr ?A] =>
         let H := fresh "H" in simpl_mod A H;
         rewrite (modm_repr_eq A _ H);
         clear H
  end;
  try unfold modm in *;
  try unfold reprm in *.

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

List lemmas

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

Lemma add_repr: forall i j, Int.add (Int.repr i) (Int.repr j) = Int.repr (i+j).
Proof. intros.
  rewrite Int.add_unsigned.
 apply Int.eqm_samerepr.
 unfold Int.eqm.
 apply Int.eqm_add; apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
Qed.

Lemma mul_repr:
 forall x y, Int.mul (Int.repr x) (Int.repr y) = Int.repr (x * y).
Proof.
intros. unfold Int.mul.
apply Int.eqm_samerepr.
repeat rewrite Int.unsigned_repr_eq.
apply Int.eqm_mult; unfold Int.eqm; apply Int.eqmod_sym;
apply Int.eqmod_mod; compute; congruence.
Qed.

Lemma sub_repr: forall i j,
  Int.sub (Int.repr i) (Int.repr j) = Int.repr (i-j).
Proof.
  intros.
 unfold Int.sub.
 apply Int.eqm_samerepr.
 unfold Int.eqm.
 apply Int.eqm_sub; apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
Qed.

Lemma Zland_two_p:
 forall i n, (0 <= n)%Z -> Z.land i (Z.ones n) = i mod (2 ^ n).
Proof.
intros.
rewrite Z.land_ones by auto.
reflexivity.
Qed.

Lemma and_repr
     : forall i j : Z, Int.and (Int.repr i) (Int.repr j) = Int.repr (Z.land i j).
Proof.
  intros.
  unfold Int.and.
  rewrite <- (Int.repr_unsigned (Int.repr (Z.land i j))).
  rewrite !Int.unsigned_repr_eq.
  change Int.modulus with (2 ^ 32).
  rewrite <- !Zland_two_p by omega.
  f_equal.
  rewrite <- !Z.land_assoc.
  f_equal.
  rewrite (Z.land_comm (Z.ones 32)).
  rewrite <- !Z.land_assoc.
  f_equal.
Qed.

Lemma or_repr
     : forall i j : Z, Int.or (Int.repr i) (Int.repr j) = Int.repr (Z.lor i j).
Proof.
  intros.
  unfold Int.or.
  rewrite <- (Int.repr_unsigned (Int.repr (Z.lor i j))).
  rewrite !Int.unsigned_repr_eq.
  change Int.modulus with (2 ^ 32).
  rewrite <- !Zland_two_p by omega.
  f_equal.
  rewrite <- Z.land_lor_distr_l.
  reflexivity.
Qed.

Arguments Int.unsigned n : simpl never.
Arguments Pos.to_nat !x / .

Lemma align_0: forall z,
    z > 0 -> align 0 z = 0.
Proof. unfold align; intros. rewrite Zdiv_small; omega.
Qed.
Hint Rewrite align_0 using omega : norm.

Lemma align_1: forall n, align n 1 = n.
Proof.  intros; unfold align. rewrite Z.div_1_r. rewrite Z.mul_1_r. omega.
Qed.
Hint Rewrite align_1 using omega : norm.

Lemma fold_right_andb: forall bl b, fold_right andb b bl = true -> forall b0, In b0 bl -> b0 = true.
Proof.
  intros.
  induction bl.
  + inversion H0.
  + destruct H0.
    - simpl in H.
      rewrite andb_true_iff in H.
      subst; tauto.
    - simpl in H.
      rewrite andb_true_iff in H.
      tauto.
Qed.

Lemma Z2Nat_inj_0: forall z, z >= 0 -> Z.to_nat z = 0%nat -> z = 0.
Proof.
  intros.
  destruct (zlt 0 z).
  + replace z with (1 + (z - 1)) in H0 by omega.
    rewrite Z2Nat.inj_add in H0 by omega.
    change (Z.to_nat 1) with (1%nat) in H0.
    inversion H0.
  + omega.
Qed.

Lemma Z2Nat_id': forall n, Z.of_nat (Z.to_nat n) = Z.max 0 n.
Proof.
intros.
 destruct (zlt n 0).
 rewrite Z2Nat_neg by auto. rewrite Z.max_l by omega; reflexivity.
 rewrite Z2Nat.id, Z.max_r by omega; omega.
Qed.

Lemma nil_or_non_nil: forall {A} (a: list A), {a = nil} + {a <> nil}.
Proof.
  intros.
  destruct a; [left | right]; congruence.
Qed.


Add LoadPath "../metatheory".
Require Export F_soundness.

Lemma eq_typ_dec : forall (τ₁ τ₂: typ), {τ₁ = τ₂} + {τ₁ ≠ τ₂}.
Proof.
decide equality.
apply eq_nat_dec.
Qed.

Lemma in_dom_dec : forall x (Γ: typing_env), {x ∈ dom Γ} + {~x ∈ dom Γ}.
Proof.
intros x Γ. induction Γ; simpl.
auto.
destruct a; destruct IHΓ; auto.
destruct (x == a); subst; auto.
Qed.

Lemma uniq_dec : forall (Γ: typing_env), {uniq Γ} + {~uniq Γ}.
Proof.
intro Γ; induction Γ.
auto.
destruct IHΓ.
  destruct a as [x τ]; destruct (in_dom_dec x Γ); [right | left]; auto.
    intro; solve_uniq.
  right; intro; inversion H; subst; auto.
Qed.

Lemma lc_typ_dec : forall τ, {lc_typ τ} + {~lc_typ τ}.
Proof.
assert (forall n t, size_typ t ≤ n -> {lc_typ t} + {~lc_typ t}) as Th.
intro n; induction n; intros t Hsize; destruct t; simpl in *; try solve [absurdity with omega]; auto.
Case "bound var". right; intro H; inversion H.
Case "arrow".
  destruct (IHn t1).
    omega. destruct (IHn t2). omega. auto.
    right; intro H; inversion H; auto.
    right; intro H; inversion H; auto.
Case "forall".
  assert (forall a, {lc_typ (open_typ_wrt_typ t (typ_var_f a))} + {⌉lc_typ (open_typ_wrt_typ t (typ_var_f a))}) as H.
    intro a; apply IHn; autorewrite with lngen; omega.
  pick fresh a; destruct (H a); [left | right]. eauto using lc_typ_forall_exists.
  intro H0; apply n0; inversion H0; subst; auto.

intro τ; apply (Th (size_typ τ)); auto.
Qed.

Lemma wftyp_forall_exists : forall a Γ τ,
  a ∉ ftv_typ τ →
  wftyp (a ~ None ++ Γ) (open_typ_wrt_typ τ (typ_var_f a)) →
  wftyp Γ (typ_forall τ).
Proof.
intros a Γ τ H H0.
assert (wfenv Γ). assert (wfenv (a~None ++ Γ)) by eauto. inversion H1; subst; auto.
assert (uniq Γ) by auto.
apply wftyp_forall with (L := {{a}} ∪ dom Γ); intros b Hb. assert (b ≠ a) by auto.
replace (open_typ_wrt_typ τ (typ_var_f b)) with (tsubst_typ (typ_var_f b) a (open_typ_wrt_typ τ (typ_var_f a))).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) nil ++ [(b, None)] ++ Γ).
apply wftyp_tsubst; simpl; simpl_env.
apply wftyp_weakening; simpl_env; auto. constructor; auto.
rewrite tsubst_typ_open_typ_wrt_typ; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wftyp_forall_exists_inv : forall a τ Γ,
  a ∉ ftv_typ τ ∪ dom Γ →
  wftyp Γ (typ_forall τ) →
  wftyp (a ~ None ++ Γ) (open_typ_wrt_typ τ (typ_var_f a)).
Proof.
intros a τ Γ Ha H.
inversion H; subst. pick fresh b.
assert (wftyp ([(b, None)] ++ Γ) (open_typ_wrt_typ τ (typ_var_f b))) by auto.
replace (open_typ_wrt_typ τ (typ_var_f a)) with (tsubst_typ (typ_var_f a) b (open_typ_wrt_typ τ (typ_var_f b))).
assert (wfenv ([(a, None)] ++ Γ)). assert (wfenv ([(b, None)] ++ Γ)) by eauto; inversion H1; subst; constructor; auto.
rewrite_env (env_map (tsubst_typ (typ_var_f a) b) nil ++ [(a, None)] ++ Γ).
apply wftyp_tsubst; simpl; simpl_env.
apply wftyp_weakening; auto. constructor; auto.
assert (uniq ([(b, None)] ++ Γ)) as H1 by eauto; inversion H1; subst; auto.
rewrite tsubst_typ_open_typ_wrt_typ; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfenv_wftyp_aux : forall τ Γ, wfenv Γ →
  {wftyp Γ τ} + {~wftyp Γ τ}.
Proof.
intro τ.
destruct (lc_typ_dec τ).
assert (lc_set_typ τ) as H by auto with lngen.
induction H; intros.
Case "var".
destruct (binds_lookup _ a1 Γ).
destruct s; destruct x; [right | left]; auto.
intro H0; inversion H0; subst. assert (uniq Γ) by eauto.
  assert (Some t = None). eapply binds_unique; eauto. congruence.
right. intro H0; inversion H0; subst; apply (n None); auto.
Case "arrow".
edestruct (IHlc_set_typ1); auto with lngen. eauto.
edestruct (IHlc_set_typ2); auto with lngen. eauto.
auto.
right. intro H2; apply n; inversion H2; subst; auto.
right. intro H2; apply n; inversion H2; subst; auto.
Case "forall".
pick fresh a.
assert (lc_typ (open_typ_wrt_typ t1 (typ_var_f a))) as H1. inversion l; subst; auto.
destruct (H a H1 (a~None ++ Γ)); auto.
left. eapply wftyp_forall_exists; eauto.
right. intro H2; apply n; apply wftyp_forall_exists_inv; auto.
Case "not lc".
intros. right. intro H0; apply n; eauto.
Qed.

Lemma wfenv_wftyp_dec : forall Γ,
  ({wfenv Γ} + {~wfenv Γ}) * (forall τ, {wftyp Γ τ} + {~wftyp Γ τ}).
Proof.
intro Γ; induction Γ; simpl_env in *; auto.
Case "wfenv_empty".
split; auto.
intros; apply wfenv_wftyp_aux with (Γ := nil); auto.
destruct a; destruct o; destruct IHΓ as [H1 H2].
Case "wfenv_cons_x".
split.
SCase "first part".
destruct H1 as [H1 | H1]. destruct (in_dom_dec a Γ).
right. intro H; inversion H; subst; contradiction.
destruct (H2 t); auto.
right. intro H; apply n0; inversion H; subst; auto.
right. intro H; apply H1; inversion H; subst; eauto.
SCase "second part".
destruct H1 as [H1 | H1]; intros. destruct (in_dom_dec a Γ).
right. intro H. assert (uniq (a ~ Some t ++ Γ)) by eauto.
  destruct_uniq. contradiction.
destruct (H2 t); auto.
apply (wfenv_wftyp_aux τ (a ~ Some t ++ Γ)); auto.
right. intro H; apply n0; assert (wfenv (a ~ Some t ++ Γ)) as H3 by eauto; inversion H3; subst; auto.
right. intro H; apply H1. assert (wfenv (a ~ Some t ++ Γ)) as H3 by eauto; inversion H3; subst; eauto.
Case "wfenv_cons_a".
split.
SCase "first part".
destruct H1 as [H1 | H1]. destruct (in_dom_dec a Γ); auto.
right. intro H; inversion H; subst; contradiction.
right. intro H; apply H1; inversion H; subst; eauto.
SCase "second part".
destruct H1 as [H1 | H1]; intros. destruct (in_dom_dec a Γ).
right. intro H. assert (uniq (a ~ None ++ Γ)) by eauto.
  destruct_uniq. contradiction.
apply (wfenv_wftyp_aux τ (a ~ None ++ Γ)); auto.
right. intro H; apply H1; assert (wfenv (a ~ None ++ Γ)) as H3 by eauto; inversion H3; subst; auto.
Qed.

Lemma wftyp_dec : forall Γ τ, {wftyp Γ τ} + {~wftyp Γ τ}.
Proof.
intros Γ τ. destruct (wfenv_wftyp_dec Γ); auto.
Qed.

Lemma wfenv_dec : forall Γ, {wfenv Γ} + {~wfenv Γ}.
Proof.
intros Γ. destruct (wfenv_wftyp_dec Γ); auto.
Qed.

Lemma lc_term_dec : forall t, {lc_term t} + {~lc_term t}.
Proof.
assert (forall n t, size_term t ≤ n -> {lc_term t} + {~lc_term t}) as Th.
intro n; induction n; intros t Hsize; destruct t; simpl in *; try solve [absurdity with omega]; auto.
Case "bound var". right; intro H; inversion H.
Case "abs".
  assert (forall x, {lc_term (t0 ^ x)} + {⌉lc_term (t0 ^ x)}) as H.
    intro x; apply IHn; autorewrite with lngen; omega.
  destruct (lc_typ_dec t).
  pick fresh x; destruct (H x); [left | right]. eauto using lc_term_abs_exists.
  intro H0; apply n0; inversion H0; subst; auto.
  right. intro H0; apply n0; inversion H0; subst; auto.
Case "app".
  destruct (IHn t1).
    omega. destruct (IHn t2). omega. auto.
    right; intro H; inversion H; auto.
    right; intro H; inversion H; auto.
Case "gen".
  assert (forall a, {lc_term (open_term_wrt_typ t (typ_var_f a))} + {⌉lc_term (open_term_wrt_typ t (typ_var_f a))}) as H.
    intro a; apply IHn; autorewrite with lngen; omega.
  pick fresh x; destruct (H x); [left | right]. eauto using lc_term_gen_exists.
  intro H0; apply n0; inversion H0; subst; auto.
Case "inst".
  destruct (lc_typ_dec t0). destruct (IHn t).
    omega. auto.
  right. intro H0; apply n0; inversion H0; subst; auto.
  right. intro H0; apply n0; inversion H0; subst; auto.

intro t; apply (Th (size_term t)); auto.
Qed.

Lemma wfterm_abs_exists : forall x τ Γ e τ',
  x ∉ fv_term e →
  wfterm (x ~ Some τ ++ Γ) (e ^ x) τ' → wfterm Γ (term_abs τ e) (typ_arrow τ τ').
Proof.
intros x τ Γ e τ' Hx H.
assert (uniq Γ). assert (uniq ([(x, Some τ)] ++ Γ)) as H1 by eauto. inversion H1; auto.
apply wfterm_abs with (L := {{x}} ∪ dom Γ); intros y Hy. assert (y ≠ x) by auto.
replace (e ^ y) with (subst_term (term_var_f y) x (e ^ x)).
apply wfterm_subst with (τ₂ := τ) (Γ₁ := nil); simpl; simpl_env.
apply wfterm_weakening; simpl_env; auto. constructor; eauto.
constructor; auto. constructor; eauto.
rewrite subst_term_open_term_wrt_term; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfterm_gen_exists : forall a τ Γ e,
  a ∉ ftv_term e ∪ ftv_typ τ →
  wfterm (a ~ None ++ Γ) (open_term_wrt_typ e (typ_var_f a)) (open_typ_wrt_typ τ (typ_var_f a)) →
  wfterm Γ (term_gen e) (typ_forall τ).
Proof.
intros a τ Γ e Ha H.
assert (uniq Γ). assert (uniq ([(a, None)] ++ Γ)) as H1 by eauto. inversion H1; auto.
apply wfterm_gen with (L := {{a}} ∪ dom Γ); intros b Hb. assert (b ≠ a) by auto.
replace (open_term_wrt_typ e (typ_var_f b)) with (tsubst_term (typ_var_f b) a (open_term_wrt_typ e (typ_var_f a))).
replace (open_typ_wrt_typ τ (typ_var_f b)) with (tsubst_typ (typ_var_f b) a (open_typ_wrt_typ τ (typ_var_f a))).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) nil ++ b ~ None ++ Γ).
assert (wfenv ([(b, None)] ++ Γ)). constructor; auto.
assert (wfenv (a ~ None ++ Γ)) by eauto; inversion H2; subst; auto.
apply wfterm_tsubst; simpl; simpl_env.
apply wfterm_weakening; simpl_env; auto. constructor; auto.
rewrite tsubst_typ_open_typ_wrt_typ; auto.
autorewrite with lngen. reflexivity.
rewrite tsubst_term_open_term_wrt_typ; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfterm_abs_exists_inv : forall x τ Γ e τ',
  x ∉ fv_term e ∪ dom Γ →
  wfterm Γ (term_abs τ e) (typ_arrow τ τ') →
  wfterm (x ~ Some τ ++ Γ) (e ^ x) τ'.
Proof.
intros x τ Γ e τ' Hx H.
inversion H; subst. pick fresh y.
assert (wfterm ([(y, Some τ)] ++ Γ) (e ^ y) τ') by auto.
replace (e ^ x) with (subst_term (term_var_f x) y (e ^ y)).
assert (wfenv ([(x, Some τ)] ++ Γ)). assert (wfenv ([(y, Some τ)] ++ Γ)) by eauto; inversion H1; subst; constructor; auto.
apply wfterm_subst with (τ₂ := τ) (Γ₁ := nil); simpl; simpl_env.
apply wfterm_weakening; auto. constructor; auto.
assert (uniq ([(y, Some τ)] ++ Γ)) as H1 by eauto; inversion H1; subst; auto.
rewrite subst_term_open_term_wrt_term; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfterm_gen_exists_inv : forall a τ Γ e,
  a ∉ fv_term e ∪ ftv_typ τ ∪ dom Γ →
  wfterm Γ (term_gen e) (typ_forall τ) →
  wfterm (a ~ None ++ Γ) (open_term_wrt_typ e (typ_var_f a)) (open_typ_wrt_typ τ (typ_var_f a)).
Proof.
intros a τ Γ e Ha H.
inversion H; subst. pick fresh b.
assert (wfterm ([(b, None)] ++ Γ) (open_term_wrt_typ e (typ_var_f b)) (open_typ_wrt_typ τ (typ_var_f b))) by auto.
replace (open_term_wrt_typ e (typ_var_f a)) with (tsubst_term (typ_var_f a) b (open_term_wrt_typ e (typ_var_f b))).
replace (open_typ_wrt_typ τ (typ_var_f a)) with (tsubst_typ (typ_var_f a) b (open_typ_wrt_typ τ (typ_var_f b))).
assert (wfenv ([(a, None)] ++ Γ)). assert (wfenv ([(b, None)] ++ Γ)) by eauto; inversion H1; subst; constructor; auto.
rewrite_env (env_map (tsubst_typ (typ_var_f a) b) nil ++ [(a, None)] ++ Γ).
apply wfterm_tsubst; simpl; simpl_env.
apply wfterm_weakening; auto. constructor; auto.
assert (uniq ([(b, None)] ++ Γ)) as H1 by eauto; inversion H1; subst; auto.
rewrite tsubst_typ_open_typ_wrt_typ; auto.
autorewrite with lngen. reflexivity.
rewrite tsubst_term_open_term_wrt_typ; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfterm_dec : forall Γ e,
  {τ | wfterm Γ e τ} + {forall τ, ~wfterm Γ e τ}.
Proof.
intros Γ e.
destruct (wfenv_dec Γ); eauto.
destruct (lc_term_dec e) as [H | H]; eauto.
assert (lc_set_term e) as H' by auto with lngen; clear H.
generalize dependent Γ. induction H'; intros.
Case "var". destruct (binds_lookup _ x1 Γ) as [[o H] | H].
  destruct o; eauto. right. intros τ H0; inversion H0; subst.
  assert (uniq Γ) by eauto. assert (Some τ = None). eapply binds_unique; eauto. congruence.
  right; intros τ H0; inversion H0; subst; eapply H; eauto.
Case "abs".
destruct (wftyp_dec Γ t1).
pick fresh x.
edestruct (H x (x ~ Some t1 ++ Γ)) as [[τ H1] | H1]; auto.
left; eauto using wfterm_abs_exists.
right; intros τ H0; inversion H0; subst; eapply H1; eauto using wfterm_abs_exists_inv.
right; intros τ H0; inversion H0; subst; eapply n; inversion H0; subst; pick fresh y; eauto.
Case "app".
edestruct (IHH'1 Γ) as [[τ₁ H1] | H1]; auto.
SCase "wfterm e1".
destruct τ₁.
SSCase "bound var".
assert (lc_typ (typ_var_b n)) as H by eauto; assert False by inversion H; contradiction.
SSCase "free var".
right; intros τ H; inversion H; subst;
  assert (typ_var_f t = typ_arrow t2 τ) by eauto using wfterm_uniqueness;
    congruence.
SSCase "typ_arrow".
edestruct (IHH'2 Γ) as [[τ₂ H2] | H2]; auto.
SSSCase "wfterm e2".
destruct (eq_typ_dec τ₁1 τ₂); subst.
SSSSCase "τ₁1 = τ₂". eauto.
SSSSCase "τ₁1 ≠ τ₂". right. intros τ H. inversion H; subst.
assert (typ_arrow τ₁1 τ₁2 = typ_arrow t2 τ) by eauto using wfterm_uniqueness.
assert (τ₂ = t2) by eauto using wfterm_uniqueness.
congruence.
SSSCase "~ wfterm e2".
right; intros τ H; inversion H; subst; eapply H2; eauto.
SSCase "forall".
right; intros τ H; inversion H; subst;
  assert (typ_forall τ₁ = typ_arrow t2 τ) by eauto using wfterm_uniqueness;
    congruence.
SCase "~ wfterm e1".
right; intros τ H; inversion H; subst; eapply H1; eauto.
Case "gen".
pick fresh a.
edestruct (H a (a ~ None ++ Γ)) as [[τ H1] | H1]; auto.
left. exists (typ_forall (close_typ_wrt_typ a τ)).
  apply wfterm_gen_exists with (a := a).
  autorewrite with lngen; auto.
  autorewrite with lngen; auto.
right. intros τ H0. inversion H0; subst.
  apply (H1 (open_typ_wrt_typ t (typ_var_f a))).
  apply wfterm_gen_exists_inv; auto.
  assert (a ∉ ftv_typ (typ_forall t)). assert (ftv_typ (typ_forall t) [<=] dom Γ) by eauto; auto. auto.
Case "inst".
destruct (wftyp_dec Γ t1).
SCase "wftyp t1".
edestruct (IHH' Γ) as [[τ H1] | H1]; auto.
SSCase "wfterm e1".
destruct τ.
SSSCase "bound var".
assert (lc_typ (typ_var_b n)) as H by eauto; assert False by inversion H; contradiction.
SSSCase "free var".
right; intros τ H; inversion H; subst;
  assert (typ_var_f t = typ_forall t') by eauto using wfterm_uniqueness;
    congruence.
SSSCase "typ_arrow".
right; intros τ H; inversion H; subst;
  assert (typ_arrow τ1 τ2 = typ_forall t') by eauto using wfterm_uniqueness;
    congruence.
SSSCase "typ_forall".
eauto.
SSCase "~ wfterm e1".
right; intros τ H; inversion H; subst; eapply H1; eauto.
SCase "~wftyp t1".
right; intros τ H; inversion H; subst; eapply n; eauto.
Qed.


Require Import Coq.Arith.PeanoNat.

Require Import FunInd.
Fixpoint pow base exp :=
  match exp with
  | 0 => 1
  | S exp' => base * pow base exp'
  end.

Fixpoint my_append (l: list nat) (r: list nat) :=
  match l with
  | nil => r
  | cons x l' =>
    cons x (my_append l' r)
  end.

From Hammer Require Import Hammer.

Variable (pow_uninterp: nat -> nat -> nat).

Variable (pow_uninterp_corr: forall n m, pow_uninterp n m = pow n m).

Fixpoint ple_eval (m: nat) (n: nat) : Prop :=
  match n with
  | 0 => pow_uninterp m 0 = 1
  | S n' => pow_uninterp m (S n') = m * pow_uninterp m n' /\ ple_eval m n'
  end.

Lemma ple_eval_corr :
  forall m n,
    ple_eval m n.
Proof.
  induction n.
  - simpl.
    erewrite pow_uninterp_corr.
    trivial.
  - simpl.
    split; trivial.
    repeat erewrite pow_uninterp_corr.
    trivial.
Qed.

Lemma pow_1_7:
  pow 1 7 = 1.
Proof.
  erewrite <- pow_uninterp_corr.
  assert (ple_eval 1 7) by eapply ple_eval_corr.
  unfold ple_eval in H.
Abort.

Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.
Import HListNotations.
Require Import MirrorSolve.SMT.
Require Import MirrorSolve.BV.

Local Declare ML Module "mirrorsolve".

Require Import MirrorSolve.N.
Require Import MirrorSolve.Z.
Require Import MirrorSolve.N2Z.

RegisterSMTSort ZS SInt.
(* RegisterSMTSort BS SBool. *)
RegisterCustomSort BS "BS".

RegisterSMTUF "pow" ZS ZS BS.

RegisterSMTBuiltin Z.ZLit IntLit.

Require Import MirrorSolve.Reflection.Core.
Require Import MirrorSolve.Reflection.FM.
Require Import MirrorSolve.Reflection.Tactics.

Definition is_z_term (t: term) : bool :=
  match t with
  | tApp c _ =>
    orb (eq_term c c_zpos) (eq_term c c_zneg)
  | _ => eq_term t c_zzero
  end.

Definition is_nat_term (t: term) : bool :=
  match t with
  | tApp f _ =>
    eq_term f c_nsucc
  | _ => eq_term t c_nzero
  end.

Require Import Coq.ZArith.BinIntDef.

Require Import Coq.Lists.List.

Require Import Coq.Strings.String.
Require Import MirrorSolve.UF.
Import ListNotations.

Notation sig := (N.sig).

Definition symbs : list (string * list (sig_sorts sig) * sig_sorts sig) := ([
  ("pow", [NS; NS], NS)
]%string).

Lemma symbs_contents :
  forall s args r,
    In (s, args, r) symbs <->
    s = "pow"%string /\ args = [NS; NS] /\ r = NS.
Proof.
  intros.
  unfold symbs.
  split; intros.
  - inversion H; subst.
    + inversion H0; subst.
      repeat econstructor.
    + inversion H0.
  - destruct H as [? [? ?]]; subst.
    left; econstructor.
Defined.

Definition interp_syms (sym: string) (a: list (sig_sorts sig)) (r: sig_sorts sig) :
  In (sym, a, r) symbs -> HList.t (FirstOrder.mod_sorts sig N.fm_model) a -> FirstOrder.mod_sorts sig N.fm_model r.
  intros.
  pose proof symbs_contents sym a r.
  destruct H0.
  specialize (H0 H).
  destruct H0 as [? [? ?]].
  subst.
  inversion X; subst.
  inversion X1; subst.
  simpl in *.
  exact (pow X0 X2).
Defined.

Notation sig' := (UF.sig sig symbs).
Definition uf_model := UF.fm_model sig N.fm_model symbs interp_syms.

Lemma in_pow :
  In ("pow", [NS; NS], NS)%string symbs.
Proof.
  simpl.
  left; trivial.
Defined.

Notation natlit := (tacLit sig' uf_model nat_lit).
MetaCoq Quote Definition t_pow := (pow).

Definition is_pow := eq_term t_pow.

Program Definition match_tacs : list ((term -> bool) * tac_syn sig' uf_model) := [
  ( is_pow, tacFun _ _ {| deep_f := UFun sig symbs in_pow |} );
  ( is_nat_term,
    natlit
      (fun z => existT _ NS z)
      (fun z _ => existT _ NS (TFun _ (CFun _ symbs (NLit z)) hnil)))
  ].

MetaCoq Quote Definition n_ind := (nat).

Definition match_inds : list (term * N.sorts) := [
    (n_ind, NS)
  ].

MetaCoq Quote Definition test_1 := (pow 1 2 = 1).

Ltac simpl_denote_tm :=
  match goal with
  | |- denote_t2fm _ _ _ _ _ _ _ _ = Some _ =>
    let x := fresh "x" in
    set (x := denote_t2fm _ _ _ _ _ _ _ _);

    simpl in x;
    unfold eq_rect_r in x;
    simpl in x;
    exact eq_refl
  end.

Ltac reflect_goal sig model srts_eq_dec mtacs minds t' :=
  match goal with
  | |- ?G =>
    eapply denote_extract_specialized with (s := sig) (m := model) (sorts_eq_dec := srts_eq_dec) (match_tacs := mtacs) (match_inds := minds) (p' := G) (t := t')
  end; [
    simpl_denote_tm |
    simpl_extract_tm |
    discharge_equiv_denote_orig; autorewrite with mod_fns; eauto |
    let v' := fresh "v" in
    let f' := fresh "f" in
    match goal with
    | |- interp_fm ?v ?f =>
      set (v' := v);
      set (f' := f)
    end;
    vm_compute in f';
    subst v';
    subst f'
  ].

Goal (pow 1 2 = 1).
Proof.
  reflect_goal (UF.sig sig symbs) uf_model N.sorts_eq_dec match_tacs match_inds test_1.

  simpl.
  unfold eq_rect_r.
  simpl eq_rect.
  2: {
    autorewrite with interp_fm.
    autorewrite with interp_tm.
    simpl.
    vm_compute.
  }
  match goal with
  | |- ?G => check_interp_pos G
  end.
Admitted.

(* TODO:
  1) develop metaprogramming plumbing for reflecting pow as an uninterpreted fun symbol, and
  2) recognize uninterpreted function symbols in the backend
*)
Lemma pow_gt_lin_r : forall p, pow 1 p = 1.
Proof.
  intros.
  (* induction p *)

  (* demo 1: manual symbolic logical evaluation *)

  assert (pow 1 p = pow 1 p) by trivial.
  revert H.
  revert p.
  induction p.

  - intros.
    simpl in *.
    trivial.
  - intros.
    simpl pow at 1 in H.
    erewrite <- H.
    erewrite Nat.add_0_r.
    eapply IHp.
    trivial.

  (* demo 2: symbolic logical evaluation with functional induction  *)

  (* functional induction (pow 1 p) using pow_ind.

  - intros; trivial.
  - erewrite IHn0.
    trivial. *)
Qed.

From Hammer Require Import Hammer.

Ltac try_ind base_tac :=
  multimatch goal with
  | |- forall (X: _), _ =>
    intros X; try_ind base_tac
  | |- ?X -> _ =>
    intros X; try_ind base_tac
  | |- forall (X: _), _ =>
    induction X; try_ind base_tac
  | |- ?X -> _ =>
    induction X; try_ind base_tac
  | _ => base_tac
  end.

Set Hammer ATPLimit 3.

Lemma pow_eq_zero:
  forall a b, pow a b = 0 -> a = 0.
Proof.
  try_ind hammer.
  induction b; hammer.
  intros.
  sauto.
  hammer.
  induction b.
  - intros; inversion H.
  - intros.
    simpl in *.


Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Require Export FcEtt.ett_ott.
Require Export FcEtt.ett_ind.

Lemma param_same : forall a, param a a = a.
Proof. unfold param.
intro a. destruct a; simpl; auto.
Qed.

Hint Rewrite param_same.

Lemma param_covariant : forall R R1 R2, SubRole R R2 -> SubRole (param R1 R) (param R1 R2).
  intros.
  unfold param.
  destruct R1; destruct R2; simpl; auto. destruct R. auto. auto.
Qed.

Lemma param_sub1 : forall R R1, SubRole (param R1 R) R1.
Proof. intros. unfold param; simpl; auto.
unfold min. destruct R1; destruct R; simpl; auto.
Qed.

Lemma param_rep_r : `(param R Rep = R).
Proof.
  intros; unfold param; auto.
  case R; reflexivity.
Qed.

Lemma app_role_covariant : forall nu R1 R2,
    SubRole R1 R2 -> SubRole (app_role nu R1)(app_role nu R2).
Proof.
  intros. unfold app_role. destruct nu; simpl; eauto using param_covariant.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Monad.
Require Import Category.Functor.Strong.
Require Import Category.Structure.Terminal.
Require Import Category.Structure.Initial.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Structure.Cocartesian.
Require Import Category.Structure.BiCCC.
Require Import Category.Structure.Constant.
Require Import Category.Structure.Monoidal.
Require Import Category.Structure.Monoidal.Closed.
Require Import Category.Structure.Monoidal.Internal.Product.
Require Import Category.Instance.Sets.

Generalizable All Variables.

#[export]
Program Instance Coq : Category := {
  obj     := Type;
  hom     := λ A B : Type, A → B;
  homset  := λ _ _, {| equiv := λ f g, ∀ x, f x = g x |};
  id      := λ _ x, x;
  compose := λ _ _ _ g f x, g (f x)
}.
Next Obligation. equivalence; congruence. Qed.
Next Obligation. proper; congruence. Qed.

#[export]
Program Instance Coq_Terminal : @Terminal Coq := {
  terminal_obj := unit : Type;
  one := λ _ a, tt
}.
Next Obligation. destruct (f x0), (g x0); reflexivity. Qed.

#[export]
Program Instance Coq_Cartesian : @Cartesian Coq := {
  product_obj := λ x y, x * y : Type;
  fork := λ _ _ _ f g x, (f x, g x);
  exl  := λ _ _ p, fst p;
  exr  := λ _ _ p, snd p
}.
Next Obligation. proper; congruence. Qed.
Next Obligation.
  intros; simplify; intros.
  - rewrite H; reflexivity.
  - rewrite H; reflexivity.
  - intros; simplify.
    rewrite <- H, <- H0.
    rewrite <- surjective_pairing; reflexivity.
Qed.

#[export]
Program Instance Coq_Monoidal : @Monoidal Coq :=
  @CC_Monoidal Coq Coq_Cartesian Coq_Terminal.

#[export]
Program Instance Coq_Closed : @Closed Coq _ := {
  exponent_obj := Basics.arrow;
  exp_iso := λ _ _ _,
    {| to   := {| morphism := λ f a b, f (a, b) |}
     ; from := {| morphism := λ f p, f (fst p) (snd p) |} |}
}.
Next Obligation. proper; extensionality X0; congruence. Qed.
Next Obligation. proper; congruence. Qed.

#[export]
Program Instance Coq_ClosedMonoidal : @ClosedMonoidal Coq :=
  @CCC_ClosedMonoidal Coq Coq_Cartesian Coq_Terminal Coq_Closed.

#[export]
Program Instance Coq_Initial : Initial Coq := {
  terminal_obj := False;
  one := λ _ _, False_rect _ _
}.
Next Obligation. contradiction. Qed.

#[export]
Program Instance Coq_Cocartesian : @Cocartesian Coq := {
  product_obj := sum;
  fork := λ _ _ _ f g x,
            match x with
            | Datatypes.inl v => f v
            | Datatypes.inr v => g v
            end;
  exl  := λ _ _ p, Datatypes.inl p;
  exr  := λ _ _ p, Datatypes.inr p
}.
Next Obligation.
  split; intros.
  - split; intros;
    rewrite H; reflexivity.
  - destruct x0; firstorder.
Qed.

(** All endofunctors in Coq have strength *)

#[export]
Program Instance Coq_StrongFunctor (F : Coq ⟶ Coq) : StrongFunctor F := {|
  strength := λ _ _ p, fmap[F] (λ y, (fst p, y)) (snd p)
|}.
Next Obligation.
  repeat srewrite_r (@fmap_comp _ _ F).
  f_equal.
Qed.
Next Obligation.
  repeat srewrite_r (@fmap_comp _ _ F).
  now srewrite (@fmap_id _ _ F).
Qed.
Next Obligation.
  repeat srewrite_r (@fmap_comp _ _ F).
  f_equal.
Qed.


From Hammer Require Import Hammer.

Require Import PeanoNat.

Local Open Scope nat_scope.
Implicit Types m n p : nat.

Notation max := Nat.max (only parsing).

Definition max_0_l := Nat.max_0_l.
Definition max_0_r := Nat.max_0_r.
Definition succ_max_distr := Nat.succ_max_distr.
Definition plus_max_distr_l := Nat.add_max_distr_l.
Definition plus_max_distr_r := Nat.add_max_distr_r.
Definition max_case_strong := Nat.max_case_strong.
Definition max_spec := Nat.max_spec.
Definition max_dec := Nat.max_dec.
Definition max_case := Nat.max_case.
Definition max_idempotent := Nat.max_id.
Definition max_assoc := Nat.max_assoc.
Definition max_comm := Nat.max_comm.
Definition max_l := Nat.max_l.
Definition max_r := Nat.max_r.
Definition le_max_l := Nat.le_max_l.
Definition le_max_r := Nat.le_max_r.
Definition max_lub_l := Nat.max_lub_l.
Definition max_lub_r := Nat.max_lub_r.
Definition max_lub := Nat.max_lub.

Notation max_case2 := max_case (only parsing).
Notation max_SS := Nat.succ_max_distr (only parsing).

Hint Resolve
Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith.

Hint Resolve
Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith.


Require Import Coq.Classes.RelationClasses.

Require Import utils.
Require Import syntax.
Require Import relations.
Require Import integration.

(** * Symmetry *)

Lemma A_rel_symmetric' {τ} :
  Symmetric (V_rel τ) ->
  Symmetric (A_rel τ).
Proof.
  repeat intro.
  apply eq_sym.
  apply H0, H, Hv.
Qed.

Lemma E_rel_symmetric' {τ} :
  Symmetric (V_rel τ) ->
  Symmetric (E_rel τ).
Proof.
  repeat intro.
  apply eq_sym.
  apply H0.
  apply A_rel_symmetric'; auto.
Qed.

Instance V_rel_symmetric {τ} : Symmetric (V_rel τ).
Proof.
  repeat intro.
  induction τ. {
    apply eq_sym.
    exact H.
  } {
    destruct H.

    constructor.
    intros.

    apply E_rel_symmetric'; auto.
    apply H.
    apply IHτ1.
    exact H0.
  }
Qed.

Instance E_rel_symmetric {τ} : Symmetric (E_rel τ)
  := E_rel_symmetric' V_rel_symmetric.
Instance A_rel_symmetric {τ} : Symmetric (A_rel τ)
  := A_rel_symmetric' V_rel_symmetric.

Instance G_rel_symmetric {Γ} : Symmetric (G_rel Γ).
Proof.
  repeat intro.
  induction Γ; dep_destruct (x, y). {
    constructor.
  } {
    dep_destruct H.
    constructor; auto.
    symmetry.
    assumption.
  }
Qed.

Instance rel_expr_symmetric {Γ τ} : Symmetric (related_exprs Γ τ).
Proof.
  intros e0 e1 He ? ? ?.
  symmetry.
  apply He.
  symmetry.
  auto.
Qed.

(** * Transitivity *)

Instance A_rel_transitive' {τ} :
  Transitive (V_rel τ) ->
  Transitive (A_rel τ).
Proof.
  intros ? x y z Hxy Hyz.
  intros v0 v1 Hv.
  transitivity (y v0); auto.
  apply Hxy.
  transitivity v1; [| symmetry]; exact Hv.
Qed.

Instance E_rel_transitive' {τ} :
  Transitive (V_rel τ) ->
  Transitive (E_rel τ).
Proof.
  intros ? x y z Hxy Hyz.
  repeat intro.

  transitivity (μ y A0); auto.
  apply Hxy.
  transitivity A1; [| symmetry]; exact HA.
Qed.

Instance V_rel_transitive {τ} :
  Transitive (V_rel τ).
Proof.
  repeat intro.
  induction τ.
  {
    transitivity y; assumption.
  } {
    destruct H.
    remember (v_lam body1).
    destruct H0.
    dep_destruct Heqv.
    rename body0 into x_body, body1 into y_body, body3 into z_body.

    constructor.
    intros.

    eapply (E_rel_transitive' IHτ2 _); [| apply H0; eauto].
    apply H.

    eapply IHτ1; eauto.
    symmetry.
    auto.
  }
Qed.

Instance E_rel_transitive {τ} : Transitive (E_rel τ)
  := E_rel_transitive' V_rel_transitive.
Instance A_rel_transitive {τ} : Transitive (A_rel τ)
  := A_rel_transitive' V_rel_transitive.

Instance G_rel_transitive {Γ} : Transitive (G_rel Γ).
Proof.
  repeat intro.
  induction Γ; dep_destruct (x, y, z). {
    constructor.
  } {
    dep_destruct H.
    dep_destruct H1.
    constructor. {
      etransitivity; eauto.
    } {
      eapply IHΓ; eauto.
    }
  }
Qed.

Instance rel_expr_transitive {Γ τ} : Transitive (related_exprs Γ τ).
Proof.
  intros x y z Hxy Hyz ? ? ?.

  transitivity (proj1_sig (close ρ0 y)). {
    apply Hxy.
    transitivity ρ1; [| symmetry]; exact Hρ.
  } {
    apply Hyz.
    exact Hρ.
  }
Qed.

(** * Reflexivity
    Depends on the fundamental property. *)

Instance E_rel_reflexive {τ} : Reflexive (E_rel τ).
Proof.
  intro e.
  pose proof (fundamental_property e _ _ G_rel_nil).
  elim_sig_exprs.
  elim_erase_eqs.
  auto.
Qed.

Instance V_rel_reflexive {τ} : Reflexive (V_rel τ).
Proof.
  intros v.

  destruct v using wt_val_rect; subst; simpl in *. {
    reflexivity.
  } {
    constructor.
    repeat intro.

    pose proof fundamental_property body as fp.
    specialize (fp _ _ (G_rel_cons H G_rel_nil)).

    elim_sig_exprs.
    elim_erase_eqs.

    apply fp; auto.
  }
Qed.

Lemma A_rel_subidentity {τ} {A0 A1 : Event (val τ)}
  : A_rel τ A0 A1 -> A0 = A1.
Proof.
  intros.
  extensionality v.
  apply H.
  reflexivity.
Qed.

Instance G_rel_reflexive {Γ} : Reflexive (G_rel Γ).
Proof.
  repeat intro.
  induction Γ; dep_destruct x. {
    constructor.
  } {
    constructor; auto.
    reflexivity.
  }
Qed.

Instance rel_expr_reflexive {Γ τ} : Reflexive (related_exprs Γ τ)
  := fundamental_property.

(** * Proving expressions are related *)

Lemma same_substitution_suffices {Γ τ} (e0 e1 : expr Γ τ) :
  (forall (ρ : wt_env Γ),
      E_rel τ (proj1_sig (close ρ e0)) (proj1_sig (close ρ e1))) ->
  (EXP Γ ⊢ e0 ≈ e1 : τ).
Proof.
  intros ? ρ0 ρ1 Hρ.

  transitivity (proj1_sig (close ρ0 e1)). {
    apply H.
  } {
    apply fundamental_property; auto.
  }
Qed.

Lemma relate_exprs {Γ τ} (e0 e1 : expr Γ τ) :
  (forall ρ A, μ (proj1_sig (close ρ e0)) A = μ (proj1_sig (close ρ e1)) A) ->
  (EXP Γ ⊢ e0 ≈ e1 : τ).
Proof.
  intros.

  apply same_substitution_suffices; auto.

  repeat intro.

  rewrite (A_rel_subidentity HA).
  apply H.
Qed.


(**
# 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)

http://qnighy.github.io/coqex2014/

## 課題42 (種別:A / 締め切り : 2014/06/15)

自然数におけるlog関数(底は2)を以下のテンプレートに従って定義せよ。
テンプレートを改変しているので、このままで応募してはいけない。
*)

Require Import ssreflect ssrbool ssrnat div eqtype.
Require Import Recdef.

(*
Require Import Arith.
Require Import Omega.
Require Import Recdef.
*)

Require Import Lt.

(* http://gcg00467.xii.jp/wp/archives/891 *)
(* http://www.cse.chalmers.se/research/group/logic/TypesSS05/resources/coq/CoqArt/gen-rec/SRC/chap15.v *)
Theorem lt_Acc : forall n:nat, Acc lt n.
Proof.
 induction n.
 split; intros p H; inversion H.
 split.
 intros y H0.
 case (le_lt_or_eq _ _ H0).
 intro; apply Acc_inv with n; auto with arith.
 intro e; injection e; intro e1; rewrite e1; assumption.
Qed.

Function log (n:nat) {wf lt n} :=
  match n with
    | 0 => 0
    | 1 => 0
    | n => (log (n %/ 2)).+1
  end.
Proof.
  + move=> n2 n1 n Hn1 Hn2.
    rewrite -!Hn2.
    apply/leP.
    Search (_ %/ _ < _).
    apply ltn_Pdiv.
      - by [].
      - by rewrite Hn2.
  + rewrite /well_founded.
    by apply lt_Acc.
Qed.

(*
ヒント

Fixpointでは構造に基づく帰納法しか書けませんでした。Coqが自動的に停止性を判断できないような
関数の定義をするために、Functionコマンドが用意されています。停止性はwf (パラメーターのうち
の1つが整礎的な関係に従って降下していくことを示す) または measure (パラメーターのうちの1つ
に自然数の重みを定める関数があり、再帰呼び出しはこの重みが減る方向に進むということを示す)
の2つの方法があります。

*)

(* END *)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-28

Some results concerning permutations of lists.
*)

Set Implicit Arguments.

Require Import ListExtras NatUtil LogicUtil Setoid Morphisms Basics.
Require Export Permutation PermutSetoid Multiset.

Arguments list_contents [A eqA] _ _.
Arguments permutation [A eqA] _ _ _.

Section Multiplicity.

  Variables
    (A : Type) (eqA : relation A)
    (eqA_dec : forall x y, {eqA x y} + {~eqA x y})
    (eqA_Equivalence : Equivalence eqA).

  Lemma multiplicity_in: forall l x,
    multiplicity (list_contents eqA_dec l) x > 0 ->
    exists x', eqA x' x /\ In x' l.

  Proof.
    induction l; simpl; intros.
    omega.
    destruct (eqA_dec a x).
    exists a; auto.
    destruct (IHl x) as [x' [x'x x'l]]; trivial.
    exists x'; split; auto.
  Qed.

  Lemma in_multiplicity: forall l a,
    In a l ->
    multiplicity (list_contents eqA_dec l) a > 0.

  Proof.
    induction l; simpl; intros.
    omega.
    destruct H.
    destruct (eqA_dec a a0).
    omega.
    absurd (eqA a a0); trivial.
    rewrite H; intuition.
    set (w := IHl a0 H); omega.
  Qed.

  Lemma multiplicity_countIn: forall l el,
    multiplicity (list_contents eqA_dec l) el = countIn eqA eqA_dec el l.

  Proof.
    induction l; simpl; intros; trivial.
    destruct (eqA_dec a el); destruct (eqA_dec el a).
    rewrite IHl; omega.
    absurd (eqA el a); intuition.
    absurd (eqA a el); intuition.
    rewrite IHl; omega.
  Qed.

  Lemma multiplicity_dropNth_eq: forall l p el el',
    nth_error l p = Some el' ->
    eqA el el' ->
    multiplicity (list_contents eqA_dec (drop_nth l p)) el =
    multiplicity (list_contents eqA_dec l) el - 1.

  Proof.
    intros.
    rewrite !multiplicity_countIn.
    apply countIn_dropNth_eq with el'; trivial.
  Qed.

  Lemma multiplicity_dropNth_neq: forall l p el el',
    nth_error l p = Some el' ->
    ~eqA el el' ->
    multiplicity (list_contents eqA_dec (drop_nth l p)) el =
    multiplicity (list_contents eqA_dec l) el.

  Proof.
    intros.
    rewrite !multiplicity_countIn.
    apply countIn_dropNth_neq with el'; trivial.
  Qed.

End Multiplicity.

Section Permutation.

  Variables
    (A : Type) (eqA : relation A)
    (eqA_dec : forall x y, {eqA x y} + {~eqA x y})
    (eqA_Equivalence : Equivalence eqA).

  Lemma permutation_sym: forall l l',
    permutation eqA_dec l l' -> permutation eqA_dec l' l.

  Proof. intros; intro; auto. Qed.

  Lemma permutation_in: forall l l' a, permutation eqA_dec l l' ->
    In a l -> exists a', eqA a' a /\ In a' l'.

  Proof.
    intros.
    destruct (multiplicity_in eqA eqA_dec l' a) as [a' [aa' a'l']].
    rewrite <- (H a); trivial.
    apply in_multiplicity; trivial.
    exists a'; split; trivial.
  Qed.

  Lemma permutation_drop: forall (l l': list A) a b p,
    eqA a b -> nth_error l' p = Some b ->
    permutation eqA_dec (a :: l) l' -> permutation eqA_dec l (drop_nth l' p).

  Proof.
    intros; intro el.
    destruct (eqA_dec a el).
    assert (eqA el b).
    apply (Seq_trans A eqA eqA_Equivalence) with a; intuition.
    rewrite (multiplicity_dropNth_eq eqA_dec eqA_Equivalence l' p el H0 H2).
    set (w := H1 el); simpl in w.
    replace (if eqA_dec a el then 1 else 0) with 1 in w.
    omega.
    clear w; destruct (eqA_dec a el); [trivial | contr].
    assert (~eqA el b).
    intro elb.
    absurd (eqA a el); trivial.
    apply (Seq_trans A eqA eqA_Equivalence) with b; intuition.
    rewrite (multiplicity_dropNth_neq eqA_dec eqA_Equivalence l' p el H0 H2).
    set (w := H1 el); simpl in w.
    replace (if eqA_dec a el then 1 else 0) with 0 in w.
    omega.
    clear w; destruct (eqA_dec a el); [contr | trivial].
  Qed.

  Lemma permutation_cons: forall l l' a,
    permutation eqA_dec (a :: l) l' ->
    exists p a',
      nth_error l' p = Some a' /\
      eqA a a' /\
      permutation eqA_dec l (drop_nth l' p).

  Proof.
    intros.
    destruct (permutation_in a H) as [a' [aa' a'l']].
    auto with datatypes.
    destruct (list_In_nth l' a' a'l') as [p l'p].
    exists p; exists a'; split; [idtac | split]; trivial.
    intuition.
    apply permutation_drop with a a'; trivial.
    intuition.
  Qed.

  Lemma permutation_length: forall (l l': list A),
    permutation eqA_dec l l' ->
    length l = length l'.

  Proof.
    induction l; intros.
     (* base *)
    simpl.
    destruct l'; trivial.
    unfold permutation in H.
    exfalso.
    assert (w := H a); simpl in w; clear H.
    destruct (eqA_dec a a).
    omega.
    intuition.
     (* step *)
    destruct (permutation_cons H) as [p [a' [l'p [aa' ll'p]]]].
    simpl.
    rewrite (IHl (drop_nth l' p)); trivial.
    set (w := nth_some l' p l'p).
    rewrite drop_nth_in_length; trivial.
    omega.
  Qed.

  Lemma insert_nth_permut: forall (l: list A) el n,
    permutation eqA_dec (insert_nth l n el) (el::l).

  Proof.
    induction l; intros.
    unfold insert_nth, finalSeg; destruct n; simpl; apply permut_refl.
    destruct n; unfold insert_nth; simpl.
    rewrite finalSeg_full; apply permut_refl.
    unfold finalSeg; simpl.
    fold (finalSeg l n); fold (insert_nth l n el).
    apply permut_tran with (a :: el :: l).
    apply permut_cons.
    apply IHl.
    change (el :: a :: l) with ((el :: nil) ++ a :: l).
    change (a :: el :: l) with (a :: (el :: nil) ++ l).
    apply permut_middle.
  Qed.

  Lemma insert_nth_permut': forall (l l': list A) el n,
    permutation eqA_dec l l' ->
    permutation eqA_dec (insert_nth l n el) (el::l').

  Proof.
    intros; intro w.
    unfold insert_nth.
    change (el :: finalSeg l n) with ((el :: nil) ++ finalSeg l n).
    change (el :: l') with ((el :: nil) ++ l').
    rewrite !list_contents_app.
    simpl.
    rewrite plus_0_r.
    match goal with
    | |- ?a + (?b + ?c) = ?d => replace (a + (b + c)) with (a + c + b)
    end.
    replace (multiplicity (list_contents eqA_dec (initialSeg l n)) w +
      multiplicity (list_contents eqA_dec (finalSeg l n)) w)
    with (multiplicity
      (list_contents eqA_dec (initialSeg l n ++ finalSeg l n)) w).
    rewrite initialSeg_finalSeg_full; trivial.
    rewrite (H w); auto with arith.
    rewrite list_contents_app; trivial.
    omega.
  Qed.

End Permutation.

Section ListSim.

  Variable A : Type.
  Variable B : Type.
  Variable R : A -> B -> Prop.

  Inductive list_sim: list A -> list B -> Prop :=
  | conv_empty:
      list_sim nil nil
  | conv_cons: forall x y xs ys,
      R x y ->
      list_sim xs ys ->
      list_sim (x::xs) (y::ys).

  Lemma list_sim_nth : forall p l l' a, list_sim l l' ->
    nth_error l p = Some a ->
    exists b, nth_error l' p = Some b /\ R a b.

  Proof.
    induction p.
    intros.
    inversion H.
    rewrite <- H1 in H0; discr.
    exists y; split; auto.
    replace a with x; trivial.
    rewrite <- H3 in H0; inversion H0; trivial.
    intros.
    destruct l; destruct l'; try discr.
    inversion H.
    inversion H.
    destruct (IHp l l' a); trivial.
    destruct H7.
    exists x0; split; trivial.
  Qed.

  Lemma list_sim_nth_rev : forall p l l' b, list_sim l l' ->
    nth_error l' p = Some b ->
    exists a, nth_error l p = Some a /\ R a b.

  Proof.
    induction p.
    intros.
    inversion H.
    rewrite <- H2 in H0; discr.
    exists x; split; auto.
    replace b with y; trivial.
    rewrite <- H4 in H0; inversion H0; trivial.
    intros.
    destruct l; destruct l'; try discr.
    inversion H.
    inversion H.
    destruct (IHp l l' b); trivial.
    destruct H7.
    exists x0; split; trivial.
  Qed.

  Lemma list_sim_app : forall l1 l1' l2 l2',
    list_sim l1 l1' -> list_sim l2 l2' -> list_sim (l1 ++ l2) (l1' ++ l2').

  Proof.
    induction l1; intros.
    inversion H; trivial.
    inversion H.
    simpl; constructor; trivial.
    apply IHl1; trivial.
  Qed.

  Lemma list_sim_unique : forall l m m',
    (forall x y y', In x l -> In y m -> In y' m' ->
      R x y -> R x y' -> y = y') ->
    list_sim l m -> list_sim l m' -> m = m'.

  Proof.
    induction l; intros; inversion H0; inversion H1; trivial.
    rewrite (H x y y0).
    rewrite (IHl ys ys0); trivial.
    intros.
    destruct (list_In_nth l x1 H12) as [p lp].
    apply H with x1; trivial.
    right; trivial.
    rewrite <- H5; right; trivial.
    rewrite <- H10; right; trivial.
    rewrite H2; auto with datatypes.
    rewrite <- H5; left; trivial.
    rewrite <- H10; left; trivial.
    rewrite H2; trivial.
    rewrite H2; trivial.
  Qed.

  Lemma list_sim_insert_nth : forall p l l' a a', nth_error l p = Some a ->
    nth_error l' p = Some a' -> R a a' ->
    list_sim (drop_nth l p) (drop_nth l' p) -> list_sim l l'.

  Proof.
    induction p; intros.
     (* induction base *)
    destruct l; destruct l'.
    constructor.
    inversion H2; discr.
    inversion H2; discr.
    constructor.
    inversion H; inversion H0; trivial.
    rewrite !drop_nth_cons in H2; trivial.
     (* induction step *)
    destruct l; destruct l'.
    constructor.
    inversion H2; discr.
    inversion H2; discr.
    rewrite !drop_nth_succ in H2.
    inversion H2.
    constructor; trivial.
    apply IHp with a a'; trivial.
  Qed.

  Lemma list_sim_length : forall l l', list_sim l l' -> length l = length l'.

  Proof.
    induction l; intros.
    inversion H; trivial.
    destruct l'.
    inversion H.
    simpl.
    rewrite (IHl l'); trivial.
    inversion H; trivial.
  Qed.

  Lemma list_sim_tail : forall l l',
    list_sim l l' -> list_sim (tail l) (tail l').

  Proof.
    intros.
    destruct H; trivial.
    simpl; constructor.
  Qed.

End ListSim.

Section ListSim_iso.

  Variables
    (A : Type) (P eqA : relation A)
    (eqA_dec : forall x y, {eqA x y} + {~eqA x y})
    (eqA_Equivalence : Equivalence eqA)
    (P_eqA_comp : Proper (eqA ==> eqA ==> impl) P).

  Definition list_simA := @list_sim A A P.

  Lemma list_sim_permutation : forall l l' m,
    list_simA l l' -> permutation eqA_dec l m ->
    exists m', list_simA m m' /\ permutation eqA_dec l' m'.

  Proof.
    unfold Setoid_Theory in eqA_Equivalence.
    induction l; intros.
     (* induction base *)
    exists (nil (A:=A)); split.
    destruct m.
    constructor.
    set (w := H0 a); inversion w.
    destruct (eqA_dec a a).
    omega.
    absurd (eqA a a); intuition.
    inversion H.
    apply permut_refl.
     (* induction step *)
    destruct l'.
    inversion H.
    destruct (permutation_cons eqA_Equivalence H0) as [p [a' [mp [aa' lm]]]].
    destruct (IHl l' (drop_nth m p)) as [m' [mm' l'm']]; trivial.
    inversion H; trivial.
    assert (length m' >= p).
    rewrite <- (list_sim_length mm').
    set (h := nth_some m p mp).
    set (w := drop_nth_length m p).
    omega.
    exists (insert_nth m' p a0); split.
    unfold list_simA; apply list_sim_insert_nth with p a' a0; trivial.
    apply nth_insert_nth; trivial.
    apply P_eqA_comp with a a0; intuition.
    inversion H; intuition.
    rewrite drop_nth_insert_nth; trivial.
    apply permutation_sym.
    apply insert_nth_permut'.
    apply permutation_sym; trivial.
  Qed.

End ListSim_iso.


From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts.
From Undecidability.Synthetic Require ListEnumerabilityFacts.

Require Import Undecidability.TM.SBTM.
Import SBTMNotations.

(* semi-decider for SBTM_HALT *)
Lemma SBTM_HALT_semi_decision : { f : { M : SBTM & config M } -> nat -> bool | semi_decider f SBTM_HALT }.
Proof.
  exists (fun '(existT _ M x) k => match steps M k x with | Some _ => false | None => true end).
  intros [M x]. split.
  + intros [k Hk]. exists k. now rewrite Hk.
  + intros [k Hk]. exists k.
    now destruct (steps M k x) as [?|].
Qed.

Definition SBTM_to_sigT (M : SBTM) := existT
  (fun n => Vector.t (option (Fin.t n * _ * _) * option (Fin.t n * _ * _)) n) (num_states M) (trans M).
Definition SBTM_of_sigT := fun '(existT _ n t) => @Build_SBTM n t.

Lemma direction_enumeration : { e | enumerator__T e direction}.
Proof.
  exists (fun n => match n with 0 => Some go_left | _ => Some go_right end).
  now intros []; [exists 0|exists 1].
Qed.

Lemma SBTM_enumeration : { e : nat -> option SBTM | enumerator__T e SBTM }.
Proof.
  assert {f | enumerator__T f {n : nat & Vector.t
    (option (Fin.t n * bool * direction) *
    option (Fin.t n * bool * direction)) n}} as [f Hf].
  { eexists.
    eapply enumerator__T_sigT.
    - apply enumerator__T_nat.
    - intros x. apply enumerator__T_Vector.
      apply enumerator__T_prod.
      + apply enumerator__T_option.
        apply enumerator__T_prod; [apply enumerator__T_prod|].
        * apply enumerator__T_Fin.
        * apply enumerator__T_bool.
        * apply (proj2_sig direction_enumeration).
      + apply enumerator__T_option.
        apply enumerator__T_prod; [apply enumerator__T_prod|].
        * apply enumerator__T_Fin.
        * apply enumerator__T_bool.
        * apply (proj2_sig direction_enumeration). }
  exists (fun n => option_map SBTM_of_sigT (f n)).
  intros M.
  destruct (Hf (SBTM_to_sigT M)) as [n Hn].
  exists n. rewrite Hn. now destruct M.
Qed.

Lemma config_enumeration (M : SBTM) : { e : nat -> option (config M) | enumerator__T e (config M) }.
Proof.
  eexists. apply enumerator__T_prod.
  + apply enumerator__T_Fin.
  + apply enumerator__T_prod; [apply enumerator__T_prod|].
    * eapply ListEnumerabilityFacts.enumerator__T_to_list.
      eapply ListEnumerabilityFacts.enumerator__T_list.
      eapply ListEnumerabilityFacts.enumerator__T_of_list.
      apply enumerator__T_bool.
    * apply enumerator__T_bool.
    * eapply ListEnumerabilityFacts.enumerator__T_to_list.
      eapply ListEnumerabilityFacts.enumerator__T_list.
      eapply ListEnumerabilityFacts.enumerator__T_of_list.
      apply enumerator__T_bool.
Qed.

Lemma SBTM_HALT_INSTANCE_enumeration : { e | enumerator__T e {M : SBTM & config M }}.
Proof.
  eexists.
  apply enumerator__T_sigT.
  - apply (proj2_sig SBTM_enumeration).
  - intros M. apply (proj2_sig (config_enumeration M)).
Qed.

(* enumerator for SBTM_HALT *)
Lemma SBTM_HALT_enumeration : { e : nat -> option { M : SBTM & config M } | enumerator e SBTM_HALT }.
Proof.
  exact (semi_decider_enumerator
    (proj2_sig SBTM_HALT_INSTANCE_enumeration)
    (proj2_sig SBTM_HALT_semi_decision)).
Qed.

Definition SBTM_HALT_enumerator := proj1_sig SBTM_HALT_enumeration.

Lemma SBTM_HALT_enumerator_spec : enumerator SBTM_HALT_enumerator SBTM_HALT.
Proof. exact (proj2_sig SBTM_HALT_enumeration). Qed.