Inductive bin : Type :=
    | s
    | b0 (n : bin)
    | b1 (n : bin).

Definition and (a: bin) (b: bin) : bin :=
    match a, b with
    | b1 (s), b0 (s) => b0 (s)
    | b0 (s), b1 (s) => b0 (s)
    | b0 (s), b0 (s) => b0 (s)
    | b1 (s), b1 (s) => b1 (s)
    | _, _ => s
    end.

Notation "x * y" := (and x y).

Definition or (a: bin) (b: bin) : bin :=
    match a, b with
    | b1 (s), b0 (s) => b1 (s)
    | b0 (s), b1 (s) => b1 (s)
    | b0 (s), b0 (s) => b0 (s)
    | b1 (s), b1 (s) => b1 (s)
    | _, _ => s
    end.

Notation "x + y" := (or x y).

Definition xor (a: bin) (b: bin) : bin :=
    match a, b with
    | b1 (s), b1 (s) => b0 (s)
    | b0 (s), b1 (s) => b1 (s)
    | b1 (s), b0 (s) => b1 (s)
    | b0 (s), b0 (s) => b0 (s)
    | _, _       => s
    end.

Notation "x ^ y" := (xor x y).

Definition fulladder (a: bin) (b: bin) (c: bin): bin * bin :=
    (a * b + c * (a + b), a ^ b ^ c).

Fixpoint nBitAdder (a : bin) (b : bin) (c :  bin) : bin :=
    match a, b, c with
    | b0 (s), b1 (s), b0 (s) => b1 (b0 (s))
    | b1 (s), b0 (s), b0 (s) => b1 (b0 (s))
    | b1 (s), b1 (s), b0 (s) => b0 (b1 (s))
    | b0 (s), b0 (s), b0 (s) => b0 (b0 (s))
    | b0 (s), b1 (s), b1 (s) => b0 (b1 (s))
    | b1 (s), b0 (s), b1 (s) => b0 (b1 (s))
    | b1 (s), b1 (s), b1 (s) => b1 (b1 (s))
    | b0 (s), b0 (s), b1 (s) => b1 (b0 (s))
    | b0 (x), b1 (y), b0 (s) => b1 ( nBitAdder x y (b0 (s)))
    | b1 (x), b0 (y), b0 (s) => b1 ( nBitAdder x y (b0 (s)))
    | b1 (x), b1 (y), b0 (s) => b0 ( nBitAdder x y (b1 (s)))
    | b0 (x), b0 (y), b0 (s) => b0 ( nBitAdder x y (b0 (s)))
    | b0 (x), b1 (y), b1 (s) => b0 ( nBitAdder x y (b1 (s)))
    | b1 (x), b0 (y), b1 (s) => b0 ( nBitAdder x y (b1 (s)))
    | b1 (x), b1 (y), b1 (s) => b1 ( nBitAdder x y (b1 (s)))
    | b0 (x), b0 (y), b1 (s) => b1 ( nBitAdder x y (b0 (s)))
    | _, _, _ => s
    end.

Compute (nBitAdder (b1 (b1 (s))) (b1 (b1 (s))) (b0 (s))).


Require Import NArith.
Require List.
Require Import AVLTree.
Require Import Bool.

Section MappingDB.
Variable kernel_object : Type.

Section Def.

  Definition mapping_db : Type := avl_tree (avl_tree kernel_object).

  Definition has_mapping (pd:N) (sel:N) (ko:kernel_object) : mapping_db -> Prop :=
    contains pd (In (sel,ko)).

  Definition in_mapping_db (pd:N) (sel:N) : mapping_db -> Prop :=
    contains pd (in_domain sel).

  Definition mapping_db_inv (db:mapping_db) : Prop :=
    avl_tree_invariant db /\ (forall k v, In (k,v) db -> avl_tree_invariant v).

End Def.

Section Create.

  Definition create_mapping (pd:N) (sel:N) (ko:kernel_object) :
    mapping_db -> mapping_db :=
    avl_insert_merge pd (avl_insert sel ko) (avl_insert sel ko Avl_empty).

  Theorem create_has_mapping :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object),
      mapping_db_inv db ->
      has_mapping pd sel ko (create_mapping pd sel ko db).
  Proof.
    Hint Resolve insert_In In_contains.
    intros db pd sel ko db_inv. unfold has_mapping. unfold create_mapping.
    unfold mapping_db_inv in db_inv. unfold avl_tree_invariant in db_inv.
    apply insert_merge_contains; simpl; intuition eauto.
  Qed.

  Lemma ineq_2_dec :
    forall (a a' b b':N), (a <> a' \/ b <> b') -> (a <> a' \/ (a = a' /\ b <> b')).
  Proof.
    intros a a' b b' H. destruct (N.eq_dec a a'); tauto.
  Qed.

  Theorem create_preserve_other :
    forall (db:mapping_db) (pd pd':N) (sel sel':N) (ko ko':kernel_object),
      (pd' <> pd \/ sel' <> sel) -> mapping_db_inv db ->
      (has_mapping pd sel ko db
       <-> has_mapping pd sel ko (create_mapping pd' sel' ko' db)).
  Proof.
    Hint Resolve <- insert_preserve_other insert_merge_preserve_other.
    Hint Resolve -> insert_preserve_other insert_merge_preserve_other.
    pose In_in_domain as T3.
    pose In_eq as T4.
    intros db pd pd' sel sel' ko ko' ineq inv_db. apply ineq_2_dec in ineq.
    unfold has_mapping. unfold create_mapping. destruct ineq as [H|[? H]].
    - split;
      destruct 1 as [pd_mappings [in_db in_pd]];
      eapply insert_merge_preserve_other in in_db; eauto.
    - subst. split.
      + destruct 1 as [pd_mappings [in_db in_pd]]. apply insert_merge_contains.
        * apply inv_db.
        * intros not_in_db. exfalso. eauto.
        * intros v v_in_db. unfold mapping_db_inv in inv_db.
          unfold avl_tree_invariant in inv_db.
          replace v with pd_mappings; intuition eauto.
      + destruct 1 as [pd_mappings [in_created in_pd]]. unfold mapping_db_inv in inv_db.
        unfold avl_tree_invariant in inv_db.
        apply insert_merge_In_inv in in_created as [[? ?] | [? [? ?]]];
          subst;
          try apply insert_preserve_other in in_pd;
          intuition eauto.
  Qed.

  Theorem create_invariant :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object),
      mapping_db_inv db ->
      mapping_db_inv (create_mapping pd sel ko db).
  Proof.
    pose insert_merge_binary_tree_invariant as T1.
    pose insert_merge_balance_correct as T2.
    pose insert_balance_correct as T3.
    pose insert_binary_tree_invariant as T4.
    assert (empty_balance_correct:
              forall T, balance_correct (@Avl_empty T)) by (simpl; auto).
    intros db pd sel ko. intros inv_db. unfold create_mapping.
    unfold mapping_db_inv in *.
    split.
    - unfold avl_tree_invariant in *. intuition auto.
    - intros k v H. destruct (N.eq_dec pd k).
      + subst. unfold avl_tree_invariant in *. apply insert_merge_In_inv in H.
        { destruct H as [H|H].
          - intuition (subst; simpl; auto).
          - destruct H as [x [in_db xe]]. subst v. destruct inv_db as [_ P].
            specialize P with k x. intuition auto.
        } tauto.
      + rewrite <- insert_merge_preserve_other in H; simpl; intuition eauto.
  Qed.

End Create.

Section Delete.

  Definition delete_mapping (pd:N) (sel:N) : mapping_db -> mapping_db :=
    avl_update pd (avl_remove sel).

  Theorem delete_deletes_mapping :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object),
      mapping_db_inv db -> ~has_mapping pd sel ko (delete_mapping pd sel db).
  Proof.
    pose remove_not_In as T1. unfold not in T1.
    intros db pd sel ko inv_db. unfold delete_mapping. unfold has_mapping.
    unfold mapping_db_inv in inv_db. unfold avl_tree_invariant in inv_db.
    destruct inv_db as [inv_db inv_sel].
    destruct 1 as [pdv [pd_in sel_in]].
    apply update_In_inv in pd_in as [x [in_db rm_eq]].
    - subst. specialize inv_sel with pd x. intuition eauto.
    - tauto.
  Qed.

  Theorem delete_preserve_other :
    forall (db:mapping_db) (pd pd':N) (sel sel':N) (ko:kernel_object),
      mapping_db_inv db ->
      (pd' <> pd \/ sel <> sel') ->
      (has_mapping pd sel ko db <-> has_mapping pd sel ko (delete_mapping pd' sel' db)).
  Proof.
    Hint Resolve -> update_preserve_other remove_preserve_other.
    Hint Resolve <- update_preserve_other remove_preserve_other.
    intros db pd pd' sel sel' ko [inv_db inv_all] ineq. apply ineq_2_dec in ineq.
    unfold has_mapping. unfold contains. unfold delete_mapping.
    destruct ineq as [H|[pd_eq sel_ineq]].
    - split; destruct 1; intuition eauto.
    - subst. split; destruct 1 as [pdm [in_db in_pdm]].
      + exists (avl_remove sel' pdm). split.
        * unfold avl_tree_invariant in inv_db.
          rewrite update_In_inv; try (exists pdm; split); tauto.
        * rewrite remove_preserve_other in in_pdm.
          destruct in_pdm as [H|H].
          { apply H. }
          { simpl in H. absurd (sel = sel'); tauto. }
      + unfold avl_tree_invariant in inv_db.
        apply update_In_inv in in_db as [? [? ?]]; subst; intuition eauto.
  Qed.

  Theorem delete_invariant :
    forall (db:mapping_db) (pd sel:N),
      mapping_db_inv db -> mapping_db_inv (delete_mapping pd sel db).
  Proof.
    intros db pd sel [db_inv sel_inv]. unfold delete_mapping.
    unfold mapping_db_inv. unfold avl_tree_invariant in *.
    pose update_balance_correct as T1. pose update_binary_tree_invariant as T2.
    pose remove_balance_correct as T3. pose remove_binary_tree_invariant as T4. split.
    - intuition auto.
    - intros k v H. destruct (N.eq_dec k pd) as [eq|ineq].
      + subst. apply update_In_inv in H.
        * destruct H as [pd_mappings [in_db mappings_eq]]. subst v.
          apply sel_inv in in_db.
          intuition auto.
        * tauto.
      + apply update_preserve_other in H; eauto.
  Qed.

End Delete.

Section DeleteAll.

  Definition delete_all_except
             (f:kernel_object -> bool)
             (exceptions:avl_tree (list N))
             : mapping_db -> mapping_db :=
    avl_map
      (fun pd pdm =>
         match avl_lookup pd exceptions with
           | None     => avl_filter (fun _ x => negb (f x)) pdm
           | Some exc => avl_filter
                           (fun sel x => negb (andb
                                                 (f x)
                                                 (negb (List.existsb (N.eqb sel) exc))))
                           pdm
         end).

  Theorem delete_all_except_deletes :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object) (f:kernel_object -> bool)
           (exceptions:avl_tree (list N)),
      mapping_db_inv db ->
      has_mapping pd sel ko (delete_all_except f exceptions db) ->
      f ko = false \/ contains pd (List.In sel) exceptions.
  Proof.
    pose lookup_In as T1.
    intros db pd sel ko f exceptions db_inv. unfold mapping_db_inv in db_inv.
    unfold avl_tree_invariant in db_inv.
    unfold has_mapping.
    unfold delete_all_except. unfold contains. destruct 1 as [pdm [in_map in_pdm]].
    apply In_map_iff in in_map as [pdm' [pdm_pdm' pdm'_in_db]].
    assert (bt_inv_pdm': binary_tree_invariant pdm'). {
      apply proj2 in db_inv. apply db_inv in pdm'_in_db. tauto.
    }
    destruct (avl_lookup pd exceptions) eqn:A; subst pdm.
    - apply filter_predicate_true in in_pdm.
      + apply negb_true_iff in in_pdm. apply andb_false_iff in in_pdm.
        destruct in_pdm as [H|H].
        * tauto.
        * apply negb_false_iff in H. apply List.existsb_exists in H as [sel' [in_l E]].
          apply Neqb_ok in E. subst. eauto.
      + assumption.
    - apply filter_predicate_true in in_pdm.
      + apply negb_true_iff in in_pdm. tauto.
      + assumption.
  Qed.

  Theorem delete_all_except_preseve_other :
  forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object) (f:kernel_object -> bool)
         (exceptions:avl_tree (list N)),
    mapping_db_inv db ->
    f ko = false ->
    (has_mapping pd sel ko db <->
     has_mapping pd sel ko (delete_all_except f exceptions db)).
  Proof.
    intros db pd sel ko f exceptions db_inv ffalse. unfold delete_all_except.
    unfold mapping_db_inv in db_inv. unfold avl_tree_invariant in db_inv.
    apply proj2 in db_inv. split.
    - unfold has_mapping. unfold contains.
      destruct 1 as [pdm [in_db in_pdm]].
      assert (pdm_bt_inv: binary_tree_invariant pdm) by (apply db_inv in in_db; tauto).
      destruct (avl_lookup pd exceptions) eqn:A;
        eexists; (split;
          [ apply In_map_iff; rewrite A; eauto
          | apply filter_In; assumption || (rewrite negb_true_iff; rewrite ffalse; simpl; auto)
          ]).
    - unfold has_mapping. unfold contains. destruct 1 as [pdm [in_map in_pdm]].
      apply In_map_iff in in_map. destruct in_map as [pdm' [pdm_pdm' in_db]].
      destruct (avl_lookup pd exceptions);
        subst pdm;
        (apply filter_In in in_pdm;
        [(destruct in_pdm; eauto)
        |(apply db_inv in in_db; tauto)
        ]).
  Qed.

  Theorem delete_all_invariant :
    forall (db:mapping_db) (pd:N) (sel:N) (ko:kernel_object) (f:kernel_object -> bool)
           (exceptions:avl_tree (list N)),
      mapping_db_inv db -> mapping_db_inv (delete_all_except f exceptions db).
  Proof.
    pose map_balance_correct as T1. pose map_binary_tree_invariant as T2.
    pose filter_balance_correct as T3. pose filter_binary_tree_invariant as T4.
    intros db pd sel ko f exceptions db_inv. unfold mapping_db_inv in *.
    unfold avl_tree_invariant in *. unfold delete_all_except. split.
    - intuition auto.
    - intros k pd_mappings' in_r.
      apply In_map_iff in in_r as [pd_mappings [mappings_eq in_db]].
      subst pd_mappings'. apply proj2 in db_inv. apply db_inv in in_db.
      destruct (avl_lookup k exceptions); intuition eauto.
  Qed.

End DeleteAll.

End MappingDB.


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

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

Print Assumptions square.


Require Import List Lia Relation_Operators.
Import ListNotations.

From Undecidability.StackMachines.Util Require Import Nat_facts List_facts.
Require Import Undecidability.StackMachines.Reductions.CM1_HALT_to_SMNdl_UB.SMX.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Section SMX_facts.
Context {State Symbol : Set}.

Local Definition Config := @Config State Symbol.

(* reachable in at most n steps *)
Inductive reachable_n (M: SMX) : nat -> Config -> Config -> Prop :=
  | reach_refl (n: nat) (X: Config) : reachable_n M n X X
  | reach_step (n: nat) (X Y Z: Config) : step M X Y -> reachable_n M n Y Z -> reachable_n M (1+n) X Z.

Definition terminal (M: SMX) (X: Config) : Prop :=
  forall (Y: Config), not (step M X Y).

(* terminating or reachable in at most n steps *)
Definition maybe_reachable (M: SMX) (n: nat) (X Y: Config) : Prop :=
  reachable_n M n X Y \/ (exists Z, reachable_n M n X Z /\ terminal M Z).

Lemma reachable_n_maybe_reachable {M n X Y} : reachable_n M n X Y-> maybe_reachable M n X Y.
Proof. move=> ?. by left. Qed.

Lemma terminal_maybe_reachable {M n X Y} : terminal M X -> maybe_reachable M n X Y.
Proof. move=> ?. right. exists X. constructor; [by apply: reach_refl | done]. Qed.

Lemma reachable_n_step {M X Y} : step M X Y -> reachable_n M 1 X Y.
Proof. move=> ?. apply: reach_step; [by eassumption | by apply: reach_refl]. Qed.

Lemma reachable_n_mon {M n m X Y} :
  n <= m -> reachable_n M n X Y -> reachable_n M m X Y.
Proof.
  elim: n m X Y.
  { move=> m X Y ?. move Hn: (0) => n HXY.
    case: HXY Hn => *; [by apply: reach_refl | by lia]. }
  move=> n IH m X Y Hnm. move Hn': (S n) => n' HXY.
  case: HXY Hn' => [|{}n'] *; first by apply: reach_refl.
  have ->: m = S (m - 1) by lia.
  apply: reach_step; first by eassumption. apply: IH; first by lia.
  by (have ->: n = n' by lia).
Qed.

Lemma reachable_n_trans {M} n m X Y Z :
  reachable_n M n X Y -> reachable_n M m Y Z -> reachable_n M (n+m) X Z.
Proof.
  elim: n X Y.
  { move=> X Y /=. move Hn: (0) => n HXY. case: HXY Hn; [done | by lia]. }
  move=> n IH X Y /=. move Hn': (S n) => n' HXY. case: HXY Hn' => [| {}n' {}X Y1 Y2] *.
  { apply: reachable_n_mon; last by eassumption. by lia. }
  have ?: n' = n by lia. subst n'.
  apply: reach_step; first by eassumption. by apply: IH; eassumption.
Qed.

Lemma reachable_n_refl' {M n X X'} :
  X = X' -> reachable_n M n X X'.
Proof. move=> ->. by apply: reach_refl. Qed.

Lemma reachable_n_mon' {M n n' X X' Y Y'} :
  n <= n' -> (X, Y) = (X', Y') -> reachable_n M n X Y -> reachable_n M n' X' Y'.
Proof. move=> ? [? ?] ?. subst. by apply: reachable_n_mon; eassumption. Qed.

Lemma reachable_n_trans' {M} n {m k X X' Y Z} :
  m+n <= k -> X = X' -> reachable_n M n Y Z -> reachable_n M m X Y -> reachable_n M k X' Z.
Proof. move /reachable_n_mon => H *. subst. apply: H. by apply: reachable_n_trans; eassumption. Qed.

Lemma reachable_n_reachable {M T x y} :
  reachable_n M T x y -> reachable M x y.
Proof.
  elim: T x y.
  { move HT: (0) => T x y Hxy. case: Hxy HT => *; [by apply: rt_refl | by lia]. }
  move=> T IH x y. move HT': (S T) => T' Hxy.
  case: Hxy HT'; first by (move=> *; apply: rt_refl).
  move=> {}T' {}x z {}y /(@rt_step Config) Hxz + ?.
  have ->: T' = T by lia. move /IH. by apply: rt_trans.
Qed.

Lemma maybe_reachable_refl' {M n X Y} : X = Y -> maybe_reachable M n X Y.
Proof. move=> ->. left. by apply: reach_refl. Qed.

Lemma maybe_reachable_mon' {M n n' X X' Y Y'} :
  n <= n' -> (X, Y) = (X', Y') -> maybe_reachable M n X Y -> maybe_reachable M n' X' Y'.
Proof.
  move /reachable_n_mon => H [-> ->] [?|]; first by (left; apply: H).
  move=> [Z [HZ ?]]. right. exists Z. by constructor; [apply: H | ].
Qed.

Lemma maybe_reachable_trans' {M} n {m k X X' Y Z} :
  m + n <= k -> X = X' -> maybe_reachable M n Y Z -> maybe_reachable M m X Y -> maybe_reachable M k X' Z.
Proof.
  move /reachable_n_mon => H <- HYZ [?|]; first last.
  { move=> [Z' [HZ' ?]]. right. exists Z'. constructor; last done.
    apply: H. apply: reachable_n_mon; last by eassumption. by lia. }
  move: HYZ => [? | [Z' [HZ' ?]]].
  { left. apply: H. by apply: reachable_n_trans; eassumption. }
  right. exists Z'. constructor; last done.
  apply: H. by apply: reachable_n_trans; eassumption.
Qed.

Lemma first_step {M} (op : Instruction) (v w: list Symbol) {n X Z} :
  1 <= n -> In op M ->
  let '((r, s, x), (r', s', y), b) := op in
    X = (r ++ v, s ++ w, x) ->
    reachable_n M (n-1) (if b is true then (s' ++ w, r' ++ v, y) else (r' ++ v, s' ++ w, y)) Z ->
    reachable_n M n X Z.
Proof.
  move=> Hn. move: op=> [[[[r s] x] [[r' s'] y]] b].
  move /(transition M v w) /reachable_n_step => + ? ?. subst X.
  by (apply: (reachable_n_trans' (n-1)); first by lia).
Qed.

Lemma maybe_first_step {M} (op : Instruction) (v w: list Symbol) {n X Z} :
  1 <= n -> In op M ->
  let '((r, s, x), (r', s', y), b) := op in
    X = (r ++ v, s ++ w, x) ->
    maybe_reachable M (n-1) (if b is true then (s' ++ w, r' ++ v, y) else (r' ++ v, s' ++ w, y)) Z ->
    maybe_reachable M n X Z.
Proof.
  move=> Hn. move: op=> [[[[r s] x] [[r' s'] y]] b].
  move /(transition M v w) /reachable_n_step => HXY ? HYZ. subst X.
  move: HYZ => [? | [Z' [HZ' ?]]].
  - left. move: HXY. by (apply: (reachable_n_trans' (n-1)); first by lia).
  - right. exists Z'. constructor; last done.
    move: HXY. by (apply: (reachable_n_trans' (n-1)); first by lia).
Qed.

End SMX_facts.


Require Export List.
Set Implicit Arguments.
Export ListNotations.

From Coq Require Import ssreflect.

Require Import genT gen.
Require Import List_lemmasT.
(*
Require Import swappedT.
*)

Definition rel (W : Type) : Type := prod W W.
Definition trf (W : Type) : Type := W -> W.

Lemma midI: forall T (a b c d : list T) x,
  a = c -> b = d -> a ++ x :: b = c ++ x :: d.
Proof. intros. subst. reflexivity. Qed.

Lemma appI: forall T (a b c d : list T),
  a = b -> c = d -> a ++ c = b ++ d.
Proof. intros. subst. reflexivity. Qed.

Lemma apprI: forall T (a b c : list T),
  a = b -> a ++ c = b ++ c.
Proof. intros. subst. reflexivity. Qed.

Lemma appl_cong: forall {T} (a b c : list T),
  (c ++ a = c ++ b) <-> (a = b).
Proof.  intros. unfold iff. apply conj ; intro.
  induction c. simpl in H. exact H.
  simpl in H. inversion H. tauto.
  intros. subst. reflexivity. Qed.

Lemma appr_cong: forall {T} (a b c : list T),
  (a ++ c = b ++ c) <-> (a = b).
Proof.  intros. unfold iff. apply conj ; intro.
pose (@if_eq_rev_eq T (a ++ c) (b ++ c) H).
rewrite -> !rev_app_distr in e.
rewrite -> appl_cong in e.
apply if_rev_eq in e.  exact e.
subst. reflexivity.  Qed.

Lemma app_eq_nil_iff: forall {A} (l l' : list A),
  l ++ l' = [] <-> l = [] /\ l' = [].
Proof. intros. unfold iff. split ; intros.
  destruct l ; simpl in H ; [ tauto | discriminate].
  destruct H. subst. simpl. tauto. Qed.

Lemma applI: forall {T} (a b c : list T),
  a = b -> c ++ a = c ++ b.
Proof. intros. subst. reflexivity. Qed.

Definition app_assoc_cons {A} (x : A) l m xs := app_assoc l m (x :: xs).

(* in ssreflect *)
Ltac list_assoc_l' := repeat (rewrite !app_assoc || rewrite !app_comm_cons).
Ltac list_assoc_r' :=
  repeat (rewrite - !app_assoc || rewrite - !app_comm_cons).
(* tactic to strip off same sublists on lhs or rhs of append sequence *)
Ltac apps_eq_tac := list_assoc_r' ; rewrite ?eq_app_canc1 ;
  list_assoc_l' ; rewrite ?eq_app_canc2 ; reflexivity.

(* to rearrange a ++ b ++ l ++ d ++ e so that l is central,
  ie to give (a ++ b) ++ l ++ (d ++ e),
  can affect terms not containing l *)
Ltac assoc_mid l :=
  list_assoc_r' ;
  rewrite ?app_comm_cons ;
  repeat ((rewrite - (app_assoc _ l _) ; fail 1) || rewrite app_assoc) ;
  rewrite - (app_assoc _ l _).

(* to rearrange a ++ b ++ x :: d ++ e so that x is central,
  ie to give (a ++ b) ++ x :: d ++ e *)
Ltac assoc_single_mid := list_assoc_r' ; rewrite ?app_assoc_cons.

(* as assoc_single_mid, but to specify x *)
Ltac assoc_single_mid' x := list_assoc_r' ;
  repeat (rewrite (app_assoc_cons x) || rewrite (list_rearr23 x)).

(* test of assoc_mid
Lemma x : forall T (a b c d e f g : list T) (x y z : T),
  a ++ x :: b ++ c ++ y :: d ++ e ++ z :: f = g.
intros.
assoc_mid b. (* doesn't work *)
assoc_mid c.
assoc_mid d. (* doesn't work *)
assoc_mid e.
*)

Ltac acacE :=
  repeat match goal with
    | [ H : _ |- _ ] => apply app_eq_app in H ; sE
    | [ H : _ |- _ ] => apply cons_eq_app in H ; sE
    | [ H : _ |- _ ] => apply app_eq_cons in H ; sE
    end.

Ltac acacD :=
  repeat match goal with
    | [ H : _ |- _ ] => apply app_eq_app in H ; sD
    | [ H : _ |- _ ] => apply cons_eq_app in H ; sD
    | [ H : _ |- _ ] => apply app_eq_cons in H ; sD
    | [ H : _ :: _ = _ :: _ |- _ ] => injection H as ?H ?H
    end.

Ltac acacD' :=
  repeat match goal with
    | [ H : _ ++ _ = _ ++ _ |- _ ] => apply app_eq_app in H ; sD
    | [ H : _ :: _ = _ ++ _ |- _ ] => apply cons_eq_app in H ; sD
    | [ H : _ ++ _ = _ :: _ |- _ ] => apply app_eq_cons in H ; sD
    | [ H : _ :: _ = _ :: _ |- _ ] => injection H as ?H ?H
    | [ H : (_, _) = (_, _) |- _ ] => injection H as ?H ?H
    | [ H : _ :: _ = [] |- _ ] => discriminate H
    | [ H : [] = _ :: _ |- _ ] => discriminate H
         end.

Ltac acacD'T2 :=
  repeat match goal with
    | [ H : _ ++ _ = _ ++ _ |- _ ] => apply app_eq_appT2 in H ; sD
    | [ H : _ :: _ = _ ++ _ |- _ ] => apply cons_eq_appT2 in H ; sD
    | [ H : _ ++ _ = _ :: _ |- _ ] => apply app_eq_consT2 in H ; sD
    | [ H : _ :: _ = _ :: _ |- _ ] => injection H as ?H ?H
    | [ H : (_, _) = (_, _) |- _ ] => injection H as ?H ?H
    | [ H : _ :: _ = [] |- _ ] => discriminate H
    | [ H : [] = _ :: _ |- _ ] => discriminate H
         end.

Ltac acacDe' :=
  match goal with
    | [ H : _ ++ _ = _ ++ _ |- _ ] => apply app_eq_app in H ; sD
    | [ H : _ :: _ = _ ++ _ |- _ ] => apply cons_eq_app in H ; sD
    | [ H : _ ++ _ = _ :: _ |- _ ] => apply app_eq_cons in H ; sD
    | [ H : _ :: _ = _ :: _ |- _ ] => injection H as ?H ?H
    | [ H : (_, _) = (_, _) |- _ ] => injection H as ?H ?H
    | [ H : _ :: _ = [] |- _ ] => discriminate H
    | [ H : [] = _ :: _ |- _ ] => discriminate H
    | [ H : _ ++ _ = [] |- _ ] => apply app_eq_nil in H
    | [ H : [] = _ ++ _ |- _ ] => apply nil_eq_app in H
    end.

Ltac acacDe'T2 :=
  match goal with
    | [ H : _ ++ _ = _ ++ _ |- _ ] => apply app_eq_appT2 in H ; sD
    | [ H : _ :: _ = _ ++ _ |- _ ] => apply cons_eq_appT2 in H ; sD
    | [ H : _ ++ _ = _ :: _ |- _ ] => apply app_eq_consT2 in H ; sD
    | [ H : _ :: _ = _ :: _ |- _ ] => injection H as ?H ?H
    | [ H : (_, _) = (_, _) |- _ ] => injection H as ?H ?H
    | [ H : _ :: _ = [] |- _ ] => discriminate H
    | [ H : [] = _ :: _ |- _ ] => discriminate H
    | [ H : _ ++ _ = [] |- _ ] => apply app_eq_nilT in H
    | [ H : [] = _ ++ _ |- _ ] => apply nil_eq_appT in H
  end.

Ltac acacDe := repeat (sD' || acacDe').
Ltac acacDeT2 := repeat (sD' || acacDe'T2).

Theorem app_eq_unitT :
    forall {A : Type } (x y:list A) (a:A),
      x ++ y = [a] -> (x = [] /\ y = [a]) + (x = [a] /\ y = []).
Proof.
  intros *; intros H; destruct x; auto.
  simpl in H; inversion H as [[H1 H2]]; subst.
  apply app_eq_nil in H2. destruct H2. subst. auto.
Qed.

Theorem unit_eq_appT :
    forall {A : Type } (x y:list A) (a:A),
      [a] = x ++ y -> (x = [] /\ y = [a]) + (x = [a] /\ y = []).
Proof.
  intros *; intros H.
  apply app_eq_unitT. auto.
Qed.

Ltac list_eq_nc :=
   match goal with
     | [ H : _ ++ _ :: _ = [] |- _ ] => apply list_eq_nil in H
     | [ H : [] = _ ++ _ :: _  |- _ ] => apply nil_eq_list in H
     | [ H : _ ++ _ = [] |- _ ] => apply app_eq_nil in H
     | [ H : [] = _ ++ _ |- _ ] => apply nil_eq_app in H
     | [ H : _ ++ _ = [_] |- _ ] => apply app_eq_unit in H
     | [ H : [_] = _ ++ _ |- _ ] => apply unit_eq_app in H
     | [ H : _ ++ _ :: _ = [_] |- _ ] => apply list_eq_single in H
     | [ H : [_] = _ ++ _ :: _ |- _ ] => apply single_eq_list in H
     | [ H : _ :: _ = [] |- _ ] => discriminate H
     | [ H : _ :: _ = _ :: _ |- _ ] => injection H as
     end.

(* Type version of list_eq_nc *)
Ltac list_eq_ncT :=
   match goal with
     | [ H : _ ++ _ :: _ = [] |- _ ] => apply list_eq_nil in H
     | [ H : [] = _ ++ _ :: _  |- _ ] => apply nil_eq_list in H
     | [ H : _ ++ _ = [] |- _ ] => apply app_eq_nilT in H
     | [ H : [] = _ ++ _ |- _ ] => apply nil_eq_appT in H
     | [ H : _ ++ _ = [_] |- _ ] => apply app_eq_unitT in H
     | [ H : [_] = _ ++ _ |- _ ] => apply unit_eq_appT in H
     | [ H : _ ++ _ :: _ = [_] |- _ ] => apply list_eq_singleT in H
     | [ H : [_] = _ ++ _ :: _ |- _ ] => apply single_eq_listT in H
     | [ H : _ :: _ = [] |- _ ] => discriminate H
     | [ H : _ :: _ = _ :: _ |- _ ] => injection H as
     end.

Ltac sD_list_eq := repeat (cD' || list_eq_nc || sDx).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection between booleans and propositions                            *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics.
Require Export LibBool LibLogic.
Generalizable Variable P.

(* ********************************************************************** *)
(** * Reflection between booleans and propositions *)

(** [istrue b] produces a proposition that is [True] if and only if
    the boolean [b] is equal to [true].
    [isTrue P] produces a boolean expression that is [true] if and only
    if the proposition [P] is equal to [True]. *)

(* ---------------------------------------------------------------------- *)
(** ** Translation from booleans into propositions *)

(** Any boolean [b] can be viewed as a proposition through the
    relation [b = true]. *)

Coercion istrue (b : bool) : Prop := (b = true).

(** Specification of the coercion [istrue] *)

Lemma istrue_def : forall b,
  istrue b = (b = true).
Proof using. reflexivity. Qed.

Lemma istrue_true_eq : istrue true = True.
Proof using. rewrite istrue_def. extens*. Qed.

Lemma istrue_false_eq : istrue false = False.
Proof using. rewrite istrue_def. extens. iff; auto_false. Qed.

(** Update of the unfolding tactics to go through the coercion
    [istrue] (see LibTactics). *)

Ltac apply_to_head_of E cont ::=
  let go E := let P := get_head E in cont P in
  match E with
  | istrue ?A => go A
  | istrue (neg ?A) => go A
  | ?A = ?B => first [ go A | go B ]
  | ?A => go A
  end.

Global Opaque istrue.

(* ---------------------------------------------------------------------- *)
(** ** Tactics for proving boolean goals [true] and [false] *)

(** Proving the goals [true] and [~ false] *)

Lemma istrue_true : true.
Proof using. reflexivity. Qed.

Hint Resolve istrue_true.

Lemma istrue_not_false : ~ false.
Proof using. rewrite istrue_false_eq. intuition. Qed.

Hint Resolve istrue_not_false.

(** Proving the goal [false] and [False] *)

Lemma False_to_false : False -> false.
Proof using. intros K. false. Qed.

Hint Extern 1 (istrue false) =>
  apply False_to_false.

Lemma false_to_False : false -> False.
Proof using. intros K. rewrite~ istrue_false_eq in K. Qed.

Hint Extern 1 (False) => match goal with
  | H: istrue false |- _ => apply (istrue_not_false H) end.

(* ---------------------------------------------------------------------- *)
(** ** Translation from propositions into booleans *)

(** The expression [isTrue P] evaluates to [true] if and only if
    the proposition [P] is [True]. *)

Definition isTrue (P : Prop) : bool :=
  If P then true else false.

(** Simplification lemmas *)

Lemma isTrue_def : forall P,
  isTrue P = If P then true else false.
Proof using. reflexivity. Qed.

Lemma isTrue_True : isTrue True = true.
Proof using. unfolds. case_if; auto_false~. Qed.

Lemma isTrue_False : isTrue False = false.
Proof using. unfolds. case_if; auto_false~. Qed.

(** Notation for comparison in [bool] are [x '= y] and [x '<> y] *)

Notation "x ''=' y :> A" := (isTrue (@eq A x y))
  (at level 70, y at next level, only parsing) : comp_scope.
Notation "x ''<>' y :> A" := (isTrue (~ (@eq A x y)))
  (at level 69, y at next level, only parsing) : comp_scope.
Notation "x ''=' y" := (isTrue (@eq _ x y))
  (at level 70, y at next level, no associativity) : comp_scope.
Notation "x ''<>' y" := (isTrue (~ (@eq _ x y)))
  (at level 69, y at next level, no associativity) : comp_scope.

Global Opaque isTrue.
Open Scope comp_scope.

(* ---------------------------------------------------------------------- *)
(** ** Extensionality for boolean equality *)

Lemma bool_ext : forall b1 b2 : bool,
  (b1 <-> b2) -> b1 = b2.
Proof using.
  destruct b1; destruct b2; intros; auto_false.
  destruct H. false H; auto.
  destruct H. false H0; auto.
Qed.

Instance bool_extensional : Extensional bool.
Proof using. apply (@Build_Extensional bool iff bool_ext). Defined.

(* ********************************************************************** *)
(** * Lemmas for reflection *)

(* ---------------------------------------------------------------------- *)
(** ** Rewriting rules for distributing [istrue] *)

Section DistribIstrue.
Implicit Types b : bool.
Implicit Types P : Prop.

Lemma istrue_isTrue_iff : forall (P : Prop),
  istrue (isTrue P) <-> P.
Proof using. intros. rewrite isTrue_def. case_if; auto_false*. Qed.

Lemma istrue_isTrue : forall P,
  istrue (isTrue P) = P.
Proof using. extens. rewrite* istrue_isTrue_iff. Qed.

Lemma istrue_neg : forall b,
  istrue (!b) = ~ (istrue b).
Proof using. extens. tautob*. Qed.

Lemma istrue_and : forall b1 b2,
  istrue (b1 && b2) = (istrue b1 /\ istrue b2).
Proof using. extens. tautob*. Qed.

Lemma istrue_or : forall b1 b2,
  istrue (b1 || b2) = (istrue b1 \/ istrue b2).
Proof using. extens. tautob*. Qed.

End DistribIstrue.

(* ---------------------------------------------------------------------- *)
(** ** Rewriting rules for distributing [isTrue] *)

Section DistribIsTrue.
Implicit Types b : bool.
Implicit Types P : Prop.

Lemma isTrue_istrue : forall b,
  isTrue (istrue b) = b.
Proof using. extens. rewrite* istrue_isTrue_iff. Qed.

Lemma isTrue_not : forall P,
  isTrue (~ P) = ! isTrue P.
Proof using. extens. do 2 rewrite isTrue_def. do 2 case_if; auto_false*. Qed.

Lemma isTrue_and : forall P1 P2,
  isTrue (P1 /\ P2) = (isTrue P1 && isTrue P2).
Proof using. extens. do 3 rewrite isTrue_def. do 3 case_if; auto_false*. Qed.

Lemma isTrue_or : forall P1 P2,
  isTrue (P1 \/ P2) = (isTrue P1 || isTrue P2).
Proof using. extens. do 3 rewrite isTrue_def. do 3 case_if; auto_false*. Qed.

Lemma isTrue_if : forall P1 P2 P3,
  isTrue (If P1 then P2 else P3) = if isTrue P1 then isTrue P2 else isTrue P3.
Proof using.
  extens. do 4 rewrite isTrue_def.
  destruct (classicT P1).
    destruct* (classicT P2).
    destruct* (classicT P3).
Qed.

End DistribIsTrue.

(* ---------------------------------------------------------------------- *)
(** Corrolaries obtained by composition *)

Lemma istrue_neg_isTrue : forall P,
  istrue (! isTrue P) = ~ P.
Proof using. intros. rewrite istrue_neg. rewrite~ istrue_isTrue. Qed.

Lemma isTrue_not_istrue : forall b,
  isTrue (~ istrue b) = !b.
Proof using. intros. rewrite isTrue_not. rewrite~ isTrue_istrue. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Tactics for distributing [istrue] and [isTrue] *)

(* TODO: keep only one of [rew_refl] and [rew_reflect] *)

(** [rew_reflect] distributes [istrue]. *)

Hint Rewrite istrue_true_eq istrue_false_eq istrue_isTrue
  istrue_neg istrue_and istrue_or : rew_reflect.

Tactic Notation "rew_reflect" :=
  autorewrite with rew_reflect.
Tactic Notation "rew_reflect" "in" hyp(H) :=
  autorewrite with rew_reflect in H.
Tactic Notation "rew_reflect" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_reflect).
  (* autorewrite with rew_reflect in *. *)

Tactic Notation "rew_reflect" "~" :=
  rew_reflect; auto_tilde.
Tactic Notation "rew_reflect" "~" "in" hyp(H) :=
  rew_reflect in H; auto_tilde.
Tactic Notation "rew_reflect" "~" "in" "*" :=
  rew_reflect in *; auto_tilde.

Tactic Notation "rew_reflect" "*" :=
  rew_reflect; auto_star.
Tactic Notation "rew_reflect" "*" "in" hyp(H) :=
  rew_reflect in H; auto_star.
Tactic Notation "rew_reflect" "*" "in" "*" :=
  rew_reflect in *; auto_star.

(** [rew_unreflect] distributes [istrue]. *)

Hint Rewrite isTrue_True isTrue_False isTrue_istrue
 isTrue_not isTrue_and isTrue_or : rew_unreflect.

Tactic Notation "rew_unreflect" :=
  autorewrite with rew_unreflect.
Tactic Notation "rew_unreflect" "in" hyp(H) :=
  autorewrite with rew_unreflect in H.
Tactic Notation "rew_unreflect" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_unreflect).
  (* autorewrite with rew_unreflect in *. *)

Tactic Notation "rew_unreflect" "~" :=
  rew_unreflect; auto_tilde.
Tactic Notation "rew_unreflect" "~" "in" hyp(H) :=
  rew_unreflect in H; auto_tilde.
Tactic Notation "rew_unreflect" "~" "in" "*" :=
  rew_unreflect in *; auto_tilde.

Tactic Notation "rew_unreflect" "*" :=
  rew_unreflect; auto_star.
Tactic Notation "rew_unreflect" "*" "in" hyp(H) :=
  rew_unreflect in H; auto_star.
Tactic Notation "rew_unreflect" "*" "in" "*" :=
  rew_unreflect in *; auto_star.

(** [rew_refl] distributes [istrue] and [isTrue]
    and replaces [decide] with [isTrue]. *)

Hint Rewrite isTrue_True isTrue_False isTrue_istrue
 isTrue_not isTrue_and isTrue_or isTrue_if
 istrue_true_eq istrue_false_eq istrue_isTrue
 istrue_neg istrue_and istrue_or : rew_refl.

Tactic Notation "rew_refl" :=
  autorewrite with rew_refl.
Tactic Notation "rew_refl" "in" hyp(H) :=
  autorewrite with rew_refl in H.
Tactic Notation "rew_refl" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_refl).
  (* autorewrite with rew_refl in *. *)

Tactic Notation "rew_refl" "~" :=
  rew_refl; auto_tilde.
Tactic Notation "rew_refl" "~" "in" hyp(H) :=
  rew_refl in H; auto_tilde.
Tactic Notation "rew_refl" "~" "in" "*" :=
  rew_refl in *; auto_tilde.

Tactic Notation "rew_refl" "*" :=
  rew_refl; auto_star.
Tactic Notation "rew_refl" "*" "in" hyp(H) :=
  rew_refl in H; auto_star.
Tactic Notation "rew_refl" "*" "in" "*" :=
  rew_refl in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Properties of boolean comparison *)

Lemma isTrue_true : forall (P:Prop),
  P -> isTrue P = true.
Proof using. intros. rewrite isTrue_def. case_if*. Qed.

Lemma isTrue_false : forall (P:Prop),
  ~ P -> isTrue P = false.
Proof using. intros. rewrite isTrue_def. case_if*. Qed.

Lemma eqb_eq : forall A (x y:A),
  x = y -> (x '= y) = true.
Proof using. intros. subst. apply~ isTrue_true. Qed.

Lemma eqb_self : forall A (x:A),
  (x '= x) = true.
Proof using. intros. apply~ eqb_eq. Qed.

Lemma eqb_neq : forall A (x y:A),
  x <> y -> (x '= y) = false.
Proof using. intros. subst. apply~ isTrue_false. Qed.

Lemma neqb_eq : forall A (x y:A),
  x = y -> (x '<> y) = false.
Proof using. intros. subst. rewrite~ isTrue_false. Qed.

Lemma neqb_neq : forall A (x y:A),
  x <> y -> (x '<> y) = true.
Proof using. intros. subst. rewrite~ isTrue_true. Qed.

Lemma neqb_self : forall A (x:A),
  (x '<> x) = false.
Proof using. intros. apply~ neqb_eq. Qed.

Lemma eqb_sym : forall A (x y : A),
  (x '= y) = (y '= x).
Proof.
  introv. tests D: (x = y).
   rewrite~ eqb_self.
   do 2 rewrite~ eqb_neq.
Qed.

(* ********************************************************************** *)
(** * Tactics for reflection *)

(* ---------------------------------------------------------------------- *)
(** ** DEPRECATED  --- Tactic [fold_bool] *)

(** Tactic [fold_bool] simplifies goal and hypotheses of the form
    [b = true] and [b = false], as well as their symmetric *)

Section FoldingBool.
Variables (b : bool).

Lemma bool_eq_true :
  b -> b = true.
Proof using. auto. Qed.

Lemma eq_true_l :
  true = b -> b.
Proof using. tautob~. Qed.

Lemma eq_true_r :
  b = true -> b.
Proof using. tautob~. Qed.

Lemma eq_false_l :
  false = b -> !b.
Proof using. tautob~. Qed.

Lemma eq_false_r :
  b = false -> !b.
Proof using. tautob~. Qed.

Lemma eq_true_l_back :
  b -> true = b.
Proof using. tautob~. Qed.

Lemma eq_true_r_back :
  b -> b = true.
Proof using. tautob~. Qed.

Lemma eq_false_l_back :
  !b -> false = b.
Proof using. tautob~. Qed.

Lemma eq_false_r_back :
  !b -> b = false.
Proof using. tautob~. Qed.

Lemma eq_false_r_back_not :
  (~b) -> b = false.
Proof using. destruct b; auto_false. Qed. (*todo:tautob~.*)

Lemma neg_neg_back :
  b -> !!b.
Proof using. tautob~. Qed.

Lemma neg_neg_forward :
  !!b -> b.
Proof using. tautob~. Qed.

Lemma eq_bool_prove : forall b' : bool,
  (b -> b') -> (b' -> b) -> b = b'.
Proof using. lets: false_to_False. tautob~; tryfalse~. Qed.
  (* todo: simplify *)

Lemma eq_bool_iff : forall b' : bool,
  b = b' -> (b <-> b').
Proof using. tautob*. Qed.

End FoldingBool.

Ltac fold_bool :=
  repeat match goal with
  | H: true = ?b |- _ => applys_to H eq_true_l
  | H: ?b = true |- _ => applys_to H eq_true_r
  | H: false = ?b |- _ => applys_to H eq_false_l
  | H: ?b = false |- _ => applys_to H eq_false_r
  | H: istrue (!! ?b) |- _ => applys_to H neg_neg_forward
  | |- true = ?b => apply eq_true_l_back
  | |- ?b = true => apply eq_true_r_back
  | |- false = ?b => apply eq_false_l_back
  | |- ?b = false => apply eq_false_r_back
  | |- istrue (!! ?b) => apply neg_neg_back
  end.

(* ---------------------------------------------------------------------- *)
(** ** DEPRECATED --- Tactic [fold_prop] *)

(** Tactic [fold_prop] simplifies goal and hypotheses of the form
    [istrue b] or [~ istrue b], or [P = True] or [P = False]
    as well as their symmetric *)

Section FoldingProp.
Variables (P : Prop) (b : bool).

Lemma istrue_isTrue_back :
  P -> istrue (isTrue P).
Proof using. rewrite~ istrue_isTrue. Qed.

Lemma istrue_isTrue_forw :
  istrue (isTrue P) -> P.
Proof using. rewrite~ istrue_isTrue. Qed.

Lemma istrue_not_isTrue_back :
  ~ P -> istrue (! isTrue P).
Proof using. rewrite~ istrue_neg_isTrue. Qed.

Lemma istrue_not_isTrue_forw :
  istrue (! isTrue P) -> ~ P.
Proof using. rewrite~ istrue_neg_isTrue. Qed.

Lemma prop_eq_True_forw :
  (P = True) -> P.
Proof using. intros. subst~. Qed.

Lemma prop_eq_True_back :
  P -> (P = True).
Proof using. intros. extens*. Qed.

Lemma prop_eq_False_forw :
  (P = False) -> ~ P.
Proof using. intro. subst*. Qed.

Lemma prop_eq_False_back :
  ~ P -> (P = False).
Proof using. intros. extens*. Qed.

Lemma prop_neq_True_forw :
  (P <> True) -> ~ P.
Proof using. intros_all. apply H. extens*. Qed.

Lemma prop_neq_True_back :
  ~ P -> (P <> True).
Proof using. intros_all. subst~. Qed.

Lemma prop_neq_False_forw :
  (P <> False) -> P.
Proof using.
  intros_all. apply not_not_elim.
  intros_all. apply H. extens*.
Qed.

Lemma prop_neq_False_back :
  P -> (P <> False).
Proof using. introv M K. rewrite~ <- K. Qed.

Lemma not_istrue_isTrue_forw :
  ~ istrue (isTrue P) -> ~ P.
Proof using. apply contrapose_intro. rewrite~ istrue_isTrue. Qed.

Lemma not_istrue_not_isTrue_forw :
  ~ istrue (! isTrue P) -> P.
Proof using.
  rewrite <- (@not_not P). apply contrapose_intro.
  rewrite~ istrue_neg_isTrue.
Qed. (* todo: missing lemma from lib logic about ~A->B *)

Lemma not_istrue_isTrue_back :
  ~ P -> ~ istrue (isTrue P).
Proof using. apply contrapose_intro. rewrite~ istrue_isTrue. Qed.

Lemma not_istrue_not_isTrue_back :
  P -> ~ istrue (! isTrue P).
Proof using.
  rewrite <- (@not_not P). apply contrapose_intro.
  rewrite~ istrue_neg_isTrue.
Qed.

End FoldingProp.

Ltac fold_prop :=
  repeat match goal with
  | H: istrue (isTrue ?P) |- _ => applys_to H istrue_isTrue_forw
  | H: istrue (! isTrue ?P) |- _ => applys_to H istrue_not_isTrue_forw
  | H: ~ istrue (isTrue ?P) |- _ => applys_to H not_istrue_isTrue_forw
  | H: ~ istrue (! isTrue ?P) |- _ => applys_to H not_istrue_not_isTrue_forw
  | H: (?P = True) |- _ => applys_to H prop_eq_True_forw
  | H: (?P = False) |- _ => applys_to H prop_eq_False_forw
  | H: (True = ?P) |- _ => symmetry in H; applys_to H prop_eq_True_forw
  | H: (False = ?P) |- _ => symmetry in H; applys_to H prop_eq_False_forw
  | H: ~ (~ ?P) |- _ => applys_to H not_not_elim
  | |- istrue (isTrue ?P) => apply istrue_isTrue_back
  | |- istrue (! isTrue ?P) => apply istrue_not_isTrue_back
  | |- ~ istrue (isTrue ?P) => apply not_istrue_isTrue_back
  | |- ~ istrue (! isTrue ?P) => apply not_istrue_not_isTrue_back
  | |- (?P = True) => apply prop_eq_True_back
  | |- (?P = False) => apply prop_eq_False_back
  | |- (True = ?P) => symmetry; apply prop_eq_True_back
  | |- (False = ?P) => symmetry; apply prop_eq_False_back
  | |- ~ (~ ?P) => apply not_not_intro
  end.

  (* todo: improve case_if so that there is no need for that *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics for case analysis on booleans *)

(** Extends the tactic [test_dispatch] from LibLogic.v, so as to
    be able to call the tactic [tests] directly on boolean expressions *)

Ltac tests_bool_base E H1 H2 :=
  tests_prop_base (istrue E) H1 H2.

Ltac tests_dispatch E H1 H2 ::=
  match type of E with
  | bool => tests_bool_base E H1 H2
  | Prop => tests_prop_base E H1 H2
  | {_}+{_} => tests_ssum_base E H1 H2
  end.

(* ---------------------------------------------------------------------- *)
(** ** Lemmas for testing booleans *)

Lemma bool_cases : forall (b : bool),
  b \/ !b.
Proof using. tautob*. Qed.

Lemma bool_cases_eq : forall (b : bool),
  b = true \/ b = false.
Proof using. tautob*. Qed.

Lemma xor_cases : forall (b1 b2 : bool),
  xor b1 b2 -> (b1 = true /\ b2 = false)
            \/ (b1 = false /\ b2 = true).
Proof using. tautob; auto_false*. Qed.

Implicit Arguments xor_cases [b1 b2].

(* ---------------------------------------------------------------------- *)
(** ** Tactic [logics] for normalizing bool/Prop coercions *)

Section Logics.

Implicit Type P : Prop.
Ltac isTrue_prove :=
  intros; try extens; try iff; rewrite isTrue_def in *; case_if; auto_false*.

Lemma true_eq_isTrue : forall P,
  (true = isTrue P) = P.
Proof using. isTrue_prove. Qed.
Lemma isTrue_eq_true : forall P,
  (isTrue P = true) = P.
Proof using. isTrue_prove. Qed.
Lemma false_eq_isTrue : forall P,
  (false = isTrue P) = ~ P.
Proof using. isTrue_prove. Qed.
Lemma isTrue_eq_false : forall P,
  (isTrue P = false) = ~ P.
Proof using. isTrue_prove. Qed.
Lemma not_not_eq : forall P,
  (~ ~ P) = P.
Proof using. intros. rew_logic*. Qed.

Lemma isTrue_eq_isTrue : forall P1 P2,
  (isTrue P1 = isTrue P2) = (P1 <-> P2).
Proof using.
  intros. extens. iff; repeat rewrite isTrue_def in *;
  repeat case_if; auto_false*.
Qed.

Lemma prop_eq_True : forall P,
  (P = True) = P.
Proof using. intros. rew_logic*. Qed.

Lemma prop_eq_False : forall P,
  (P = False) = ~ P.
Proof using. intro. rew_logic*. Qed.

Lemma prop_neq_True : forall P,
  (P <> True) = ~ P.
Proof using. intros. rew_logic*. Qed.

Lemma prop_neq_False : forall P,
  (P <> False) = P.
Proof using.
  intro. rew_logic*. iff.
  apply not_not_elim. intros E. apply H. autos*.
  intros E. rewrite* <- E.
Qed.

End Logics.

Hint Rewrite
  true_eq_isTrue isTrue_eq_true
  false_eq_isTrue isTrue_eq_false
  isTrue_eq_isTrue not_not_eq
  istrue_true_eq istrue_false_eq istrue_isTrue
  istrue_neg istrue_and istrue_or
  : rew_isTrue.

Ltac rew_isTrue :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_isTrue).

Tactic Notation "logics" :=
  rew_isTrue.
Tactic Notation "logics" "~" :=
  logics; auto_tilde.
Tactic Notation "logics" "*" :=
  logics; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Tactics extended for reflection *)

(* Extension of [extens] *)

Ltac extens_base :=
  first [ extens_core | intros; extens_core ]; logics.

(* Extension of [case_if] *)

Ltac case_if_post ::= logics; tryfalse.

(* Extension of [absurds] *)

Ltac absurds_post H :=
  rew_logic in H.

(* ********************************************************************** *)
(** * Decidable predicates *)

(** [Decidable P] asserts that there exists a boolean
    value indicating whether [P] is true. The definition
    is interesting when this boolean is computable and
    can lead to code extraction. *)

Class Decidable (P:Prop) := decidable_make {
  decide : bool;
  decide_spec : decide = isTrue P }.

Hint Rewrite @decide_spec : rew_refl.
Implicit Arguments decide [[Decidable]].
Extraction Inline decide.

(** Notation [ifb P then x else y] can be used for
    testing a proposition [P] for which there exists an
    instance of [Decidable P]. *)

Notation "'ifb' P 'then' v1 'else' v2" :=
  (if decide P then v1 else v2)
  (at level 200, right associativity) : type_scope.

(** In classical logic, any proposition is decidable; of course,
    we do not want to use this lemma as an instance because
    it cannot be extracted to executable code. *)

Lemma prop_decidable : forall (P:Prop), Decidable P.
Proof using. intros. applys~ decidable_make (isTrue P). Qed.

(** In constructive logic, any proposition with a proof of
    that is constructively true or false is decidable. *)

Definition sumbool_decidable : forall (P:Prop),
  {P}+{~P} -> Decidable P.
Proof using.
  introv H. applys decidable_make
    (match H with left _ => true | right _ => false end).
  rewrite isTrue_def. destruct H; case_if; tryfalse; auto.
Defined.

Definition decidable_sumbool : forall P : Prop,
    Decidable P -> {P}+{~P}.
Proof using.
  introv D. destruct (decide P) eqn: H; fold_bool; rew_refl in H; [left*|right*].
Defined.

(** [sumbool_decidable] and [decidable_sumbool] just wrap their
    property as expected. *)

Lemma sumbool_decidable_decidable_sumbool : forall P (d : {P}+{~P}),
  decidable_sumbool (sumbool_decidable d) = d.
Proof.
  introv. unfolds.
  asserts R1: (forall (d : bool) B C C1 C2,
    d ->
    (if d as b return (d = b -> B) then
      fun H => C1 H
    else fun H => C2 H) eq_refl = C ->
    exists E, C1 E = C).
   clear. introv D Eq. destruct d; tryfalse. eexists. apply Eq.
  lets R1': (rm R1) (@decide P (sumbool_decidable d)).
  asserts R2: (forall (d : bool) B C C1 C2,
    !d ->
    (if d as b return (d = b -> B) then
      fun H => C1 H
    else fun H => C2 H) eq_refl = C ->
    exists E, C2 E = C).
   clear. introv D Eq. destruct d; tryfalse. eexists. apply Eq.
  lets R2': (rm R2) (@decide P (sumbool_decidable d)).
  unfold sumbool_decidable. case_if as I.
   forwards (E&Eq): R1'.
     rewrite decide_spec. rew_refl*.
     reflexivity.
    rewrite <- Eq. fequals.
   forwards (E&Eq): R2'.
     rewrite decide_spec. rew_refl*.
     reflexivity.
    rewrite <- Eq. fequals.
Qed.

Global Instance Decidable_impl : forall A B : Prop,
    Decidable A -> Decidable B -> Decidable (A -> B).
  introv (da&Ha) (db&Hb).
  destruct da; destruct db; fold_bool; rew_refl in *;
    ((apply decidable_make with true; solve [ fold_bool; rew_refl* ]) ||
     (apply decidable_make with false; solve [ fold_bool; rew_refl* ])).
Defined.

Global Instance Decidable_equiv : forall A B : Prop,
    (A <-> B) -> Decidable A -> Decidable B.
  introv E. apply prop_ext in E. substs~.
Defined.

(** Extending the [case_if] tactic to support [if decide] *)

Lemma Decidable_dec : forall (P:Prop) {H: Decidable P} (A:Type) (x y:A),
  exists (Q : {P}+{~P}),
  (if decide P then x else y) = (if Q then x else y).
Proof using.
  intros. exists (classicT P).
  rewrite decide_spec.
  tautotest P; case_if as C; case_if as C';
  first [ rewrite isTrue_True in C
        | rewrite isTrue_False in C
        | idtac ]; autos*; false*.
Qed.

Ltac case_if_on_tactic_core E Eq ::=
  match E with
  | @decide ?P ?M =>
      let Q := fresh in let Eq := fresh in
      forwards (Q&Eq): (@Decidable_dec P M);
      rewrite Eq in *; clear Eq; destruct Q
  | _ =>
    match type of E with
    | {_}+{_} => destruct E as [Eq|Eq]; try subst_hyp Eq
    | _ => let X := fresh in
           sets_eq <- X Eq: E;
           destruct X
    end
  end.

(** Rewriting lemma *)

Lemma istrue_decide : forall `{Decidable P},
  istrue (decide P) = P.
Proof using. intros. rew_refl~. Qed.

Lemma decide_prove : forall `{Decidable P},
  P -> istrue (decide P).
Proof using. intros. rewrite~ istrue_decide. Qed.

Lemma decide_def : forall `{Decidable P},
  (decide P) = (If P then true else false).
Proof using. intros. rewrite decide_spec. rewrite isTrue_def. case_if*. Qed.

Lemma decide_cases : forall `{Decidable P},
  (P /\ decide P = true) \/ (~ P /\ decide P = false).
Proof using. intros. rewrite decide_spec. rewrite isTrue_def. case_if*. Qed.

(** Dedicability instances *)

Global Instance true_decidable : Decidable True.
Proof using. applys decidable_make true. rew_refl~. Qed.

Global Instance false_decidable : Decidable False.
Proof using. applys decidable_make false. rew_refl~. Qed.

Global Instance bool_decidable : forall (b : bool), Decidable (b).
Proof using. introv. applys (@decidable_make (istrue b) b). rew_refl~. Qed.

Global Instance not_decidable : forall (P : Prop),
  Decidable P -> Decidable (~ P).
Proof using.
  (* todo: cleanup proof *)
  introv [dec spec]. applys decidable_make (neg dec).
  rew_refl. rewrite~ spec.
Qed.

Global Instance or_decidable : forall (P Q : Prop),
  Decidable P -> Decidable Q ->
  Decidable (P \/ Q).
Proof using.
  intros. applys decidable_make (decide P || decide Q).
  rew_refl. subst~.
Qed.

Global Instance and_decidable : forall P Q,
  Decidable P -> Decidable Q ->
  Decidable (P /\ Q).
Proof using.
  intros. applys decidable_make (decide P && decide Q).
  rew_refl. subst~.
Qed.

Global Instance If_dec : forall P Q R,
  Decidable P -> Decidable Q -> Decidable R ->
  Decidable (If P then Q else R).
Proof using.
  intros. applys decidable_make (if decide P then decide Q else decide R).
  rew_refl. subst~.
Qed.

(* ********************************************************************** *)
(** * Comparable types *)

(** [Comparable A] asserts that there exists a decidable
    equality over values of type [A] *)

Class Comparable (A:Type) := make_comparable {
  comparable : forall (x y:A), Decidable (x = y) }.

Hint Resolve @comparable : typeclass_instances.
Extraction Inline comparable.

(** In classical logic, any type is comparable; of course,
    we do not want to use this lemma as an instance because
    it cannot be extracted to executable code. *)

Lemma type_comparable : forall (A:Type), Comparable A.
Proof using. constructor. intros. applys~ prop_decidable. Qed.

(** [Comparable] can be proved by exhibiting a boolean
    comparison function *)

Lemma comparable_beq : forall A (f:A->A->bool),
  (forall x y, (istrue (f x y)) <-> (x = y)) ->
  Comparable A.
Proof using.
  introv H. constructors. intros.
  applys decidable_make (f x y).
  rewrite isTrue_def. extens.
  rewrite H. case_if; auto_false*.
Qed.

Extraction Inline comparable_beq.

(** [Comparable] can be proved by exhibiting a decidability
    result in the form of a strong sum *)

Lemma comparable_of_dec : forall (A:Type),
  (forall x y : A, {x = y} + {x <> y}) ->
  Comparable A.
Proof using.
  introv H. constructors. intros.
  applys decidable_make (if H x y then true else false).
  rewrite isTrue_def. destruct (H x y); case_if*.
Qed.

(** Comparison for booleans *)

Instance bool_comparable : Comparable bool.
Proof using.
  applys (comparable_beq Bool.eqb).
  destruct x; destruct y; simpl; rew_refl; auto_false*.
Qed.

Global Instance prop_eq_decidable : forall P Q,
  Decidable P -> Decidable Q ->
  Decidable (P = Q).
Proof using.
  intros. applys decidable_make (decide (decide P = decide Q)).
  extens. rew_refl.
  iff E.
    do 2 rewrite isTrue_def in E.
     extens. case_if; case_if; auto_false*.
    subst*.
Qed.

(**************************************************************)
(** * Computable epsilon operator *)

(** [Pickable P] asserts the existence of computable witness
    of a value that satisfies the predicate [P]. When an
    instance of [Pickable P] can be derived using the typeclass
    mechanism, one may write [pick P] to denote an arbitrary
    value that satisfies the predicate P. This operation is
    typically useful for extraction, in order to associate
    computable values to predicates. *)

Class Pickable (A : Type) (P : A -> Prop) := pickable_make {
  pick : A;
  pick_spec : (exists a, P a) -> P pick }.

Implicit Arguments pick [A [Pickable]].
Extraction Inline pick.

(** Instances of pickable *)

Global Instance eq_pickable : forall (A : Type) (a : A), (* todo: use `{Inhab A} *)
  Pickable (eq a).
Proof using.
  (* todo: clean up proof *)
  introv. applys pickable_make a.
  intro. reflexivity.
Qed.


From Hammer Require Import Hammer.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Require Import List.
From QuicksortComplexity Require Import list_utils.
Require Import Bool.
From QuicksortComplexity Require Import expec.
From QuicksortComplexity Require Import util.
From QuicksortComplexity Require Import sums_and_averages.
Require Import Rbase.

Arguments length {A}.

Section contents.

Variables (X: Set) (eq_X_dec: forall (x y: X), { x = y } + { x <> y }).
Definition beq_X (x y: X): bool := unsum_bool (eq_X_dec x y).

Lemma counts_0_length_0 (l: list X): (forall i, count (beq_X i) l = 0%nat) -> length l = 0%nat.
Proof with auto. hammer_hook "list_length_expec" "list_length_expec.counts_0_length_0".
destruct l; simpl...
intros.
elimtype False.
specialize (H x).
unfold beq_X in H.
destruct (eq_X_dec x x)...
simpl in H.
discriminate.
Qed.

Lemma counts_0_expec_length_0 t:
(forall i, expec (count (beq_X i)) t = 0) -> expec (@length (_:Set)) t = 0.
Proof with auto. hammer_hook "list_length_expec" "list_length_expec.counts_0_expec_length_0".
intros.
replace 0 with (INR 0)...
apply expec_constant.
intros.
apply counts_0_length_0.
intros.
apply (expec_0_inv (count (beq_X i))) with t...
Qed.

Lemma exp_list_sum_le (fr: X -> R) (q: list X) (t: ne_tree.T (list X)):
(forall i, In i q -> expec (count (beq_X i)) t <= fr i) ->
(forall i, ~ In i q -> expec (count (beq_X i)) t = 0) ->
expec (@length (_:Set)) t <= Rsum (map fr q).
Proof with auto with real. hammer_hook "list_length_expec" "list_length_expec.exp_list_sum_le".
induction q in t |- *.
simpl.
intros.
rewrite counts_0_expec_length_0...
simpl.
intros.
rewrite (@expec_ext _ (@length (_:Set)) (fun x => plus (count (beq_X a) x) (count (negb ∘ beq_X a) x)) ).
Focus 2.
intro.
apply length_excl_counts.
rewrite expec_plus.
apply Rle_trans with (fr a + expec (count (fun t0: X => negb (beq_X a t0))) t)...
apply Rplus_le_compat_l.
apply Rle_trans with (expec (@length (_:Set)) (ne_tree.map (filter (fun x: X => negb (beq_X a x))) t)).
rewrite expec_map.
apply expec_le.
intros.
rewrite comp_apply.
rewrite length_filter...
apply IHq...
intros.
rewrite expec_map.
destruct (eq_X_dec a i).
subst.
apply Rle_trans with (expec (count (beq_X i)) t)...
apply expec_le.
intros.
repeat rewrite comp_apply.
apply count_filter_le.
apply Rle_trans with (expec (count (beq_X i)) t).
apply expec_le.
intros.
repeat rewrite comp_apply.
apply count_filter_le.
apply H.
right...
intros.
rewrite expec_map.
destruct (eq_X_dec a i).
subst.
replace 0 with (INR 0)...
apply expec_constant.
intros.
rewrite comp_apply.
apply count_filtered.
intros.
destruct (beq_X i x0)...
apply Rle_antisym.
apply Rle_trans with (expec (count (beq_X i)) t).
apply expec_le.
intros.
rewrite comp_apply.
apply count_filter_le.
rewrite H0...
intro.
destruct H2...
apply expec_nonneg.
Qed.

End contents.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Theory.Adjunction.
Require Export Category.Instance.Fun.

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

Local Obligation Tactic := intros.

(* The category Adj(C,D), of adjoint functors between C and D:

    objects                (F, U, F ⊣ U)
    arrows                 (σ : F ⟹ F', τ : U ⟹ U')
    identity               identity of natural transformation
    composition            pairwise composition of natural transformations
*)

Program Definition Adj (C D : Category) : Category := {|
  obj := ∃ (F : D ⟶ C) (U : C ⟶ D), F ⊣ U;
  hom := fun x y => (`1 x ⟹ `1 y) ∧ (`1`2 x ⟹ `1`2 y);
  id  := fun x => (nat_id, nat_id);
  compose := fun _ _ _ f g => (fst f ⊙ fst g, snd f ⊙ snd g)
|}.
Next Obligation. apply prod_setoid. Defined.
Next Obligation.
  proper; simpl in *; simplify;
  rewrites; reflexivity.
Qed.
Next Obligation. split; simpl; cat. Qed.
Next Obligation. split; simpl; cat. Qed.
Next Obligation. split; simpl; cat. Qed.
Next Obligation. split; simpl; cat. Qed.


Module Time.

  (* Time is defined as a natural number. *)
  Definition time := nat.

End Time.


Require Export Categories.Typ.

Module Discrete.
Section category.
Context (T: Type).

Let obj := T.
Let hom := @eq obj.

Lemma hom_eq {x y: T} (f g: hom x y): f = g.
Proof.
  apply proof_irrelevance.
Qed.

Let id (x: T): hom x x := eq_refl.
Let comp {x y z: T} (f: hom y z) (g: hom x y): hom x z := eq_trans g f.

Lemma comp_assoc {a b c d: T} (f: hom c d) (g: hom b c) (h: hom a b): comp f (comp g h) = comp (comp f g) h.
Proof. apply hom_eq. Qed.

Lemma comp_id_l {x y: T} (f: hom x y): comp (id y) f = f.
Proof. apply hom_eq. Qed.

Lemma comp_id_r {x y: T} (f: hom x y): comp f (id x) = f.
Proof. apply hom_eq. Qed.

Definition cat_mixin: Category.mixin_of obj :=
  Category.Mixin obj hom id (@comp) (@comp_assoc) (@comp_id_l) (@comp_id_r).

Definition cat := Category.Pack obj cat_mixin.

End category.

Program Definition func {T} {C: Category} (f: T -> C) := {|
  fobj (x: cat T) := f x;
  fmap x y e := eq_iso (f_equal f e);
|}.
Next Obligation.
  apply is_eq_unique, is_eq_comp.
  all: apply eq_iso_is_eq.
Qed.

Lemma func_fobj {T} {C: Category} (F: Functor (cat T) C): func F = F.
Proof.
  fun_eq x y H.
  destruct H; simpl.
  symmetry.
  apply (@fmap_id _ _ F x).
Qed.

Lemma func_surj {T} {C: Category} (F: Functor (cat T) C): exists f, func f = F.
Proof.
  exists F.
  apply func_fobj.
Qed.

End Discrete.

Notation Discrete := Discrete.cat.

Program Definition disc: Typ ~> Cat := {|
  fobj := Discrete;
  fmap A B f := {|
    fobj := f;
    fmap := f_equal f;
    fmap_id _ := eq_refl;
    fmap_comp _ _ _ _ _ := Discrete.hom_eq _ _ _;
  |};
|}.
Next Obligation.
  fun_eq x y f.
  apply Discrete.hom_eq.
Qed.
Next Obligation.
  fun_eq x y h.
  apply Discrete.hom_eq.
Qed.

Definition forget: Cat ~> Typ := {|
  fobj := Category.obj;
  fmap := @fobj;
  fmap_id _ := eq_refl;
  fmap_comp _ _ _ _ _ := eq_refl;
|}.

Program Definition disc_counit: disc ∘ forget ~> id Cat := {|
  transform C := {|
    fobj x := x;
    fmap x y e := eq_iso e;
  |};
|}.
Next Obligation.
  apply is_eq_unique.
  2: apply is_eq_comp.
  all: apply eq_iso_is_eq.
Qed.
Next Obligation.
  rename x into C, y into D, f into F.
  fun_eq x y f.
  destruct f.
  symmetry.
  apply fmap_id.
Qed.

Program Definition disc_unit: id Typ ~> forget ∘ disc := {|
  transform T x := x;
|}.

Lemma disc_adj_by: adjoint_by disc forget disc_unit disc_counit.
Proof.
  apply adjoint_by_alt.
  split.
  intros T.
  fun_eq x y f.
  apply Discrete.hom_eq.
  intros C.
  extensionality x.
  reflexivity.
Qed.

Lemma disc_adj: disc -| forget.
Proof.
  exists disc_unit, disc_counit.
  apply disc_adj_by.
Qed.