Load InsertionSort.

Definition quicksort_impl_left_predicate {A} (rb : A -> A -> bool) x := fun y => negb (rb x y).

Definition quicksort_impl_right_predicate {A} (rb : A -> A -> bool) x := fun y => rb x y.

Definition quicksort_impl {A} rb :=
  fix quicksort_impl (n : nat) (l : list A) :=
    match n with
    | 0 =>
      match l with
      | [] => []
      | _ :: _ => []
      end
    | S n' =>
      match l with
      | [] => []
      | x :: l' =>
        quicksort_impl n' (filter (quicksort_impl_left_predicate rb x) l') ++
          x ::
          quicksort_impl n' (filter (quicksort_impl_right_predicate rb x) l')
      end
    end.

Definition quicksort {A} (r : A -> A -> Prop) {total_order : TotalOrder r}
  {rb} {decidable_binary_relation : DecidableBinaryRelation r rb} :=
  fun l => quicksort_impl rb (length l) l.

Lemma quicksort_impl_enough_fuel :
  forall {A} rb n m (l : list A),
  length l <= n ->
  length l <= m ->
  quicksort_impl rb n l = quicksort_impl rb m l.
Proof.
  intros ? ? ?. induction n; intros ? ? ? ?.
  - destruct m.
    + auto.
    + destruct l; simpl in H; try lia. auto.
  - destruct m.
    + destruct l; simpl in H0; try lia. auto.
    + simpl. destruct l.
      * auto.
      * f_equal.
        -- specialize (length_filter_le (quicksort_impl_left_predicate rb a) l) as ?.
           simpl in H, H0. apply IHn; lia.
        -- f_equal. specialize (length_filter_le (quicksort_impl_right_predicate rb a) l) as ?.
           simpl in H, H0. apply IHn; lia.
Qed.

Theorem quicksort_correct :
  forall {A} (r : A -> A -> Prop) {total_order : TotalOrder r}
    {rb} {decidable_binary_relation : DecidableBinaryRelation r rb},
  is_sorter r (quicksort r).
Proof.
  unfold is_sorter, quicksort. intros ? ? ? ? ? ?.
  remember (length l) as n. assert (length l <= n) by lia; clear Heqn.
  generalize dependent l. induction n using nat_strong_induction; intros l ?.
  destruct n.
  - destruct l.
    + simpl. split.
      * apply permutation_nil.
      * auto.
    + simpl in H0. lia.
  - destruct l.
    + simpl. split.
      * apply permutation_nil.
      * auto.
    + simpl. unfold quicksort_impl_left_predicate, quicksort_impl_right_predicate. simpl in H0.
      specialize (length_filter_le (fun y => negb (rb a y)) l) as ?.
      specialize (length_filter_le (fun y => rb a y) l) as ?.
      destruct (
        H
        (length (filter (fun y => negb (rb a y)) l))
        ltac:(lia)
        (filter (fun y => negb (rb a y)) l)
        ltac:(lia)
      ) as (? & ?).
      destruct (
        H
        (length (filter (fun y => rb a y) l))
        ltac:(lia)
        (filter (fun y => rb a y) l)
        ltac:(lia)
      ) as (? & ?).
      rewrite <- (quicksort_impl_enough_fuel _ n) in H3, H4, H5, H6; try lia. clear H H0 H1 H2.
      split.
      * clear H4 H6. apply permutation_insert.
        assert (predicate_xor (fun y => negb (rb a y)) (fun y => rb a y)). {
          unfold predicate_xor. intros x. destruct (rb a x); intuition auto.
        }
        specialize (permutation_filter l (fun y => negb (rb a y)) (fun y => rb a y) H) as ?; clear H.
        eapply permutation_app_trans.
        -- apply H0.
        -- apply permutation_sym. auto.
        -- apply permutation_sym. auto.
      * apply sorted_app.
        -- auto.
        -- simpl. split.
           ++ eapply list_forall_permutation.
              ** apply permutation_sym. apply H5.
              ** rewrite list_forall_list_in. intros b ?.
                 rewrite list_in_filter in H. destruct H as (? & ?).
                 destruct (DecidableBinaryRelation_spec r a b); try discriminate.
                 auto.
           ++ auto.
        -- simpl. eapply list_forall_permutation.
           ++ apply permutation_sym. apply H3.
           ++ rewrite list_forall_list_in. intros b ?.
              rewrite list_in_filter in H. destruct H as (? & ?). split.
              ** destruct (DecidableBinaryRelation_spec r a b); try discriminate.
                 specialize (TotalOrder_totality r a b); intuition auto.
              ** eapply list_forall_permutation.
                 --- apply permutation_sym. apply H5.
                 --- rewrite list_forall_list_in. intros c ?.
                     rewrite list_in_filter in H1. destruct H1 as (? & ?).
                     destruct (DecidableBinaryRelation_spec r a b); try discriminate.
                     destruct (DecidableBinaryRelation_spec r a c); try discriminate.
                     destruct (DecidableBinaryRelation_spec r b a).
                     +++ apply (TotalOrder_transitivity r) with a; auto.
                     +++ specialize (TotalOrder_totality r a b); intuition auto.
Qed.

Definition quicksort_impl_left_predicate_cost {A} rb {rb_Cost : Cost (Signature [_; _] _) rb} :=
  ltac2:(
    Cost.refine_compute_cost
    [(('rb, 2), '(@cost_fun _ _ rb_Cost))]
    2
    (eval red in (@quicksort_impl_left_predicate A rb))
    []
  ).

Definition quicksort_impl_right_predicate_cost {A} rb {rb_Cost : Cost (Signature [_; _] _) rb} :=
  ltac2:(
    Cost.refine_compute_cost
    [(('rb, 2), '(@cost_fun _ _ rb_Cost))]
    2
    (eval red in (@quicksort_impl_right_predicate A rb))
    []
  ).

#[export] Instance quicksort_impl_left_predicate_Cost {A}
  (rb : A -> A -> bool) {rb_Cost : Cost (Signature [_; _] _) rb} :
  Cost (Signature [_; _] _) (quicksort_impl_left_predicate rb) := {
  cost_fun := quicksort_impl_left_predicate_cost rb;
}.

#[export] Instance quicksort_impl_right_predicate_Cost {A}
  (rb : A -> A -> bool) {rb_Cost : Cost (Signature [_; _] _) rb} :
  Cost (Signature [_; _] _) (quicksort_impl_right_predicate rb) := {
  cost_fun := quicksort_impl_right_predicate_cost rb;
}.

Definition quicksort_impl_cost {A} rb {rb_Cost : Cost (Signature [_; _] _) rb} :=
  ltac2:(
    let use_rel_2 t :=
      match Constr.Unsafe.kind t with
      | Constr.Unsafe.Lambda _ body =>
        let body_subst := Constr.Unsafe.substnl [Constr.Unsafe.make (Constr.Unsafe.Var @x)] 0 body in
        Constr.Unsafe.closenl [@x] 2 body_subst
      | _ => Control.throw Match_failure
      end in
    Cost.refine_compute_cost
    [
      (
        (use_rel_2 '(fun x => filter (quicksort_impl_left_predicate rb x)), 1),
        use_rel_2 '(fun x =>
          @filter_cost
          _
          (quicksort_impl_left_predicate rb x)
          (Cost_cons _ _ _ _ (@quicksort_impl_left_predicate_Cost _ _ rb_Cost) _)
        )
      );
      (
        (use_rel_2 '(fun x => filter (quicksort_impl_right_predicate rb x)), 1),
        use_rel_2 '(fun x =>
          @filter_cost
          _
          (quicksort_impl_right_predicate rb x)
          (Cost_cons _ _ _ _ (@quicksort_impl_right_predicate_Cost _ _ rb_Cost) _)
        )
      );
      (('(@app A), 2), '(@app_cost A))
    ]
    2
    (eval red in (@quicksort_impl A rb))
    ['(@quicksort_impl A rb)]
  ).

Theorem quicksort_impl_left_predicate_cost_constant_on_cost_constant_rb :
  forall {A} (rb : A -> A -> bool) {rb_Cost : Cost (Signature [_; _] _) rb},
  binary_cost_constant rb_Cost ->
  binary_cost_constant (quicksort_impl_left_predicate_Cost rb).
Proof.
  intros ? ? ? ?. destruct H as (c & H). exists (c + 4). intros (a, b). specialize (H (a, b)).
  simpl. unfold quicksort_impl_left_predicate_cost. lia.
Qed.

Theorem quicksort_impl_right_predicate_cost_constant_on_cost_constant_rb :
  forall {A} (rb : A -> A -> bool) {rb_Cost : Cost (Signature [_; _] _) rb},
  binary_cost_constant rb_Cost ->
  binary_cost_constant (quicksort_impl_right_predicate_Cost rb).
Proof.
  intros ? ? ? ?. destruct H as (c & H). exists (c + 4). intros (a, b). specialize (H (a, b)).
  simpl. unfold quicksort_impl_right_predicate_cost. lia.
Qed.

Lemma quicksort_cost_enough_fuel :
  forall {A} (r : A -> A -> Prop) {total_order : TotalOrder r}
    {rb} {decidable_binary_relation : DecidableBinaryRelation r rb}
    {rb_Cost : Cost (Signature [_; _] _) rb}
    n m l,
  length l <= n ->
  length l <= m ->
  quicksort_impl_cost rb n l = quicksort_impl_cost rb m l.
Proof.
  intros ? ? ? ? ? ? ? ?. generalize dependent n. induction m; intros ? ? ? ?.
  - destruct n.
    + lia.
    + destruct l.
      * auto.
      * simpl in H0. lia.
  - destruct n.
    + destruct l.
      * simpl. lia.
      * simpl in H. lia.
    + destruct l.
      * simpl. lia.
      * simpl. simpl in H. simpl in H0.
        specialize (length_filter_le (quicksort_impl_left_predicate rb a) l) as ?.
        specialize (length_filter_le (quicksort_impl_right_predicate rb a) l) as ?.
        rewrite (IHm n (filter (quicksort_impl_left_predicate rb a) l) ltac:(lia) ltac:(lia)).
        rewrite (IHm n (filter (quicksort_impl_right_predicate rb a) l) ltac:(lia) ltac:(lia)).
        clear IHm.
        rewrite (quicksort_impl_enough_fuel _  n m); try lia.
        rewrite (quicksort_impl_enough_fuel _  n m); try lia.
Qed.

Theorem quicksort_cost_quadratic_on_cost_constant_rb :
  forall {A} (r : A -> A -> Prop) {total_order : TotalOrder r}
    {rb} {decidable_binary_relation : DecidableBinaryRelation r rb}
    {rb_Cost : Cost (Signature [_; _] _) rb},
  binary_cost_constant rb_Cost ->
  big_o
    (fun l => quicksort_impl_cost rb (length l) l)
    (fun (l : list A) => 1 + (length l) * (length l)).
Proof.
  intros ? ? ? ? ? ? ?.
  specialize (@app_cost_linear A) as ?.
  specialize (
    filter_cost_linear_when_predicate_cost_constant_binary
    (quicksort_impl_left_predicate rb)
    (quicksort_impl_left_predicate_cost_constant_on_cost_constant_rb rb H)
  ) as ?.
  specialize (
    filter_cost_linear_when_predicate_cost_constant_binary
    (quicksort_impl_right_predicate rb)
    (quicksort_impl_right_predicate_cost_constant_on_cost_constant_rb rb H)
  ) as ?.
  clear H. destruct H0 as (c1 & H0), H1 as (c2 & H1), H2 as (c3 & H2).
  exists ((c1 + c2 + c3) * 2 + 18). intros l.
  remember (length l) as n. assert (length l <= n) by lia; clear Heqn.
  generalize dependent l. induction n using nat_strong_induction; intros l ?.
  destruct n.
  - simpl. destruct l; lia.
  - destruct l.
    + simpl. lia.
    + simpl. destruct (list_empty_or_not_empty l).
      * subst l. destruct n.
        -- simpl. lia.
        -- simpl. lia.
      * simpl in H3. apply le_S_n in H3.
        specialize (length_filter_le (quicksort_impl_left_predicate rb a) l) as ?.
        specialize (length_filter_le (quicksort_impl_right_predicate rb a) l) as ?.
        specialize (
          H0
          (
            (quicksort_impl rb (length l) (filter (quicksort_impl_left_predicate rb a) l)),
            (a :: quicksort_impl rb (length l) (filter (quicksort_impl_right_predicate rb a) l))
          )
        ).
        simpl in H0. do 2 rewrite (quicksort_impl_enough_fuel _ (length l) n) in H0; try lia.
        le_chain H0; clear H0.
        specialize (H1 (a, l)). simpl in H1. le_chain H1; clear H1.
        specialize (H2 (a, l)). simpl in H2. le_chain H2; clear H2.
        specialize (quicksort_correct r (filter (quicksort_impl_left_predicate rb a) l)) as (? & _).
        apply permutation_length in H0.
        unfold quicksort in H0. rewrite <- (quicksort_impl_enough_fuel _ n) in H0; try lia.
        specialize (quicksort_correct r (filter (quicksort_impl_right_predicate rb a) l)) as (? & _).
        apply permutation_length in H1.
        unfold quicksort in H1. rewrite <- (quicksort_impl_enough_fuel _ n) in H1; try lia.
        rewrite <- H0; clear H0. rewrite <- H1; clear H1.
        rewrite (
          quicksort_cost_enough_fuel
          _
          n
          (length (filter (quicksort_impl_left_predicate rb a) l))
          (filter (quicksort_impl_left_predicate rb a) l)
          ltac:(lia)
          ltac:(lia)
        ).
        rewrite (
          quicksort_cost_enough_fuel
          _
          n
          (length (filter (quicksort_impl_right_predicate rb a) l))
          (filter (quicksort_impl_right_predicate rb a) l)
          ltac:(lia)
          ltac:(lia)
        ).
        specialize (
          H
          (length (filter (quicksort_impl_left_predicate rb a) l))
          ltac:(lia)
          (filter (quicksort_impl_left_predicate rb a) l)
          ltac:(lia)
        ) as ?. le_chain H0; clear H0.
        specialize (
          H
          (length (filter (quicksort_impl_right_predicate rb a) l))
          ltac:(lia)
          (filter (quicksort_impl_right_predicate rb a) l)
          ltac:(lia)
        ) as ?. le_chain H0; clear H0.
        clear H.
        assert (predicate_xor (quicksort_impl_left_predicate rb a) (quicksort_impl_right_predicate rb a)). {
          unfold quicksort_impl_left_predicate, quicksort_impl_right_predicate.
          unfold predicate_xor. intros x. destruct (rb a x); intuition auto.
        }
        specialize (permutation_filter l _ _ H) as ?; clear H.
        apply permutation_length in H0. rewrite length_app in H0.
        replace (fun x => quicksort_impl_right_predicate rb a x)
          with (quicksort_impl_right_predicate rb a) in H0 by auto.
        remember (length (filter (quicksort_impl_left_predicate rb a) l)) as m.
        remember (length (filter (quicksort_impl_right_predicate rb a) l)) as k.
        rewrite H0 in *. repeat (eapply le_trans_rev; [le_chain_l H3 |]).
        assert (length l >= 1). {
          destruct l.
          - destruct n0. auto.
          - simpl. lia.
        }
        rewrite H0 in H. clear n0 Heqm Heqk H0 H3 H4 H5. nia.
Qed.

Section Example.

Compute quicksort Nat.le [4; 4; 6; 1; 0; 40; 3].

End Example.


From mathcomp Require Import all_ssreflect zify.

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

Lemma zagierK x y z : 0 < x -> 0 < z ->
  let zagier t :=
    let: (x, y, z) := t in
    if x < y - z then (x + z.*2, z, y - z - x)
    else if x < y.*2 then (y.*2 - x, y, x + z - y)
    else (x - y.*2, x + z - y, y) in
  zagier (zagier (x, y, z)) = (x, y, z).
Proof.
move=> xP zP /=.
repeat case: leqP => *; congr (_,_,_); lia.
Qed.


(*
Contains the definitions for Z and X spider semantics, their equivalence,
and well formedness
*)

Require Export QuantumLib.Quantum.
Require Import QuantumLib.Proportional.
Require Export QuantumLib.VectorStates.
Require Export QlibTemp.

(* Sparse Matrix Definition *)

Definition Z_semantics (n m : nat) (α : R) : Matrix (2 ^ m) (2 ^ n) :=
  fun x y =>
  match x, y with
  | 0, 0 => match n, m with
                  | 0, 0 => C1 + Cexp α
                  | _, _  => C1
                  end
  | _, _ => if ((x =? 2^m-1) && (y =? 2^n-1)) then Cexp α else C0
  end.

Lemma Z_semantics_0_0 (n m : nat) (α : R) :
  Z_semantics (S n) (S m) α 0%nat 0%nat = 1.
Proof. reflexivity. Qed.

Lemma Z_semantics_max_max (n m : nat) (α : R) :
  Z_semantics (S n) (S m) α (2^(S m) - 1)%nat (2^(S n) - 1)%nat = Cexp α.
Proof.
  unfold Z_semantics.
  simpl.
  destruct (2^m)%nat eqn:Em.
  { contradict Em; apply Nat.pow_nonzero; easy. }
  destruct (2^n)%nat eqn:En.
  { contradict En; apply Nat.pow_nonzero; easy. }
  simpl.
  repeat rewrite Nat.sub_0_r;
  repeat rewrite Nat.add_0_r;
  repeat rewrite <- plus_n_Sm;
  repeat rewrite Nat.eqb_refl.
  reflexivity.
Qed.

Definition X_semantics (n m : nat) (α : R) : Matrix (2 ^ m) (2 ^ n) :=
  (m ⨂ hadamard) × (Z_semantics n m α) × (n ⨂ hadamard).

(* Transpose and Adjoint lemmas *)

Lemma Z_semantics_transpose (n m : nat) (α : R) :
  (Z_semantics n m α) ⊤ = Z_semantics m n α.
Proof.
  unfold Z_semantics.
  unfold transpose.
  prep_matrix_equality.
  destruct x, y.
  1: destruct n, m; reflexivity.
  all: rewrite andb_comm; reflexivity.
Qed.

Lemma Z_semantics_adj (n m : nat) (α : R) :
  (Z_semantics n m α) † = Z_semantics m n (- α).
Proof.
  unfold adjoint.
  unfold Z_semantics.
  prep_matrix_equality.
  destruct x,y.
  1: destruct n,m; try lca;
    rewrite Cconj_plus_distr;
    rewrite Cexp_conj_neg;
    lca.
  all: rewrite andb_comm;
       rewrite (if_dist _ _ _ (Cconj));
       rewrite Cexp_conj_neg;
       rewrite Cconj_0;
       reflexivity.
Qed.

Lemma X_semantics_transpose (n m : nat) (α : R) :
  (X_semantics n m α) ⊤ = X_semantics m n α.
Proof.
  unfold X_semantics.
  rewrite 2 Mmult_transpose.
  rewrite 2 kron_n_transpose.
  rewrite hadamard_st.
  rewrite Mmult_assoc.
  rewrite Z_semantics_transpose.
  reflexivity.
Qed.

Lemma X_semantics_adj (n m : nat) (α : R) :
  (X_semantics n m α)† = X_semantics m n (- α).
Proof.
  unfold X_semantics.
  distribute_adjoint.
  rewrite Z_semantics_adj.
  rewrite 2 kron_n_adjoint; try auto with wf_db.
  rewrite hadamard_sa.
  rewrite Mmult_assoc.
  reflexivity.
Qed.

(* Dirac Notation *)

(* The core of dirac notation *)

Definition bra_ket_mn (bra: Matrix 1 2) (ket : Vector 2) {n m} :
                                          Matrix (2 ^ m) (2 ^ n) :=
  (m ⨂ ket) × (n ⨂ bra).
Transparent bra_ket_mn.

Arguments bra_ket_mn bra ket n m /.

Lemma WF_bra_ket_mn : forall n m bra ket,
  WF_Matrix bra -> WF_Matrix ket -> WF_Matrix (@bra_ket_mn bra ket n m).
Proof.
  intros.
  unfold bra_ket_mn.
  apply WF_mult; restore_dims; apply WF_kron_n; assumption.
Qed.

Definition dirac_spider_semantics
  (bra0 bra1 : Matrix 1 2) (ket0 ket1 : Vector 2)
  (α : R) (n m : nat) : Matrix (2 ^ m) (2 ^ n) :=
    (bra_ket_mn bra0 ket0) .+ (Cexp α) .* (bra_ket_mn bra1 ket1).

Arguments dirac_spider_semantics bra0 bra1 ket0 ket1 α n m /.

Lemma WF_dirac_spider_semantics : forall n m bra0 bra1 ket0 ket1 α,
  WF_Matrix bra0 -> WF_Matrix bra1 -> WF_Matrix ket0 -> WF_Matrix ket1 ->
  WF_Matrix (@dirac_spider_semantics bra0 bra1 ket0 ket1 α n m).
Proof.
  intros.
  unfold dirac_spider_semantics.
  apply WF_plus; restore_dims; try apply WF_scale;
                                   apply WF_bra_ket_mn;
                                   assumption.
Qed.

#[export] Hint Resolve WF_dirac_spider_semantics WF_bra_ket_mn : wf_db.

(* Dirac semantics for a given spider *)

Definition Z_dirac_semantics (n m : nat) (α : R) :=
  dirac_spider_semantics ⟨0∣ ⟨1∣ ∣0⟩ ∣1⟩ α n m.

Definition X_dirac_semantics (n m : nat) (α : R) :=
  dirac_spider_semantics ⟨+∣ ⟨-∣ ∣+⟩ ∣-⟩ α n m.

Arguments Z_dirac_semantics n m α /.
Arguments X_dirac_semantics n m α /.

Ltac unfold_dirac_spider :=
  simpl; unfold dirac_spider_semantics, bra_ket_mn; try (simpl; Msimpl).

(** Working towards equivalence of the two forms of semantics *)

Lemma dirac_spider_X_H_Z : forall n m α,
  X_dirac_semantics n m α =
  m ⨂ hadamard × (Z_dirac_semantics n m α) × (n ⨂ hadamard).
Proof.
  intros.
  simpl.
  restore_dims.
  rewrite Mmult_plus_distr_l.
  rewrite Mmult_plus_distr_r.
  apply Mplus_simplify.
  - repeat rewrite Mmult_assoc.
    restore_dims.
    rewrite kron_n_mult.
    rewrite <- Mmult_assoc.
    rewrite kron_n_mult.
    replace (hadamard × ∣0⟩) with ∣+⟩ by lma.
    replace (⟨0∣ × hadamard) with ⟨+∣ by lma.
    reflexivity.
  - autorewrite with scalar_move_db.
    apply Mscale_simplify; [| lca].
    repeat rewrite Mmult_assoc.
    restore_dims.
    rewrite kron_n_mult.
    rewrite <- Mmult_assoc.
    rewrite kron_n_mult.
    replace (hadamard × ∣1⟩) with ∣-⟩ by lma.
    replace (⟨1∣ × hadamard) with ⟨-∣ by lma.
    reflexivity.
Qed.

Definition braket_0_intermediate (n m : nat) : Matrix (2^m) (2^n) :=
  fun x y => match x, y with
             | 0, 0 => C1
             | _, _ => C0
             end.

Definition braket_1_intermediate (n m : nat) : Matrix (2^m) (2^n) :=
  fun x y => if (x =? 2^m - 1) && (y =? 2^n - 1) then C1 else C0.

Lemma Z_semantics_split_plus : forall (n m : nat) (α : R),
  Z_semantics n m α =
  (braket_0_intermediate n m) .+ Cexp α .* (braket_1_intermediate n m).
Proof.
  assert (contra : forall a, (2^S a - 1 <> 0)%nat).
  { intros; simpl.
    destruct (2^a)%nat eqn:Ea.
    - apply Nat.pow_nonzero in Ea; [destruct Ea | easy].
    - simpl; rewrite <- plus_n_Sm; easy.
  }
  intros.
  unfold braket_0_intermediate; unfold braket_1_intermediate.
  unfold Z_semantics.
  unfold Mplus, scale.
  prep_matrix_equality.
  destruct x, y; simpl.
  - destruct (2^n-1)%nat eqn:En, (2^m-1)%nat eqn:Em.
    + destruct n, m; [lca | destruct (contra m Em) | | ];
                                  destruct (contra n En).
    + destruct n, m; [discriminate | | | ]; lca.
    + destruct n, m; [discriminate | | | ]; lca.
    + destruct n, m; [discriminate | discriminate | | ]; lca.
  - destruct (2^n-1)%nat eqn:En, (2^m-1)%nat eqn:Em.
    + destruct n,m; [lca | destruct (contra m Em) | | ]; destruct (contra n En).
    + destruct n, m; [discriminate | | | ]; lca.
    + destruct n, m; [discriminate | discriminate | |]; destruct (y =? n0); lca.
    + destruct n, m; [discriminate | | | lca]; destruct (y =? n0); lca.
  - destruct (2^n-1)%nat eqn:En, (2^m-1)%nat eqn:Em; [lca | | lca | ];
                                               destruct (_ =? _); lca.
  - destruct (2^n-1)%nat eqn:En, (2^m-1)%nat eqn:Em; [lca | | lca | ];
                                        repeat destruct (_ =? _); lca.
Qed.

Lemma big_bra_0_0_0 : forall n, (n ⨂ (bra 0)) 0%nat 0%nat = C1.
Proof.
  intros.
  induction n; [reflexivity | ].
  rewrite kron_n_assoc; [ | auto with wf_db].
  unfold kron.
  rewrite 2 Nat.div_0_l; try apply Nat.pow_nonzero; try easy.
  rewrite 2 Nat.mod_0_l; try apply Nat.pow_nonzero; try easy.
  rewrite IHn.
  rewrite Cmult_1_r.
  unfold bra.
  unfold adjoint.
  simpl.
  lca.
Qed.

Lemma big_bra_S_r : forall n i j, ((S n) ⨂ bra 0) i (S j) = C0.
Proof.
  induction n.
  - simpl; rewrite kron_1_l; [ | auto with wf_db ].
    intros; unfold bra; simpl; unfold adjoint; unfold qubit0.
    destruct i,j; lca.
  - intros.
    rewrite kron_n_assoc; [| auto with wf_db].
    unfold kron.
    destruct (S j mod 2 ^S n) eqn:En.
    + destruct (Nat.mod_divides (S j) (2 ^ S n));
                 [apply Nat.pow_nonzero; auto |].
      destruct (H En).
      rewrite H1.
      replace (2 ^ S n * x / 2 ^ S n)%nat with x.
      * unfold bra; simpl.
        unfold adjoint.
        simpl.
        destruct x.
        -- rewrite mult_0_r in H1.
           discriminate H1.
        -- destruct (i / (1 ^ n + 0))%nat.
           ++ simpl.
              destruct x; lca.
           ++ simpl.
              destruct x; lca.
      * rewrite mult_comm.
        rewrite Nat.divide_div_mul_exact.
        -- rewrite Nat.div_same; [lia | ].
           apply Nat.pow_nonzero; easy.
        -- apply Nat.pow_nonzero; easy.
        -- apply Nat.divide_refl.
    + rewrite IHn.
      lca.
Qed.

Lemma big_bra_S_l : forall n i j, (n ⨂ bra 0) (S i) j = C0.
Proof.
  intros.
  assert (WF : WF_Matrix (n ⨂ bra 0)).
  { auto with wf_db. }
  apply WF.
  left.
  rewrite Nat.pow_1_l.
  induction i; auto.
Qed.

Lemma big_ket_0_0_0 : forall n, (n ⨂ (ket 0)) 0%nat 0%nat = C1.
Proof.
  intros.
  induction n; [reflexivity | ].
  rewrite kron_n_assoc; [ | auto with wf_db].
  unfold kron.
  rewrite 2 Nat.div_0_l; try apply Nat.pow_nonzero; try easy.
  rewrite 2 Nat.mod_0_l; try apply Nat.pow_nonzero; try easy.
  rewrite IHn.
  rewrite Cmult_1_r.
  reflexivity.
Qed.

Lemma big_ket_S_r : forall n i j, (n ⨂ ket 0) i (S j) = C0.
Proof.
  intros.
  assert (WF : WF_Matrix (n ⨂ ket 0)).
  { auto with wf_db. }
  apply WF.
  right.
  rewrite Nat.pow_1_l.
  induction j; auto.
Qed.

Lemma big_ket_S_l : forall n i j, (S n ⨂ ket 0) (S i) j = C0.
Proof.
  induction n.
  - intros. simpl.
    rewrite kron_1_l; [ | auto with wf_db ].
    unfold ket.
    unfold qubit0; simpl.
    destruct i, j;lca.
  - intros.
    rewrite kron_n_assoc; [ | auto with wf_db ].
    unfold kron.
    rewrite Nat.pow_1_l.
    rewrite Nat.mod_1_r.
    rewrite Nat.div_1_r.
    destruct (S i mod 2 ^ S n) eqn:En.
    + destruct (Nat.mod_divides (S i) (2^S n)); [apply Nat.pow_nonzero; auto |].
      destruct H; [assumption |].
      rewrite H.
      rewrite mult_comm.
      rewrite Nat.divide_div_mul_exact;
        [ | apply Nat.pow_nonzero; auto | apply Nat.divide_refl ].
      rewrite Nat.div_same; [ | apply Nat.pow_nonzero; auto].
      rewrite Nat.mul_1_r.
      destruct x; [rewrite mult_0_r in H; discriminate H |].
      unfold ket; simpl.
      destruct x, j; lca.
    + rewrite IHn.
      lca.
Qed.

Lemma braket_sem_0_intermediate : forall (n m : nat),
  (n ⨂ ket 0) × (m ⨂ bra 0) = braket_0_intermediate m n.
Proof.
  intros.
  destruct n,m; prep_matrix_equality.
  - destruct x,y; lca.
  - unfold Mmult; simpl.
    destruct x,y;
    replace (m ⨂ bra 0 ⊗ bra 0) with ((S m) ⨂ bra 0) by reflexivity.
    + rewrite big_bra_0_0_0.
      lca.
    + rewrite big_bra_S_r.
      lca.
    + rewrite big_bra_0_0_0.
      lca.
    + rewrite big_bra_S_r.
      lca.
  - unfold Mmult; rewrite Nat.pow_1_l; simpl.
    destruct x,y;
    replace (n ⨂ ket 0 ⊗ ket 0) with ((S n) ⨂ ket 0) by reflexivity.
    + rewrite big_ket_0_0_0.
      lca.
    + rewrite big_ket_0_0_0.
      lca.
    + rewrite big_ket_S_l.
      lca.
    + rewrite big_ket_S_l.
      lca.
  - unfold Mmult; rewrite Nat.pow_1_l; simpl; rewrite Cplus_0_l.
    replace (n ⨂ ket 0 ⊗ ket 0) with ((S n) ⨂ ket 0) by reflexivity;
    replace (m ⨂ bra 0 ⊗ bra 0) with ((S m) ⨂ bra 0) by reflexivity.
    destruct x,y.
    + rewrite big_ket_0_0_0; rewrite big_bra_0_0_0.
      lca.
    + rewrite big_bra_S_r.
      lca.
    + rewrite big_ket_S_l.
      lca.
    + rewrite big_ket_S_l.
      lca.
Qed.

Lemma big_ket_1_max_0 : forall n, (n ⨂  ∣1⟩) (2 ^ n - 1)%nat 0%nat = C1.
Proof.
  induction n.
  - lca.
  - rewrite kron_n_assoc; [| auto with wf_db].
    unfold kron.
    simpl.
    rewrite <- Nat.add_sub_assoc.
    + replace (0 / 1 ^ n)%nat with 0%nat
        by (rewrite Nat.pow_1_l; rewrite Nat.div_1_r; reflexivity).
      replace (0 mod 1^n) with 0%nat by (rewrite Nat.pow_1_l; reflexivity).
      replace ((2 ^ n + (2 ^ n + 0 - 1)) / 2 ^ n)%nat with 1%nat.
      * replace ((2 ^ n + (2 ^ n + 0 - 1)) mod 2 ^ n)%nat with (2^n-1)%nat.
        -- rewrite IHn; lca.
        -- rewrite Nat.add_mod; [| apply Nat.pow_nonzero; auto].
           ++ rewrite plus_0_r.
              rewrite Nat.mod_same; [| apply Nat.pow_nonzero; auto].
              rewrite plus_0_l.
              rewrite Nat.mod_mod; [| apply Nat.pow_nonzero; auto].
              destruct n.
              ** reflexivity.
              ** rewrite Nat.mod_small; [reflexivity|].
                 destruct (2 ^ S n)%nat eqn:E.
                 --- destruct (Nat.pow_nonzero 2 (S n)); [auto |apply E].
                 --- simpl.
                     rewrite Nat.sub_0_r.
                     constructor.
      * rewrite plus_0_r.
        replace ((2 ^ n + (2 ^ n - 1)) / 2 ^ n)%nat
          with (((1 * 2 ^ n) + (2 ^ n - 1)) / 2 ^ n)%nat.
        -- rewrite Nat.div_add_l; [| apply Nat.pow_nonzero; auto].
           rewrite Nat.div_small; [reflexivity|].
           destruct (2^n)%nat eqn:E.
           ++ destruct (Nat.pow_nonzero 2 n); [auto | apply E].
           ++ simpl; rewrite Nat.sub_0_r.
              auto.
        -- rewrite mult_1_l.
           reflexivity.
    + rewrite plus_0_r.
      rewrite <- (Nat.pow_1_l n).
      replace (S (1 ^ n)) with 2%nat.
      * apply Nat.pow_le_mono_l.
        auto.
      * rewrite Nat.pow_1_l; reflexivity.
Qed.

Lemma big_bra_1_0_max : forall n, (n ⨂ ⟨1∣) 0%nat (2 ^ n - 1)%nat = C1.
Proof.
  induction n.
  - lca.
  - rewrite kron_n_assoc; [| auto with wf_db].
    unfold kron.
    simpl.
    rewrite <- Nat.add_sub_assoc.
    + replace (0 / 1 ^ n)%nat with 0%nat
        by (rewrite Nat.pow_1_l; rewrite Nat.div_1_r; reflexivity).
      replace (0 mod 1^n) with 0%nat by (rewrite Nat.pow_1_l; reflexivity).
      replace ((2 ^ n + (2 ^ n + 0 - 1)) / 2 ^ n)%nat with 1%nat.
      * replace ((2 ^ n + (2 ^ n + 0 - 1)) mod 2 ^ n)%nat with (2^n-1)%nat.
        -- rewrite IHn; lca.
        -- rewrite Nat.add_mod; [| apply Nat.pow_nonzero; auto].
           ++ rewrite plus_0_r.
              rewrite Nat.mod_same; [| apply Nat.pow_nonzero; auto].
              rewrite plus_0_l.
              rewrite Nat.mod_mod; [| apply Nat.pow_nonzero; auto].
              destruct n.
              ** reflexivity.
              ** rewrite Nat.mod_small; [reflexivity|].
                 destruct (2 ^ S n)%nat eqn:E.
                 --- destruct (Nat.pow_nonzero 2 (S n)); [auto |apply E].
                 --- simpl.
                     rewrite Nat.sub_0_r.
                     constructor.
      * rewrite plus_0_r.
        replace ((2 ^ n + (2 ^ n - 1)) / 2 ^ n)%nat
           with (((1 * 2 ^ n) + (2 ^ n - 1)) / 2 ^ n)%nat.
        -- rewrite Nat.div_add_l; [| apply Nat.pow_nonzero; auto].
           rewrite Nat.div_small; [reflexivity|].
           destruct (2^n)%nat eqn:E.
           ++ destruct (Nat.pow_nonzero 2 n); [auto | apply E].
           ++ simpl; rewrite Nat.sub_0_r.
              auto.
        -- rewrite mult_1_l.
           reflexivity.
    + rewrite plus_0_r.
      rewrite <- (Nat.pow_1_l n).
      replace (S (1 ^ n)) with 2%nat.
      * apply Nat.pow_le_mono_l.
        auto.
      * rewrite Nat.pow_1_l; reflexivity.
Qed.

Lemma big_ket_1_n_S : forall n i j, (n ⨂  ∣1⟩) i (S j) = C0.
Proof.
  induction n.
  - intros.
    simpl.
    destruct i.
    + lca.
    + unfold I.
      replace (S i <? 1) with false; [| reflexivity].
      rewrite andb_false_r.
      reflexivity.
  - intros.
    simpl.
    unfold kron.
    rewrite Nat.div_1_r.
    rewrite IHn.
    lca.
Qed.

Definition big_bra_sem (n : nat) : Matrix 1 (2 ^ n) :=
  fun x y =>
  if (y =? 2^n-1) && (x =? 0) then C1 else C0.

Opaque Nat.div.
Opaque Nat.modulo.

Lemma big_bra_to_sem : forall n, (n ⨂ (bra 1)) = big_bra_sem n.
Proof.
  induction n.
  - prep_matrix_equality.
    destruct x,y.
    + lca.
    + lca.
    + lca.
    + unfold big_bra_sem.
      rewrite andb_false_r.
      simpl.
      unfold I.
      rewrite andb_false_r.
      reflexivity.
  - prep_matrix_equality.
    simpl.
    rewrite IHn.
    unfold kron.
    destruct (y =? 2^(S n) - 1) eqn:Ex.
    + unfold big_bra_sem.
      rewrite Ex.
      apply Nat.eqb_eq in Ex.
      rewrite Ex.
      rewrite Nat.mod_1_r.
      rewrite Nat.div_1_r.
      destruct y.
      * destruct (2^n)%nat eqn:En.
        -- contradict En.
           apply Nat.pow_nonzero.
           easy.
        -- replace ((2 ^ S n - 1) / 2)%nat with (2^n - 1)%nat.
           ++ rewrite En.
              rewrite Nat.eqb_refl.
              replace ((2 ^ S n - 1) mod 2)%nat with 1%nat.
              ** destruct x; lca.
              ** replace (2 ^ S n)%nat with (2^n + 2^n)%nat.
                 --- destruct (2 ^ n)%nat eqn:E2n.
                     +++ contradict E2n.
                         apply Nat.pow_nonzero; easy.
                     +++ rewrite <- plus_n_Sm.
                         replace (S (S n1 + n1) - 1)%nat
                            with (S (n1 + n1))%nat by reflexivity.
                         rewrite (double_mult n1).
                         rewrite <- (plus_0_l (2*n1)).
                         replace (S (0 + 2 * n1))%nat
                            with (1 + 2 * n1)%nat by reflexivity.
                         rewrite Nat.add_mod; [| easy].
                         rewrite mult_comm.
                         rewrite Nat.mod_mul; [| easy].
                         reflexivity.
                 --- simpl.
                     rewrite plus_0_r.
                     lia.
           ++ replace (2 ^ S n)%nat with (2 * (2 ^ n))%nat.
              ** destruct (2^n)%nat.
                 --- reflexivity.
                 --- contradict Ex.
                     destruct (2^S n)%nat eqn:Esn.
                     +++ contradict Esn.
                         apply Nat.pow_nonzero; easy.
                     +++ destruct n2.
                         *** contradict Esn.
                             simpl.
                             destruct (2^n)%nat.
                             ---- easy.
                             ---- destruct n2.
                                  ++++ easy.
                                  ++++ simpl.
                                       easy.
                         *** easy.
              ** reflexivity.
      * Opaque Nat.div.
        Opaque Nat.modulo.
        replace ((2 ^ S n - 1) / 2)%nat with (2^n - 1)%nat.
        replace ((2 ^ S n - 1) mod 2)%nat with 1%nat.
        -- rewrite Nat.eqb_refl.
           destruct x; lca.
        -- simpl.
           rewrite plus_0_r.
           destruct (2 ^ n)%nat eqn:En.
           ++ contradict En.
              ** apply Nat.pow_nonzero; easy.
           ++ simpl.
              rewrite <- plus_n_Sm.
              rewrite Nat.sub_0_r.
              rewrite double_mult.
              replace (S (2 * n0))%nat with (1 + (2 * n0))%nat by reflexivity.
              rewrite mult_comm.
              rewrite Nat.add_mod; [| easy].
              rewrite Nat.mod_mul; [| easy].
              reflexivity.
        -- simpl.
           rewrite plus_0_r.
           destruct (2 ^ n)%nat.
           ++ reflexivity.
           ++ simpl.
              rewrite Nat.sub_0_r.
              rewrite Nat.sub_0_r.
              rewrite <- plus_n_Sm.
              rewrite double_mult.
              replace (S (2 * n0))%nat with ((1 + (2 * n0)))%nat by reflexivity.
              rewrite plus_comm.
              rewrite mult_comm.
              rewrite Nat.div_add_l; [| easy].
              rewrite plus_comm.
              reflexivity.
    + unfold big_bra_sem.
      rewrite Ex.
      simpl.
      rewrite Nat.mod_1_r.
      Transparent Nat.div.
      destruct (Nat.divmod y 1 0 1) eqn:Edm.
      assert (Hy : (y = 2 * (y / 2) + y mod 2)%nat).
      { apply Nat.div_mod; lia. } (* Nat.div_mod_eq works in 8.14 on *)
      destruct (y/2 =? 2^n-1) eqn:Ey2.
      * destruct (y mod 2 =? 1) eqn:Eym.
        -- apply Nat.eqb_eq in Eym, Ey2.
           rewrite Ey2, Eym in Hy.
           replace (2 * (2 ^ n - 1) + 1)%nat with (2 ^ S n - 1)%nat in Hy.
           ++ rewrite Hy in Ex.
              rewrite Nat.eqb_refl in Ex.
              discriminate.
           ++ simpl.
              rewrite 2 plus_0_r.
              rewrite <- plus_assoc.
              rewrite <- plus_n_Sm.
              rewrite plus_0_r.
              destruct (2 ^ n)%nat eqn:En.
              ** contradict En.
                 apply Nat.pow_nonzero; easy.
              ** simpl. lia.
        -- destruct (y mod 2).
           ++ lca.
           ++ destruct n2.
              ** discriminate.
              ** lca.
      * lca.
Qed.

Definition big_ket_sem (n : nat) : Matrix (2 ^ n) 1 :=
  fun x y =>
  if (x =? 2^n-1) && (y =? 0) then C1 else C0.

Lemma big_ket_sem_big_bra_sem_transpose : forall n,
  big_ket_sem n = (big_bra_sem n) ⊤.
Proof.
  intros.
  unfold big_ket_sem, big_bra_sem.
  unfold transpose.
  reflexivity.
Qed.

Lemma big_ket_to_sem : forall n, (n ⨂ (ket 1)) = big_ket_sem n.
Proof.
  intros.
  rewrite <- (transpose_involutive _ _ _).
  rewrite kron_n_transpose.
  replace ((ket 1)⊤) with (bra 1).
  - rewrite big_ket_sem_big_bra_sem_transpose.
    f_equal.
    + rewrite Nat.pow_1_l.
      easy.
    + apply big_bra_to_sem.
  - rewrite ket1_transpose_bra1.
    reflexivity.
Qed.

Lemma braket_sem_1_intermediate : forall n m : nat,
  n ⨂ ket 1 × m ⨂ bra 1 = braket_1_intermediate m n.
Proof.
  intros.
  rewrite big_bra_to_sem.
  rewrite big_ket_to_sem.
  prep_matrix_equality.
  unfold braket_1_intermediate, big_ket_sem, big_bra_sem, Mmult.
  rewrite Nat.pow_1_l; simpl.
  rewrite Cplus_0_l.
  destruct (x =? 2^n-1), (y =? 2^m-1); lca.
Qed.

Lemma Z_semantics_equiv : forall n m α,
  Z_semantics n m α = Z_dirac_semantics n m α.
Proof.
  intros.
  simpl.
  replace (m ⨂ ∣0⟩ × n ⨂ ⟨0∣)
     with (braket_0_intermediate n m).
  replace (m ⨂ ∣1⟩ × n ⨂ ⟨1∣)
     with (braket_1_intermediate n m).
  apply Z_semantics_split_plus.
  rewrite braket_sem_1_intermediate; auto.
  rewrite braket_sem_0_intermediate; auto.
Qed.

Lemma X_semantics_equiv : forall n m α,
  X_semantics n m α = X_dirac_semantics n m α.
Proof.
  intros.
  rewrite dirac_spider_X_H_Z.
  unfold X_semantics.
  Msimpl.
  restore_dims.
  rewrite Z_semantics_equiv.
  reflexivity.
Qed.

Lemma WF_Z_semantics : forall n m α, WF_Matrix (Z_semantics n m α).
Proof.
  intros; rewrite Z_semantics_equiv;
  apply WF_dirac_spider_semantics; auto with wf_db.
Qed.

Lemma WF_X_semantics : forall n m α, WF_Matrix (X_semantics n m α).
Proof.
  intros; rewrite X_semantics_equiv;
  apply WF_dirac_spider_semantics; auto with wf_db.
Qed.

#[export] Hint Resolve WF_Z_semantics WF_X_semantics : wf_db.


(*

Ideas:
I'm borrowing generously from https://xavierleroy.org/talks/compilation-agay.pdf and
https://github.com/ajcave/code/blob/master/normalization/weak-head-bigstep-cbn.agda

But CBV.

*)

(* Trying to formalize the normalization of closed system F terms *)
Require Import List Arith Bool.

Import ListNotations.

Definition name := nat.

(* Don't really need de Bruijn for types: *)
(* We just do the "textbook logic book" trick and add a bunch of free var assumptions. *)
Inductive type :=
| Tvar : name -> type
| Arrow : type -> type -> type
| Forall : name -> type -> type.

Fixpoint is_free (n : name) (t : type) :=
  match t with
  | Tvar k => if k =? n then true else false
  | Arrow t1 t2 => (is_free n t1) || (is_free n t2)
  | Forall k t1 =>
    if n =? k then false else
      (is_free n t1)
  end.

(* Boring ol' shadowing substitution *)
Fixpoint ty_subst (n : name) (t u : type) :=
  match t with
  | Tvar k => if k =? n then u else Tvar k
  | Arrow t1 t2 => Arrow (ty_subst n t1 u) (ty_subst n t2 u)
  | Forall k t1 =>
    if n =? k then t else
    Forall k (ty_subst n t1 u)
  end.

(* No explicit type abstractions or applications: we don't really care about type-checking. *)
Inductive term :=
| Var : nat -> term
| App : term -> term -> term
| Abs : term -> term.

(* An evaluation context is either empty, or a pair of a term and an
eval context, with the remainder of the bindings. *)
Inductive eval_ctxt :=
| Empty_ctxt : eval_ctxt
| Push_ctxt : term -> eval_ctxt -> eval_ctxt -> eval_ctxt.

Notation "[::]" := Empty_ctxt.
Inductive value := VAbs : term -> eval_ctxt -> value.

Fixpoint nth_error (ectx : eval_ctxt) (n : nat) : option value :=
  match ectx with
  | Empty_ctxt => None
  | Push_ctxt t e cs =>
    match n with
    | 0 => Some (VAbs t e)
    | S m => nth_error cs m
    end
  end.

Definition cons_ctxt (v : value) (e : eval_ctxt) : eval_ctxt :=
  match v with
  | VAbs t e' => Push_ctxt t e' e
  end.

Notation "v ::: e" := (cons_ctxt v e)(at level 30, right associativity).

Inductive TmEval : eval_ctxt -> term -> value -> Prop :=
| Eval_var : forall ectx n v,
    nth_error ectx n = Some v ->
    TmEval ectx (Var n) v
(* Weak reduction *)
| Eval_abs : forall ectx t, TmEval ectx (Abs t) (VAbs t ectx)
(* Call by value *)
| Eval_app : forall ectx ectx' t t' u v v',
    TmEval ectx t (VAbs t' ectx') ->
    TmEval ectx u v ->
    TmEval (v ::: ectx') t' v' ->
    TmEval ectx (App t u) v'
.

Hint Constructors TmEval.

Definition context := list type.

Definition is_free_ctxt : name -> context -> bool :=
  fun n ctxt =>
    List.existsb (fun ty => is_free n ty) ctxt.

Fixpoint is_bound n ty :=
  match ty with
  | Tvar _ => false
  | Arrow ty1 ty2 =>
    is_bound n ty1 || is_bound n ty2
  | Forall m ty' =>
    (m =? n) || is_bound n ty'
  end.

(* true iff no bound variable if ty1 is free in ty2 *)
Definition no_capture ty1 ty2 :=
    forall n, is_bound n ty1 = true -> is_free n ty2 = false.

(* Type checking is undecidable, but who cares? *)
Inductive TyRel : context -> term -> type -> Prop :=
| TyRel_var : forall ctxt n ty,
    List.nth_error ctxt n = Some ty ->
    TyRel ctxt (Var n) ty
| TyRel_abs : forall ctxt ty1 ty2 t,
    TyRel (ty1::ctxt) t ty2 ->
    TyRel ctxt (Abs t) (Arrow ty1 ty2)
| TyRel_app : forall ctxt ty1 ty2 t u,
    TyRel ctxt t (Arrow ty1 ty2) ->
    TyRel ctxt u ty1 ->
    TyRel ctxt (App t u) ty2
| TyRel_ty_abs : forall ctxt n ty t,
    is_free_ctxt n ctxt = false ->
    TyRel ctxt t ty ->
    TyRel ctxt t (Forall n ty)
| TyRel_ty_app : forall ctxt n ty1 ty2 t,
    no_capture ty1 ty2 -> (* very required! *)
    TyRel ctxt t (Forall n ty1) ->
    TyRel ctxt t (ty_subst n ty1 ty2) (* No tags for substs, because they only matter operationally. *)
.

(* What we really care about: a term normalizes in a context. *)
Definition norm (ectx : eval_ctxt) (t : term) :=
  exists v, TmEval ectx t v.

(* We actually care about *pairs* of predicates, one for term (and
closures) and one for just values *)
Record comp_pair :=
  { comp_term : eval_ctxt -> term -> Prop;
    comp_val : value -> Prop }.

Definition valuation := name -> comp_pair.

Definition extend (f : valuation)(v : name)(P : comp_pair) : valuation :=
  fun var => if var =? v then P else f var.

(* This is the "usual" computability predicates stuff, but for normal forms in a given strategy.*)
Record computable (P : comp_pair) :=
  {
  comp_norm : forall ectx t, comp_term P ectx t -> norm ectx t;
  comp_val_of_term : forall ectx t v, TmEval ectx t v -> comp_term P ectx t -> comp_val P v;
  comp_term_of_val : forall ectx t v, TmEval ectx t v -> comp_val P v -> comp_term P ectx t
  }.

Definition norm_pred := {| comp_term := norm; comp_val := fun _ => True |}.

(* A good sanity check, but we use it for dummy values later *)
Lemma computable_norm : computable norm_pred.
Proof.
  constructor; simpl; auto.
  intros; eexists; eauto.
Qed.

(* Amusingly, we could probably use empty sets, and have a nice empty
interpretation for types without values, like Forall X.X...

The "usual" proof has neutral terms in all types.
*)

Hint Resolve computable_norm.

(* The usual interpretation of types in system F with computable predicates *)
(* Though this is the "positive" version, where a term at arrow type is computable
   iff its *values* are. *)
Fixpoint interp_term (ty : type) : valuation -> eval_ctxt -> term -> Prop :=
  fun val =>
    match ty with
    | Tvar v => comp_term (val v)
    | Arrow t1 t2 =>
      fun ectx t =>
        exists t' ectx',
          TmEval ectx t (VAbs t' ectx') /\
        forall v,
          interp_val t1 val v ->
          interp_term t2 val (v ::: ectx') t'
    | Forall name ty =>
      fun ectx t =>
        forall P, computable P -> interp_term ty (extend val name P) ectx t
    end
with interp_val (ty : type) : valuation -> value -> Prop :=
       fun val =>
         match ty with
         | Tvar v => comp_val (val v)
         | Arrow t1 t2 =>
           fun v =>
             match v with
             | VAbs t env =>
               forall v,
                 interp_val t1 val v ->
                 interp_term t2 val (v ::: env) t
             end
         | Forall name ty =>
           fun v =>
             forall P, computable P -> interp_val ty (extend val name P) v
         end
.

Definition computable_valuation (val : valuation) :=
  forall v, computable (val v).

Lemma computable_valuation_extend : forall n val P,
    computable_valuation val ->
    computable P -> computable_valuation (extend val n P).
Proof.
  unfold extend, computable_valuation.
  intros n ? ? ? ? m.
  case (m =? n); auto.
Qed.

Hint Resolve computable_valuation_extend.

(* Surprisingly useful. This is a bit sad, since we don't really want
   to rely on it in the non-deterministic setting, or if confluence
   fails. *)
Lemma eval_det : forall ectx t v v',
    TmEval ectx t v -> TmEval ectx t v' -> v = v'.
Proof.
  intros t ectx v v' H; revert v'; induction H; intros v2 H'; inversion H'; subst; auto; try congruence.
  assert (v = v0) by firstorder.
  subst v.
  assert (H2 : VAbs t' ectx' = VAbs t'0 ectx'0) by firstorder.
  inversion H2; subst.
  now auto.
Defined. (* We use this in the WF proofs *)

Hint Resolve eval_det.

(* The crucial Girard trick: interpretations satisfy the computability conditions. *)
Lemma computable_interp_term : forall ty val,
    computable_valuation val ->
    computable {| comp_term := interp_term ty val; comp_val := interp_val ty val |} .
Proof.
  induction ty.
  simpl; intros val H; constructor; simpl; intros; try (destruct (H n); now eauto).
  - intros; constructor; simpl.
    + intros ectx t [t' [ectx' [eval_t _]]].
      eexists; now eauto.
    + intros ectx t v eval_t [t' [ectx' [eval_t2 comp_t']]].
      assert (v = VAbs t' ectx') by eauto; subst.
      auto.
    + intros ectx t v; destruct v as [t' ectx']; intros eval_t comp_t'.
      eexists; now eauto.
  - intros; constructor; simpl.
    + pose (P := norm_pred).
      assert (h := computable_norm : computable P).
      intros ectx t comp_t.
      assert (comp_t1 := comp_t _ h).
      assert (comp_ext : computable_valuation (extend val n P)) by auto.
      assert (comp_t2 := IHty _ comp_ext).
      destruct comp_t2; simpl in *.
      now auto.
    + intros ectx t v eval_t h P comp_p.
      assert (h0 : computable_valuation (extend val n P)) by auto.
      assert (comp_ext := IHty _ h0).
      destruct comp_ext; simpl in *.
      now eauto.
    + intros ectx t v eval_t h P comp_p.
      assert (h0 : computable_valuation (extend val n P)) by auto.
      assert (comp_ext := IHty _ h0).
      destruct comp_ext; simpl in *.
      now eauto.
Qed.

Hint Resolve computable_interp_term.

Check nth_error.

Definition ctxt_val : valuation -> eval_ctxt -> context -> Prop :=
  fun val ectx ctx =>
    forall n ty,
      List.nth_error ctx n = Some ty ->
      exists v,
      nth_error ectx n = Some v /\
      interp_val ty val v.

(* The notion of equality for computable pairs. Probably we should use
   setoids here, a lot of pain later because of our laziness...*)
Definition equiv_comp_pair P P' :=
  (forall ectx t,
      comp_term P ectx t <-> comp_term P' ectx t)
  /\
  (forall v,
      comp_val P v <-> comp_val P' v)
.

Lemma equiv_comp_pair_sym : forall P P',
    equiv_comp_pair P P' -> equiv_comp_pair P' P.
Proof.
  intros P P'; unfold equiv_comp_pair; firstorder.
Qed.

Lemma equiv_comp_pair_refl : forall P,
    equiv_comp_pair P P.
Proof.
  intros P; unfold equiv_comp_pair; firstorder.
Qed.

Hint Resolve equiv_comp_pair_refl.

Lemma extend_equiv : forall val val' n P,
    (forall m, equiv_comp_pair (val m) (val' m)) ->
    forall k, equiv_comp_pair (extend val n P k) (extend val' n P k).
Proof.
  intros.
  unfold extend.
  destruct (k =? n); simpl; auto.
Qed.

Lemma ty_subst_ext : forall ty val val',
    (forall n, equiv_comp_pair (val n) (val' n)) ->
    (forall ectx t, interp_term ty val ectx t -> interp_term ty val' ectx t)
    /\
    (forall v, interp_val ty val v -> interp_val ty val' v).
Proof.
  induction ty; intros val val' H; split; simpl; intros; try apply H; auto.
  - destruct H0 as [t' [ectx' [eval_t comp_t]]].
    exists t', ectx'; split; auto.
    intros; eapply IHty2; [now auto | apply comp_t].
    eapply IHty1; intros; [apply equiv_comp_pair_sym; now auto| now auto].
  - destruct v; intros; eapply IHty2; eauto.
    apply H0.
    eapply IHty1; [intros; apply equiv_comp_pair_sym; eauto| now eauto].
  - eapply IHty; [intros; apply extend_equiv; eauto| now auto].
  - eapply IHty; [intros; apply extend_equiv; eauto| now auto].
Qed.

(* Crucial to deal with our lack of DB in types.
   You think you're simplifing your life at first...
*)
Lemma is_not_free_extend : forall ty n val P,
    is_free n ty = false ->
    (forall ectx t,
      interp_term ty val ectx t <->
      interp_term ty (extend val n P) ectx t)
    /\
    (forall v,
        interp_val ty val v <->
        interp_val ty (extend val n P) v)
.
Proof.
  induction ty; simpl; intros.
  - unfold extend; assert (eq := Nat.eqb_eq n n0).
    destruct (n =? n0); split; intros; try congruence; reflexivity; eauto.
  - rewrite orb_false_iff in *.
    destruct H.
    split; [split; intro h; destruct h as [t' [ectx' [h1 h2]]]; exists t', ectx'; split; eauto; intros v| ].
    + edestruct IHty1; edestruct IHty2; eauto.
      rewrite<- H3.
      rewrite<- H2.
      eauto.
    + edestruct IHty1; edestruct IHty2; eauto.
      rewrite H3.
      rewrite H2.
      eauto.
    + intros v; destruct v.
      split; intros h v; edestruct IHty1; edestruct IHty2; eauto.
      -- rewrite<- H2.
         rewrite<- H3.
         eauto.
      -- rewrite H2.
         rewrite H3.
         now eauto.
  - assert (eq := Nat.eqb_eq n0 n).
    destruct (n0 =? n).
    assert (n0 = n) by firstorder; subst.
    + assert (forall P0 k,
                 equiv_comp_pair
                   (extend val n P0 k)
                   (extend (extend val n P) n P0 k)).
      {
        unfold extend; intros; destruct (k =? n); simpl;
          apply equiv_comp_pair_refl; eauto.
      }
      split; split; intros; eapply ty_subst_ext; intros;
        try apply H0; try (apply equiv_comp_pair_sym; apply H0); try apply H1; eauto. (* Maybe first [apply ...] here? *)
    + assert (forall P0 k,
                 equiv_comp_pair
                   (extend (extend val n0 P) n P0 k)
                   (extend (extend val n P0) n0 P k)).
      {
        unfold extend; intros.
        assert (eq' := Nat.eqb_eq k n).
        assert (eq'' := Nat.eqb_eq k n0).
        destruct (k =? n); destruct (k =? n0); simpl; try apply equiv_comp_pair_refl.
        assert (n0 = n) by (firstorder; congruence).
        exfalso.
        assert (false = true) by (apply eq; eauto).
        congruence.
      }
      split; split; intros;
        try (eapply ty_subst_ext; intros;
             apply equiv_comp_pair_sym; apply H0; apply IHty; now eauto).
      -- eapply ty_subst_ext; intros; try apply equiv_comp_pair_sym; try apply H0.
         apply IHty; eauto.
      -- assert (interp_term ty (extend (extend val n P0) n0 P) ectx t) by (eapply ty_subst_ext; intros; try apply H0; eauto).
         revert H3.
         apply IHty; eauto.
      -- eapply ty_subst_ext; intros; try apply equiv_comp_pair_sym; try apply H0; eauto.
         apply IHty; eauto.
      -- assert (interp_val ty (extend (extend val n P0) n0 P) v) by (eapply ty_subst_ext; intros; try apply H0; eauto).
         revert H3.
         apply IHty; eauto.
         (* WTF *)
         Unshelve.
         auto.
         auto.
         auto.
         auto.
         auto.
         auto.
         auto.
         auto.
Qed.

Lemma no_capture_arrow1 : forall ty1_1 ty1_2 ty2, no_capture (Arrow ty1_1 ty1_2) ty2 -> no_capture ty1_1 ty2.
Proof.
  unfold no_capture; simpl.
  setoid_rewrite orb_true_iff; auto.
Qed.

Hint Resolve no_capture_arrow1.

Lemma no_capture_arrow2 : forall ty1_1 ty1_2 ty2, no_capture (Arrow ty1_1 ty1_2) ty2 -> no_capture ty1_2 ty2.
Proof.
  unfold no_capture; simpl.
  setoid_rewrite orb_true_iff; auto.
Qed.

Hint Resolve no_capture_arrow2.

Lemma no_capture_forall : forall n ty1 ty2, no_capture (Forall n ty1) ty2 -> no_capture ty1 ty2.
Proof.
  unfold no_capture; simpl.
  setoid_rewrite orb_true_iff; auto.
Qed.

Hint Resolve no_capture_forall.

Lemma no_capture_forall_free : forall n ty1 ty2,
    no_capture (Forall n ty1) ty2 ->
    is_free n ty2 = false.
Proof.
  unfold no_capture; intros n ty1 ty2 H; generalize (H n); simpl.
  rewrite Nat.eqb_refl; simpl; auto.
Qed.

Hint Resolve no_capture_forall_free.

(* And the magical lemma to swap substitution and interpretation. Also painful. *)
Lemma ty_subst_extend : forall ty1 n ty2 val,
    let interp_ty2 := {| comp_term := interp_term ty2 val; comp_val := interp_val ty2 val |} in
    no_capture ty1 ty2 ->
    (forall ectx t, interp_term (ty_subst n ty1 ty2) val ectx t <-> interp_term ty1 (extend val n interp_ty2) ectx t)
    /\
    (forall v, interp_val (ty_subst n ty1 ty2) val v <-> interp_val ty1 (extend val n interp_ty2) v)
.
Proof.
  induction ty1; unfold extend in *; simpl; intros m; intros.
  - simpl; destruct (n =? m); now auto.
  - split; split; intros h.
    + destruct h as [t' [ectx' [eval_t comp_t]]].
      exists t', ectx'; split; auto; intros v0.
      intros.
      apply IHty1_2; eauto.
      apply comp_t.
      apply IHty1_1; eauto.
    + destruct h as [t' [ectx' [eval_t comp_t]]].
      exists t', ectx'; split; auto.
      intros; apply IHty1_2; eauto.
      apply comp_t.
      apply IHty1_1; eauto.
    + destruct v; intros v comp_v.
      apply IHty1_2; eauto.
      apply h.
      apply IHty1_1; eauto.
    + destruct v; intros v comp_v.
      apply IHty1_2; eauto.
      apply h.
      apply IHty1_1; eauto.
  - simpl; unfold extend.
    case_eq (m =? n); intros eq_n_m; try rewrite eq_n_m; simpl;
      [assert (m = n) by (apply beq_nat_true; eauto)  | assert (m <> n) by (apply beq_nat_false; eauto)];
      [subst; unfold extend; split; intros; split; intros;
        assert
          (val_ext : forall n m,
              equiv_comp_pair
                ((fun var : name =>
                    if var =? n
                    then P else val var) m)
                ((fun var : name =>
                    if var =? n
                    then P
                    else if var =? n then {| comp_term := interp_term ty2 val; comp_val := interp_val ty2 val |} else val var) m)
          ) by (intros k1 k2; destruct (k2 =? k1); eauto);
        eapply ty_subst_ext; eauto; try apply val_ext; intros; try (apply equiv_comp_pair_sym; apply val_ext) |].
    split; split; intros; assert (IH := IHty1 m ty2 (extend val n P)); clear IHty1; unfold extend in *.
    + apply (ty_subst_ext
               ty1
               (
                 fun var : name =>
                   if var =? m
                   then
                     {|
                       comp_term := interp_term ty2 (fun var0 : name => if var0 =? n then P else val var0);
                       comp_val := interp_val ty2 (fun var0 : name => if var0 =? n then P else val var0) |}
                   else if var =? n then P else val var
               )
               _); [| apply IH; eauto].
      intros.
      assert (at_most_one : ((n0 =? m) = false) \/ ((n0 =? n) = false)) by
          (case_eq (n0 =? m); case_eq (n0 =? n);
           repeat rewrite Nat.eqb_neq;
           repeat rewrite Nat.eqb_eq;
           intros; try congruence; auto).
      split; intros; destruct (n0 =? m); destruct (n0 =? n); simpl; try reflexivity; destruct at_most_one; try congruence.
      -- symmetry; eapply is_not_free_extend; eauto.
      -- symmetry; eapply is_not_free_extend; eauto.
    + apply IH; [ now eauto |].
      apply (ty_subst_ext
               ty1
               (
                 fun var : name =>
                   if var =? n
                   then P
                   else if var =? m then {| comp_term := interp_term ty2 val; comp_val := interp_val ty2 val |} else val var
               )
               _); [ | now auto].
      intros n0;
      assert (at_most_one : ((n0 =? m) = false) \/ ((n0 =? n) = false)) by
          (case_eq (n0 =? m); case_eq (n0 =? n);
           repeat rewrite Nat.eqb_neq;
           repeat rewrite Nat.eqb_eq;
           intros; try congruence; auto).
      split; intros; destruct (n0 =? m); destruct (n0 =? n); simpl; try reflexivity; destruct at_most_one; try congruence.
      -- eapply is_not_free_extend; eauto.
      -- eapply is_not_free_extend; eauto.
    + apply (ty_subst_ext
               ty1
               (
                 fun var : name =>
                   if var =? m
                   then
                     {|
                       comp_term := interp_term ty2 (fun var0 : name => if var0 =? n then P else val var0);
                       comp_val := interp_val ty2 (fun var0 : name => if var0 =? n then P else val var0) |}
                   else if var =? n then P else val var
               )
               _); [| apply IH; eauto].
      intros.
      assert (at_most_one : ((n0 =? m) = false) \/ ((n0 =? n) = false)) by
          (case_eq (n0 =? m); case_eq (n0 =? n);
           repeat rewrite Nat.eqb_neq;
           repeat rewrite Nat.eqb_eq;
           intros; try congruence; auto).
      split; intros; destruct (n0 =? m); destruct (n0 =? n); simpl; try reflexivity; destruct at_most_one; try congruence.
      -- symmetry; eapply is_not_free_extend; eauto.
      -- symmetry; eapply is_not_free_extend; eauto.
    + apply IH; [now eauto |].
      apply (ty_subst_ext
               ty1
               (
                 fun var : name =>
                   if var =? n
                   then P
                   else if var =? m then {| comp_term := interp_term ty2 val; comp_val := interp_val ty2 val |} else val var
               )
               _); [| now eauto].
      intros;
      assert (at_most_one : ((n0 =? m) = false) \/ ((n0 =? n) = false)) by
          (case_eq (n0 =? m); case_eq (n0 =? n);
           repeat rewrite Nat.eqb_neq;
           repeat rewrite Nat.eqb_eq;
           intros; try congruence; auto).
      split; intros; destruct (n0 =? m); destruct (n0 =? n); simpl; try reflexivity; destruct at_most_one; try congruence;
        eapply is_not_free_extend; eauto.
Qed.

Definition interp_pair ty val :=
  {| comp_term := interp_term ty val; comp_val := interp_val ty val |}.

Lemma comp_eval : forall P ectx ectx' t t',
    computable P ->
    (forall v, TmEval ectx' t' v -> TmEval ectx t v) ->
    comp_term P ectx' t' -> comp_term P ectx t.
Proof.
  intros.
  destruct H.
  destruct (comp_norm0 ectx' t' H1) as [v eval'].
  apply comp_term_of_val0 with (v := v); auto.
  eapply comp_val_of_term0; now eauto.
Qed.

Lemma is_free_ctx_nth_error : forall n m ctx ty,
    is_free_ctxt n ctx = false ->
    List.nth_error ctx m = Some ty ->
    is_free n ty = false.
Proof.
  unfold is_free_ctxt.
  intros.
  assert (is_free n (nth m ctx (Tvar n)) = false).
  {
    apply existsb_nth; auto.
    apply nth_error_Some; congruence.
  }
  assert (nth m ctx (Tvar n) = ty) by (apply nth_error_nth; auto).
  subst; auto.
Qed.

Lemma ctxt_val_extend : forall P n val ectx ctx,
    is_free_ctxt n ctx = false ->
    computable P -> ctxt_val val ectx ctx ->
    ctxt_val (extend val n P) ectx ctx.
Proof.
  unfold ctxt_val.
  intros ? ? ? ? ? ? ? h n ty ?.
  edestruct h as [v [nth_v interp_v]]; eauto.
  exists v; split; auto.
  apply is_not_free_extend; auto.
  eapply is_free_ctx_nth_error; eauto.
Qed.

(* Somewhat painless once you get *everything perfectly right* up to here. *)
Theorem ty_safe : forall ctx t ty ectx val,
    computable_valuation val ->
    TyRel ctx t ty ->
    ctxt_val val ectx ctx ->
    interp_term ty val ectx t.
Proof.
  intros ctx t ty ectx val val_comp H; revert ectx val val_comp; induction H; simpl; intros; auto.
  - pose (P := {| comp_term := interp_term ty val; comp_val := interp_val ty val |}).
    assert (comp_ty : computable (interp_pair ty val)) by (unfold interp_pair; auto).
    destruct comp_ty.
    edestruct H0 as [v [lookup_v comp_v]]; eauto.
    simpl in *.
    eapply comp_term_of_val0; now eauto.
  - exists t, ectx; split; [now auto|intros].
    apply IHTyRel; [now auto|].
    intros n; destruct n; simpl.
    + intros ty eq; inversion eq; subst.
      destruct v.
      unfold ":::"; simpl.
      exists (VAbs t0 e); split; now auto.
    + intros ty; simpl.
      intros eq.
      edestruct H0 as [v' [lookup_v' comp_v']]; eauto.
      exists v'; unfold ":::"; destruct v; simpl; now auto.
  - simpl in *.
    edestruct IHTyRel1 as [t' [ectx' [eval_t comp_t]]]; eauto.
    assert (comp_ty1 : computable (interp_pair ty1 val)) by (unfold interp_pair; auto).
    assert (comp_ty2 : computable (interp_pair ty2 val)) by (unfold interp_pair; auto).
    destruct comp_ty1; destruct comp_ty2; simpl in *.
    assert (norm_u : norm ectx u) by auto.
    destruct norm_u as [v eval_u].
    assert (comp_red_t_u : interp_term ty2 val (v ::: ectx') t') by (eapply comp_t; eauto).
    apply (comp_eval (interp_pair ty2 val)) with (ectx' := (v ::: ectx'))(t' := t'); unfold interp_pair; simpl; auto.
    intros; now eauto.
  - apply IHTyRel; eauto.
    apply ctxt_val_extend; auto.
  - simpl in *.
    apply ty_subst_extend; auto.
Qed.

(* Easy peesy. We do use the fact that there is *some* computable predicate. *)
Theorem norm_f : forall t ty,
    TyRel [] t ty ->
    norm [::] t.
Proof.
  intros.
  pose (val := fun _ : name => norm_pred).
  assert (interp_term ty val [::] t).
  - apply ty_safe with (ctx := []); auto.
    + intro; simpl; apply computable_norm.
    + intro n; destruct n; simpl; intros; congruence.
  - assert (comp : computable (interp_pair ty val))
      by (unfold interp_pair; apply computable_interp_term; intro; simpl; apply computable_norm).
    destruct comp; auto.
Qed.

(* Sadly, in a constructive logic, this isn't quite enough to get you a *normalization function*. *)
(* Let's finish the steps, which involve Acc, well_founded and singleton elimination... *)

(* The exact things we need for the recursive calls: this is roughly the Bove-Capretta method. *)
Inductive TmEvalRel : forall (cl1 cl2 : (eval_ctxt * term)), Prop :=
| TmEvalRel_appl : forall e t u,
    TmEvalRel (e, t) (e, App t u)
| TmEvalRel_appr : forall e t u,
    TmEvalRel (e, u) (e, App t u)
| TmEvalRel_hd : forall e e' t t' u v,
    TmEval e t (VAbs t' e') ->
    TmEval e u v ->
    TmEvalRel (v ::: e', t') (e, App t u).

Hint Constructors TmEvalRel.

(* Well-founded by construction of the evaluation tree *)
Theorem acc_tmeval : forall e t v,
    TmEval e t v ->
    Acc TmEvalRel (e, t).
Proof.
  intros e t v h; induction h; constructor; intros [e1 t1] lt_t_t1;
    inversion lt_t_t1; subst; try congruence.
  assert (v = v0) by eauto; subst. (* this is kind of a hack to enable turning existentials into deterministic computations *)
  assert (h : VAbs t' ectx' = VAbs t1 e') by eauto.
  inversion h; subst.
  auto.
Defined. (* Just in case we wanna compute a bit *)

(* We actually know how to define a WF relation on *these* now. *)
Record red_triple :=
  {
  red_ctx : eval_ctxt;
  red_tm : term;
  red_correct : exists val, TmEval red_ctx red_tm val;
  }.

Definition eval_rel : red_triple -> red_triple -> Prop :=
  fun tr1 tr2 =>
    let ectx1 := red_ctx tr1 in
    let ectx2 := red_ctx tr2 in
    let t1 := red_tm tr1 in
    let t2 := red_tm tr2 in
    TmEvalRel (ectx1, t1) (ectx2, t2).

(* We need a few lemmas from here if we're to prove anything... *)
Require Import Wellfounded.

Theorem wf_triple : well_founded eval_rel.
Proof.
  intros [ectx t [v red_v]].
  constructor.
  intros [ectx_y t_y [v_y red_v_y]]; unfold eval_rel; simpl.
  intros; eapply Acc_lemma; [ | reflexivity].
  simpl.
  eapply acc_tmeval; eauto.
Defined.

(* Gotta be reaaaal careful here to get a nice-lookign term *)
Definition eval_triple : forall tr : red_triple, { v : value | TmEval (red_ctx tr) (red_tm tr) v }.
  apply (Fix wf_triple).
  intros x eval_triple_rec.
  destruct x as [ectx t ?].
  destruct t.
  (* Variable case *)
  - case_eq (nth_error ectx n); intros.
    + exists v; simpl.
      destruct red_correct0.
      inversion t; subst.
      constructor; auto.
    + (* Can't happen because we have *some* value. *)
      exfalso.
      destruct red_correct0.
      inversion t; congruence.
  - (* evaluate t1 *)
    assert (val_t1 : { v | TmEval ectx t1 v }).
    + refine (eval_triple_rec {| red_ctx := ectx; red_tm := t1; red_correct := _ |} _ ).
      unfold eval_rel; simpl.
      eauto. (* Auto is ok here because we're in prop *)
    + (* evaluate t2 *)
      assert (val_t2 : { v | TmEval ectx t2 v} ).
      -- refine (eval_triple_rec {| red_ctx := ectx; red_tm := t2; red_correct := _ |} _ ).
         unfold eval_rel; simpl.
         eauto.
      -- simpl.
         destruct val_t1 as [[t1' ectx'] h1].
         destruct val_t2 as [v2 h2].
         assert (val_app : { v | TmEval (v2 ::: ectx') t1' v }).
         ++ refine (eval_triple_rec {| red_ctx := v2 ::: ectx'; red_tm := t1'; red_correct := _ |} _).
            unfold eval_rel; simpl; eauto.
         ++ destruct val_app as [v' h_app].
            exists v'; eauto.
  - exists (VAbs t ectx); unfold eval_rel; simpl; auto.
    Unshelve.
    destruct red_correct0; inversion t; eexists; eauto.
    destruct red_correct0; inversion t; eexists; eauto.
    destruct red_correct0; inversion t; subst.
    exists x.
    assert (v = v2) by eauto; subst.
    assert (h : VAbs t1' ectx' = VAbs t' ectx'0) by eauto; inversion h; subst.
    auto.
Defined.

Definition eval_f (t : term) (ty : type)(well_typed : TyRel [] t ty) : value :=
  let triple := {| red_ctx := [::]; red_tm := t; red_correct := norm_f t ty well_typed |} in
  let v := eval_triple triple in
  proj1_sig v.

Theorem eval_f_correct : forall t ty wt,
    TmEval [::] t (eval_f t ty wt).
Proof.
  unfold eval_f.
  intros.
  pose (v := (eval_triple {| red_ctx := [::]; red_tm := t; red_correct := norm_f t ty wt |})).
  assert (h := @proj2_sig _ _ v).
  simpl in h.
  apply h.
Qed.

(* Just to see what it's like *)
Recursive Extraction eval_f.
(* Amusingly this gives an evaluator for *any* term! Only guarenteed to terminate on well-typed ones... *)
(* It would be nice to get better extraction for evaluation contexts,
   say to arrays, so that we could actually get a somewhat decent
   evaluator. Left as exercise to the reader. *)


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal54.

Set Printing Depth 1000.
Definition lfind_eval  z x:=
drop x z.

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)))))) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


(*|
====================================
TAPFA - Partie Coq - Preuve assistée
====================================

:Auteurs: Jean-Paul Bodeveix (resp. UE), Erik Martin-Dorel, Pierre Roux
:Date:    L3 Info, Semestre 6, Année 2021-2022

Supports de ce cours :

-  https://pfitaxel.github.io/tapfa-coq-alectryon/

Principe
========

-  Prouver une propriété `P` :math:`\equiv` Construire un terme de type `P`.

.. coq::
|*)
Parameters (p : Prop) (q : Prop).

Theorem th : p -> (p -> q) -> q.
Proof.
exact (fun (x : p) (f : p -> q) => f x).
Qed.
(*|

-  Les tactiques aident à la construction du terme de preuve:

.. coq::
|*)
Theorem th' : p -> (p -> q) -> q.
Proof.
auto.
Qed.

Print th'.
(* .unfold *)
(*|

Les principales tactiques de preuve
===================================

La tactique `intro` (variante : `intros H_1 … H_n`)
---------------------------------------------------

.. code-block:: Coq

   h_1 : e_1                       h_1 : e_1
      ...        --> intro H -->      ...
   h_n : e_n                       h_n : e_n
   =========                       H : p
   p -> q                          =========
                                   q

   h_1 : e_1                       h_1 : e_1
      ...        --> intro x -->      ...
   h_n : e_n                       h_n : e_n
   ============                    x : t
   ∀ x : t, P x                    =========
                                   P x

Cas d’utilisation de `intro`

Lorsque le but est une implication ou une
quantification universelle :math:`\leadsto` introduction de l’hypothèse
dans le contexte
|*)

(*|
Preuve d’une égalité
--------------------

.. code-block:: Coq

   Γ        --> reflexivity -->   ∅ si t = t'
   ======
   t = t'

Cas d’utilisation de `reflexivity`

Lorsque le but est une égalité
entre 2 termes identiques (modulo calcul) :math:`\leadsto` fin de la
preuve.

Exemple

.. code-block:: Coq

   Γ          --> reflexivity -->   ∅ (Qed)
   =========
   1 + 1 = 2
|*)

(*|
Réécriture (utilisation d’une égalité)
--------------------------------------

Soit `E : t1 = t2` un théorème ou une hypothèse du contexte :math:`\Gamma`

.. code-block:: Coq

   Γ     --> rewrite E -->   Γ
   ====                      ====
   P t1                      P t2

   Γ     --> rewrite <-E -->   Γ
   ====                        ====
   P t2                        P t1

   Γ                                   Γ
   H : P t1   --> rewrite E in H -->   H : P t2
   ========                            ========
   G                                   G

   Γ                                     Γ
   H : P t2   --> rewrite <-E in H -->   H : P t1
   ========                              ========
   G                                     G
|*)

(*|
Réécriture (exemple)
--------------------
 *)

Theorem exemple_de_propriete_prouvee_par_reecriture :
  forall f : nat -> nat,
    (forall n : nat, f n = f (S n)) ->
    f 2 = f 0.
Proof.
  intros f.
  intros H.
  rewrite <- H.
  rewrite <- H.
  reflexivity.
Qed.

(*|
Réécriture (cas général où le théorème ``E`` a des conditions)
--------------------------------------------------------------

Soit
`E : ∀ x1 ... xk,
p1 x1 ... xk -> ⋅⋅⋅ -> pn x1 ... xk ->
t x1 ... xk = t' x1 ... xk`,
un théorème ou une hypothèse du contexte :math:`\Gamma`

.. code-block:: Coq

   Γ                 --> rewrite E -->   Γ
   ===============                       ================
   P (t u1 ... uk)                       P (t' u1 ... uk)

                                         Γ
                                         ============
                                         p1 u1 ... uk

                                         ...

                                         Γ
                                         ============
                                         pn u1 ... uk

                                         (* n conditions requises par le théorème E *)
|*)

(*|
Réécriture (exemple avec une condition)
---------------------------------------

.. code-block:: Coq

   pred : nat -> nat                             pred : nat -> nat
   E : ∀ x : nat, O < x ->                       E : ∀ x : nat, O < x ->
       S (pred x) = x                                S (pred x) = x
   n : nat                   --> rewrite E -->   n : nat
   =======================                       =======================
   S (pred (2 * (n + 1)))                        2 * (n + 1) = 2 * n + 2
   = 2 * n + 2
                                                 pred : nat -> nat
                                                 E : ∀ x : nat, O < x ->
                                                     S (pred x) = x
                                                 n : nat
                                                 ===============
                                                 O < 2 * (n + 1)
|*)

(*|
La tactique `apply` (variante : `apply H with (x_i:=v_i)` …)
------------------------------------------------------------

Soit `H : ∀ x1 ... xk,
p1 x1 ... xk -> ⋅⋅⋅ -> pn x1 ... xk ->
q x1 ... xk`,
un théorème ou une hypothèse du contexte :math:`\Gamma`

.. code-block:: Coq

   Γ             --> apply H -->   Γ
   ===========                     ============
   q u1 ... uk                     p1 u1 ... uk

                                   ...

                                   Γ
                                   ============
                                   pn u1 ... uk

                                   (* n conditions requises pour appliquer H *)
|*)

(*|
La tactique `apply` (exemple)
-----------------------------

.. coq::
|*)
Search concl:(_ <= _) S.
(* .unfold *)
(*|
(`documentation de la commande Search <https://coq.github.io/doc/V8.12.2/refman/proof-engine/vernacular-commands.html#coq:cmd.search>`_)
|*)

Goal forall n, n <= S (S n).
Proof.
intro n.
Check le_S.  (* réaffichons le lemme le_S, juste pour rappel *)
apply le_S.
Abort.
(*|

La tactique `induction` : applique le théorème d’induction
----------------------------------------------------------

.. coq::
|*)
Theorem add_comm : forall n m : nat, n + m = m + n.
Proof.
induction n.
Abort.
(*|

La tactique `destruct` : preuve par cas
---------------------------------------

.. coq::
|*)
Theorem addn1_neq0 : forall n : nat, n + 1 <> 0.
Proof.
destruct n.
(*|

La tactique `simpl` : simplification du but
-------------------------------------------

.. coq::
|*)
simpl.
Abort.
(*|

Détail : réduction des expressions `0+n`, `1+n`, `n+0`, `n+1`
-------------------------------------------------------------

Étant donnée que la fonction `(fun a b : nat => a + b)` est
définie récursivement par rapport à son premier argument :

-  `0 + n` se réduit par calcul à `n`

-  `1 + n` se réduit par calcul à `S n`

-  :math:`\leadsto` donc on peut prouver trivialement `1 + n = S n` (par réflexivité)

-  mais **on a besoin d’une preuve par induction** pour montrer que

   .. code-block:: Coq

      ∀ n : nat, n + 0 = n
      ∀ n : nat, n + 1 = S n

Autres tactiques non détaillées dans ces transparents :

-  `exact`

-  `symmetry`, `transitivity`

-  `constructor`, `split`, `left`, `right`, `exists`,
   `discriminate`, `injection`

-  `unfold`

-  `lia` (Linear Integer Arithmetic), `tauto`, `firstorder`

Pour plus de détails, voir l’Aide-mémoire des tactiques de preuve Coq
|*)

(*|
Retour sur la correspondance "preuve-programme" (Curry-Howard)
--------------------------------------------------------------

Coq fournit un langage de tactiques qui permet de construire
**interactivement** et **incrémentalement**, un programme fonctionnel
(le "terme de preuve").  Lorsque la construction de ce programme est
terminée, son type est vérifié par Coq au moment du `Qed` par rapport
au type attendu (c.-à-d. par rapport à la formule logique qui devait
être démontrée).

L'exemple qui suit, qui peut être joué dans la dernière version de
ProofGeneral en activant deux fonctionnalités spécifiques dans l'IDE,
illustre ce principe :

-  Menu ``Coq > Show Proof`` (``M-x coq-show-proof-stepwise-toggle RET``)
-  Menu ``Coq > Diffs > On`` (``ESC ` c D O``)

(en utilisant aussi si besoin, le menu ``Coq > Toggle 3 Windows mode``
ainsi que le raccourci ``C-c C-l  C-c C-p``)
|*)

Lemma example :
  forall A B C : Prop,
    (A -> B -> C) -> (A /\ B -> C).
Proof.
  intros A B C. (* notez l'apparition d'un fun ... *)
  intros hABC.
  intros hAB.
  destruct hAB. (* notez l'apparition d'un match-with ... *)
  apply hABC; auto.
Qed.

(*|
Exemples et exercices autour des listes
=======================================

Préliminaires
-------------

Pour charger la bibliothèque des listes (et les notations
à la OCaml) puis activer les arguments implicites pour vos définitions,
ajoutez au début de votre fichier :

.. coq::
|*)
Require Import List.
Import ListNotations.
Set Implicit Arguments.
(*|

Quelques preuves (de théorèmes de la stdlib) sur les listes
-----------------------------------------------------------

**But** Prouver que la double inversion d’une liste renvoie la liste
inchangée :

.. code-block:: Coq

   ∀ T (l : list T), rev (rev l) = l

La fonction `List.rev` est définie comme suit :

.. code-block:: Coq

   Fixpoint rev (T : Type) (l : list T) :=
     match l with
     | [] => []
     | x :: l’ => rev l’ ++ [x]
     end.

où `++` est une notation Coq qui équivaut à ``@`` en OCaml.

**Méthode** On part du théorème à prouver et on identifie au fur et à
mesure les lemmes intermédiaires qui méritent d’être prouvés à part.
|*)

(*|
Premier lemme
-------------

Prouver (par induction sur la liste `l1`) que l’on a :

.. code-block:: Coq

   Lemma app_nil : forall (T : Type) (l : list T), l = l ++ [].

Rappel: la fonction `(fun l1 l2 => l1 ++ l2)` est définie comme suit :

.. code-block:: Coq

   Fixpoint app (T : Type) (l1 l2 : list T) :=
     match l1 with
     | [] => l2
     | x1 :: l1 => x1 :: app l1 l2
     end.

Sauriez vous l'écrire en OCaml ?
|*)

(*|
Premier lemme – preuve par induction
------------------------------------

À la main :

Prouvons le lemme `app_nil` par induction structurelle sur la liste `l`.

- Cas de base (si `l` est la liste vide `[]`). On doit montrer que
  `[] = [] ++ []`, soit, après simplification de la définition de `app`,
  `[] = []`. CQFD.

- Cas inductif (si `l` est de la forme `x :: l'`).
  Fixons un `x : T` et un `l' : list T`, supposons que `l' = l' ++ []`
  et appelons cette hypothèse d'induction `IHl`.
  Montrons qu'alors `x :: l' = (x :: l') ++ []`.
  En simplifiant la définition de `app` on doit donc prouver que
  `x :: l' = x :: (l' ++ [])`, soit après avoir utilisé `IHl`, que
  `x :: l' = x :: l'`. CQFD.

Premier lemme – preuve par induction (version Coq)
--------------------------------------------------

.. coq::
|*)
Lemma app_nil : forall (T : Type) (l : list T), l = l ++ [].
Proof.
induction l.
{ (* accolades conseillées pour délimiter les preuves du sous but *)
  simpl.
  reflexivity. }
simpl.
rewrite <- IHl. (* utilise l’hypothèse d’induction *)
reflexivity.
Qed.
(*|

Pour appliquer `simpl` à chaque sous-but généré il suffit d’écrire
la tactique une fois après ";"

.. coq::
|*)
Lemma app_nil' : forall (T : Type) (l : list T), l = l ++ [].
Proof.
induction l; simpl.
{ reflexivity. }
rewrite <- IHl. (* utilise l’hypothèse d’induction *)
reflexivity.
Qed.
(*|

Deuxième lemme
--------------

.. coq::
|*)
Lemma app_assoc :
  forall T (l1 l2 l3 : list T), l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
induction l1; simpl; intros; auto.
rewrite IHl1.
reflexivity.
Qed.
(*|

`auto` essaie d’appliquer récursivement les hypothèses
(et certains lemmes standard, comme la réflexivité)
pour prouver le sous-but ; sinon la tactique ne fait rien.

Troisième lemme
---------------

.. coq::
|*)
Lemma rev_app_distr :
  forall T (l1 l2 : list T), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
induction l1; simpl; intros.
apply app_nil.
rewrite IHl1.
rewrite app_assoc.
reflexivity.
Qed.
(*|

Le théorème visé
----------------

.. coq::
|*)
Theorem rev_involutive : forall T (l : list T), rev (rev l) = l.
Proof.
(* exercice ! *)
(* Qed. *)


(** * Decide: Programming with decision procedures *)

Require Import Perm.

(* ################################################################# *)
(** * Using [reflect] to characterize decision procedures *)

(** Thus far in _Verified Functional Algorithms_ we have been using
   - propositions ([Prop]) such as [a<b] (which is Notation for [lt a b])
   - booleans ([bool]) such as [a<?b] (which is Notation for [ltb a b]).
*)

Check Nat.lt.  (* : nat -> nat -> Prop *)
Check Nat.ltb.  (* : nat -> nat -> bool *)

(** The [Perm] chapter defined a tactic called [bdestruct] that
    does case analysis on (x <? y) while giving you hypotheses (above
    the line) of the form (x<y).   This tactic is built using the [reflect]
    type and the [blt_reflect] theorem. *)

Print reflect.
(* Inductive reflect (P : Prop) : bool -> Set :=
    | ReflectT : P -> reflect P true
    | ReflectF : ~ P -> reflect P false  *)

Check blt_reflect.  (* : forall x y, reflect (x<y) (x <? y) *)

(** The name [reflect] for this type is a reference to _computational
   reflection_,  a technique in logic.  One takes a logical formula, or
   proposition, or predicate,  and designs a syntactic embedding of
   this formula as an "object value" in the logic.  That is, _reflect_ the
   formula back into the logic. Then one can design computations
   expressible inside the logic that manipulate these syntactic object
   values.  Finally, one proves that the computations make transformations
   that are equivalent to derivations (or equivalences) in the logic.

   The first use of computational reflection was by Goedel, in 1931:
   his syntactic embedding encoded formulas as natural numbers, a
   "Goedel numbering."  The second and third uses of reflection were
   by Church and Turing, in 1936: they encoded (respectively)
   lambda-expressions and Turing machines.

   In Coq it is easy to do reflection, because the Calculus of Inductive
   Constructions (CiC) has Inductive data types that can easily encode
   syntax trees.  We could, for example, take some of our propositional
   operators such as [and], [or], and make an [Inductive] type that is an
   encoding of these, and build a computational reasoning system for
   boolean satisfiability.

   But in this chapter I will show something much simpler.  When
   reasoning about less-than comparisons on natural numbers, we have
   the advantage that [nat] already an inductive type; it is "pre-reflected,"
   in some sense.  (The same for [Z], [list], [bool], etc.)  *)

(** Now, let's examine how [reflect] expresses the coherence between
  [lt] and [ltb]. Suppose we have a value [v] whose type is
  [reflect (3<7) (3<?7)].  What is [v]?  Either it is
  - ReflectT [P] (3<?7), where [P] is a proof of [3<7],  and [3<?7] is [true], or
  - ReflectF [Q] (3<?7), where [Q] is a proof of [~(3<7)], and [3<?7] is [false].
  In the case of [3,7], we are well advised to use [ReflectT], because
   (3<?7) cannot match the [false] required by [ReflectF]. *)

Goal (3<?7 = true). Proof. reflexivity. Qed.

(** So [v] cannot be [ReflectF Q (3<?7)] for any [Q], because that would
   not type-check.  Now, the next question:  must there exist a value
   of type [reflect (3<7) (3<?7)]  ?  The answer is yes; that is the
   [blt_reflect] theorem.  The result of [Check blt_reflect], above, says that
   for any [x,y], there does exist a value (blt_reflect x y) whose type
   is exactly [reflect (x<y)(x<?y)].     So let's look at that value!  That is,
   examine what [H], and [P], and [Q] are equal to at "Case 1" and "Case 2": *)

Theorem three_less_seven_1: 3<7.
Proof.
assert (H := blt_reflect 3 7).
remember (3<?7) as b.
destruct H as [P|Q] eqn:?.
* (* Case 1: H = ReflectT (3<7) P *)
apply P.
* (* Case 2: H = ReflectF (3<7) Q *)
compute in Heqb.
inversion Heqb.
Qed.

(** Here is another proof that uses [inversion] instead of [destruct].
   The [ReflectF] case is eliminated automatically by [inversion]
   because [3<?7] does not match [false]. *)

Theorem three_less_seven_2: 3<7.
Proof.
assert (H := blt_reflect 3 7).
inversion H as [P|Q].
apply P.
Qed.

(** The [reflect] inductive data type is a way of relating a _decision
   procedure_ (a function from X to [bool]) with a predicate (a function
   from X to [Prop]).   The convenience of [reflect], in the verification
   of functional programs, is that we can do [destruct (blt_reflect a b)],
   which relates [a<?b] (in the program) to the [a<b] (in the proof).
   That's just how the [bdestruct] tactic works; you can go back
   to [Perm.v] and examine how it is implemented in the [Ltac]
   tactic-definition language. *)

(* ################################################################# *)
(** * Using [sumbool] to characterize decision procedures *)

Module ScratchPad.

(** An alternate way to characterize decision procedures,
   widely used in Coq, is via the inductive type [sumbool].

   Suppose [Q]  is a proposition, that is, [Q: Prop].  We say [Q] is
   _decidable_ if there is an algorithm for computing a proof of
   [Q] or [~Q].  More generally, when [P] is a predicate (a function
   from some type [T] to [Prop]), we say [P] is decidable when
   [forall x:T, decidable(P)].

   We represent this concept in Coq by an inductive datatype: *)

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

(** Let's consider [sumbool] applied to two propositions: *)

Definition t1 := sumbool (3<7) (3>2).
Lemma less37: 3<7. Proof. omega. Qed.
Lemma greater23: 3>2. Proof. omega. Qed.

Definition v1a: t1 := left (3<7) (3>2) less37.
Definition v1b: t1 := right (3<7) (3>2) greater23.

(** A value of type [sumbool (3<7) (3>2)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (3>2).   *)

(** Now let's consider: *)

Definition t2 := sumbool (3<7) (2>3).
Definition v2a: t2 := left (3<7) (2>3) less37.

(** A value of type [sumbool (3<7) (2>3)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (2>3).
  But since there are no proofs of 2>3, only [left] values (such as [v2a])
  exist.  That's OK. *)

(** [sumbool] is in the Coq standard library, where there is [Notation]
   for it:  the expression [ {A}+{B} ] means [sumbool A B]. *)

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

(** A very common use of [sumbool] is on a proposition and its negation.
   For example, *)

Definition t4 := forall a b, {a<b}+{~(a<b)}.

(** That expression, [forall a b, {a<b}+{~(a<b)}], says that for any
 natural numbers [a] and [b], either [a<b] or [a>=b].  But it is _more_
 than that!  Because [sumbool] is an Inductive type with two constructors
 [left] and [right], then given the [{3<7}+{~(3<7)}] you can pattern-match
 on it and learn _constructively_ which thing is true.  *)

Definition v3: {3<7}+{~(3<7)} := left _ _ less37.

Definition is_3_less_7:  bool :=
 match v3 with
 | left _ _ _ => true
 | right _ _ _ => false
 end.

Eval compute in is_3_less_7. (* = true : bool *)

Print t4.  (* = forall a b : nat, {a < b} + {~ a < b} *)

(** Suppose there existed a value [lt_dec] of type [t4].  That would be a
  _decision procedure_ for the less-than function on natural numbers.
  For any nats [a] and [b], you could calculate [lt_dec a b], which would
  be either [left ...] (if [a<b] was provable) or [right ...] (if [~(a<b)] was
  provable).

  Let's go ahead and implement [lt_dec].  We can base it on the function
  [ltb: nat -> nat -> bool] which calculates whether [a] is less than [b],
  as a boolean.  We already have a theorem that this function on booleans
  is related to the proposition [a<b]; that theorem is called [blt_reflect]. *)

Check blt_reflect.  (* : forall x y, reflect (x<y) (x<?y) *)

(** It's not too hard to use [blt_reflect] to define [lt_dec] *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match blt_reflect a b with
| ReflectT _ P => left (a < b) (~ a < b) P
| ReflectF _ Q => right (a < b) (~ a < b) Q
end.

(** Another, equivalent way to define [lt_dec] is to use
     definition-by-tactic: *)

Definition lt_dec' (a: nat) (b: nat) : {a<b}+{~(a<b)}.
  destruct (blt_reflect a b) as [P|Q]. left. apply P.  right. apply Q.
Defined.

Print lt_dec.
Print lt_dec'.

Theorem lt_dec_equivalent: forall a b, lt_dec a b = lt_dec' a b.
Proof.
intros.
unfold lt_dec, lt_dec'.
reflexivity.
Qed.

(** Warning: these definitions of [lt_dec] are not as nice as the
  definition in the Coq standard library, because these are not
  fully computable.  See the discussion below. *)

End ScratchPad.

(* ================================================================= *)
(** **  [sumbool] in the Coq standard library *)

Module ScratchPad2.
Locate sumbool. (* Coq.Init.Specif.sumbool *)
Print sumbool.

(** The output of [Print sumbool] explains that the first two arguments
   of [left] and [right] are implicit.  We use them as follows (notice that
   [left] has only one explicit argument [P]:  *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match blt_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

Definition le_dec (a: nat) (b: nat) : {a<=b}+{~(a<=b)} :=
match ble_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

(** Now, let's use [le_dec] directly in the implementation of insertion
   sort, without mentioning [ltb] at all. *)

Fixpoint insert (x:nat) (l: list nat) :=
  match l with
  | nil => x::nil
  | h::t => if le_dec x h then x::h::t else h :: insert x t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
   x <= y -> sorted (y::l) -> sorted (x::y::l).

(** **** Exercise: 2 stars (insert_sorted_le_dec)  *)
Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l H.
  induction H.
  - constructor.
  - unfold insert.
    destruct (le_dec a x) as [ Hle | Hgt].

   (** Look at the proof state now.  In the first subgoal, we have
      above the line, [Hle: a <= x].  In the second subgoal, we have
      [Hgt: ~ (a < x)].  These are put there automatically by the
      [destruct (le_dec a x)].  Now, the rest of the proof can proceed
      as it did in [Sort.v], but using [destruct (le_dec _ _)] instead of
      [bdestruct (_ <=? _)]. *)

(* FILL IN HERE *) Admitted.

(* ################################################################# *)
(** * Decidability and computability *)

(** Before studying the rest of this chapter, it is helpful to study the
   [ProofObjects] chapter of _Software Foundations volume 1_ if you
   have not done so already.

   A predicate [P: T->Prop] is _decidable_ if there is a computable
   function [f: T->bool] such that, forall [x:T], [f x = true <-> P x].
   The second and most famous example of an _undecidable_ predicate
   is the Halting Problem (Turing, 1936): [T] is the type of Turing-machine
   descriptions, and [P(x)] is, Turing machine [x] halts.  The first, and not
   as famous, example is due to Church, 1936 (six months earlier): test
   whether a lambda-expression has a normal form.  In 1936-37, as a
   first-year PhD student before beginning his PhD thesis work, Turing
   proved these two problems are equivalent.

   Classical logic contains the axiom [forall P, P \/ ~P].  This is not provable
   in core Coq, that is, in the bare Calculus of Inductive Constructions.  But
   its negation is not provable either.   You could add this axiom to Coq
   and the system would still be consistent (i.e., no way to prove [False]).

   But [P \/ ~P] is a weaker statement than [ {P}+{~P} ], that is,
   [sumbool P (~P)].  From [ {P}+{~P} ] you can actually _calculate_ or
   [compute] either [left (x:P)] or [right(y: ~P)].     From [P \/ ~P] you cannot
   [compute] whether [P] is true.  Yes, you can [destruct] it in a proof,
   but not in a calculation.

   For most purposes its unnecessary to add the axiom [P \/ ~P] to Coq,
   because for specific predicates there's a specific way to prove [P \/ ~P]
   as a theorem.  For example,  less-than on natural numbers is decidable,
   and the existence of [blt_reflect] or [lt_dec] (as a theorem, not as an axiom)
   is a demonstration of that.

   Furthermore, in this "book" we are interested in _algorithms_.  An axiom
   [P \/ ~P] does not give us an algorithm to compute whether P is true.  As
   you saw in the definition of [insert] above, we can use [lt_dec] not only as
   a theorem that either [3<7] or [~(3<7)], we can use it as a function to
   compute whether [3<7].  In Coq, you can't compute with axioms!
   Let's try it: *)

Axiom lt_dec_axiom_1:  forall i j: nat, i<j \/ ~(i<j).

(** Now, can we use this axiom to compute with?  *)

(* Uncomment and try this:
Definition max (i j: nat) : nat :=
   if lt_dec_axiom_1 i j then j else i.
*)

(** That doesn't work, because an [if] statement requires an [Inductive]
  data type with exactly two constructors; but [lt_dec_axiom_1 i j] has
  type [i<j \/ ~(i<j)],  which is not Inductive.  But let's try a different axiom: *)

Axiom lt_dec_axiom_2:  forall i j: nat, {i<j} + {~(i<j)}.

Definition max_with_axiom (i j: nat) : nat :=
   if lt_dec_axiom_2 i j then j else i.

(** This typechecks, because [lt_dec_axiom_2 i j]  belongs to type
     [sumbool (i<j) (~(i<j))]   (also written [ {i<j} + {~(i<j)} ]), which does have
     two constructors.

     Now, let's use this function: *)

Eval compute in max_with_axiom 3 7.
  (*  = if lt_dec_axiom_2 3 7 then 7 else 3
     : nat *)

(** This [compute] didn't compute very much!  Let's try to evaluate it
    using [unfold]: *)

Lemma prove_with_max_axiom:   max_with_axiom 3 7 = 7.
Proof.
unfold max_with_axiom.
try reflexivity.  (* does not do anything, reflexivity fails *)
(* uncomment this line and try it:
   unfold lt_dec_axiom_2.
*)
destruct (lt_dec_axiom_2 3 7).
reflexivity.
contradiction n. omega.
Qed.

(** It is dangerous to add Axioms to Coq: if you add one that's inconsistent,
   then it leads to the ability to prove [False].  While that's a convenient way
   to get a lot of things proved, it's unsound; the proofs are useless.

   The Axioms above, [lt_dec_axiom_1] and [lt_dec_axiom_2], are safe enough:
   they are consistent.  But they don't help in computation.  Axioms are not
   useful here. *)

End ScratchPad2.

(* ################################################################# *)
(** * Opacity of [Qed] *)

(** This lemma [prove_with_max_axiom] turned out to be _provable_, but the proof
    could not go by _computation_.  In contrast, let's use [lt_dec], which was built
    without any axioms: *)

Lemma compute_with_lt_dec:  (if ScratchPad2.lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
(* uncomment this line and try it:
   unfold blt_reflect.
*)
Abort.

(** Unfortunately, even though [blt_reflect] was proved without any axioms, it
    is an _opaque theorem_  (proved with [Qed] instead of with [Defined]), and
    one cannot compute with opaque theorems.  Not only that, but it is proved with
    other opaque theorems such as [iff_sym] and [Nat.ltb_lt].  If we want to
    compute with an implementation of [lt_dec] built from [blt_reflect], then
    we will have to rebuild [blt_reflect] without using [Qed] anywhere, only [Defined].

    Instead, let's use the version of [lt_dec] from the Coq standard library,
    which _is_ carefully built without any opaque ([Qed]) theorems.
*)

Lemma compute_with_StdLib_lt_dec:  (if lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
reflexivity.
Qed.

(** The Coq standard library has many decidability theorems.  You can
   examine them by doing the following [Search] command. The results
   shown here are only for the subset of the library that's currently
   imported (by the [Import] commands above); there's even more out there. *)

Search ({_}+{~_}).
(*
reflect_dec: forall (P : Prop) (b : bool), reflect P b -> {P} + {~ P}
lt_dec: forall n m : nat, {n < m} + {~ n < m}
list_eq_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall l l' : list A, {l = l'} + {l <> l'}
le_dec: forall n m : nat, {n <= m} + {~ n <= m}
in_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall (a : A) (l : list A), {In a l} + {~ In a l}
gt_dec: forall n m : nat, {n > m} + {~ n > m}
ge_dec: forall n m : nat, {n >= m} + {~ n >= m}
eq_nat_decide: forall n m : nat, {eq_nat n m} + {~ eq_nat n m}
eq_nat_dec: forall n m : nat, {n = m} + {n <> m}
bool_dec: forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}
Zodd_dec: forall n : Z, {Zodd n} + {~ Zodd n}
Zeven_dec: forall n : Z, {Zeven n} + {~ Zeven n}
Z_zerop: forall x : Z, {x = 0%Z} + {x <> 0%Z}
Z_lt_dec: forall x y : Z, {(x < y)%Z} + {~ (x < y)%Z}
Z_le_dec: forall x y : Z, {(x <= y)%Z} + {~ (x <= y)%Z}
Z_gt_dec: forall x y : Z, {(x > y)%Z} + {~ (x > y)%Z}
Z_ge_dec: forall x y : Z, {(x >= y)%Z} + {~ (x >= y)%Z}
*)

(** The type of [list_eq_dec] is worth looking at.  It says that if you
     have  a decidable equality for an element type [A], then
    [list_eq_dec] calculates for you a decidable equality for type [list A].
    Try it out: *)

Definition list_nat_eq_dec:
    (forall al bl : list nat, {al=bl}+{al<>bl}) :=
  list_eq_dec eq_nat_dec.

Eval compute in if list_nat_eq_dec [1;3;4] [1;4;3] then true else false.
 (* = false : bool *)

Eval compute in if list_nat_eq_dec [1;3;4] [1;3;4] then true else false.
 (* = true : bool *)

(** **** Exercise: 2 stars (list_nat_in)  *)
(** Use [in_dec] to build this function. *)

Definition list_nat_in: forall (i: nat) (al: list nat), {In i al}+{~ In i al}
 (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example in_4_pi:  (if list_nat_in 4  [3;1;4;1;5;9;2;6] then true else false) = true.
Proof.
simpl.
(* reflexivity. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** In general, beyond [list_eq_dec] and [in_dec], one can construct a
     whole programmable calculus of decidability, using the
     programs-as-proof  language of Coq.  But is it a good idea?  Read on! *)

(* ################################################################# *)
(** * Advantages and disadvantages of [reflect] versus [sumbool] *)

(** I have shown two ways to program decision procedures in Coq,
    one using [reflect] and the other using [{_}+{~_}], i.e., [sumbool].

   - With [sumbool], you define _two_ things: the operator in [Prop]
      such as [lt: nat -> nat -> Prop] and the decidability "theorem"
      in [sumbool], such as [lt_dec: forall i j, {lt i j}+{~ lt i j}].  I say
      "theorem" in quotes because it's not _just_ a theorem, it's also
      a (nonopaque) computable function.

   - With [reflect], you define _three_ things:  the operator in [Prop],
      the operator in [bool] (such as [ltb: nat -> nat -> bool], and the
      theorem that relates them (such as [ltb_reflect]).

   Defining three things seems like more work than defining two.
   But it may be easier and more efficient.  Programming in [bool],
   you may have more control over how your functions are implemented,
   you will have fewer difficult uses of dependent types, and you
   will run into fewer difficulties with opaque theorems.

   However, among Coq programmers, [sumbool] seems to be more
   widely used, and it seems to have better support in the Coq standard
   library.  So you may encounter it, and it is worth understanding what
   it does.   Either of these two methods is a reasonable way of programming
   with proof.  *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL B FREE SOFTWARE LICENSE AGREEMENT           *)
(**************************************************************)

From Coq
  Require Import List.

From KruskalTrees
  Require Import notations.

Set Implicit Arguments.

#[local] Hint Resolve in_eq in_cons : core.

Fact list_eq_dect X (l m : list X) :
       (forall x y, x ∈ l -> y ∈ m -> { x = y } + { x <> y })
    -> { l = m } + { l <> m }.
Proof.
  revert m; induction l as [ | x l IHl ]; intros [ | y m ] H; auto.
  1,2: now right.
  destruct (H x y) as [ <- | H1 ]; auto.
  2: now right; contradict H1; inversion H1.
  destruct (IHl m) as [ <- | H2 ]; auto.
  now right; contradict H2; inversion H2.
Qed.