Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_nom_low_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_low L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. lfind. Admitted.


Set Implicit Arguments.

Record Place (Env A: Type) : Type := {
  read: Env -> A ;
  write: Env -> A -> Env ;
  write_read: forall (e:Env), (write e (read e))=e
}.

Hint Rewrite -> write_read: placeeq.

Record sumPl (Env A B: Type) (vL:(Place Env A)) (vR:(Place Env B)) : Type :=
 {
   mkEnv: A -> B -> Env ;
   mkEnv2writeL: forall (e:Env) (x:A), (mkEnv x (read vR e))=(write vL e x)
 }.

(* when the following line is commented, the bug does not appear *)
Hint Rewrite -> mkEnv2writeL: placeeq.

Lemma autorewrite_raise_anomaly: forall (Env A:Type) (e: Env) (p:Place Env A),
  (exists e1:Env, e=(write p e1 (read p e))).
Proof.
  intros Env A e p; eapply ex_intro.
  autorewrite with placeeq. (* Here is the bug *)
  auto.
Qed.


From Coq.Unicode Require Import Utf8.
From Coq.micromega Require Import Lia.
From trillium.prelude Require Import
     classical quantifiers sigma classical_instances.
From stdpp Require Import finite fin_sets gmap list.

Section finite_smaller_card_nat.
  Context {A} `{!EqDecision A}.

  Fixpoint list_generated_by (f : nat → A) (n : nat) : list A :=
    match n with
    | O => [f 0]
    | S n => f (S n) :: list_generated_by f n
    end.

  Lemma list_generated_by_length (f : nat → A) n :
    length (list_generated_by f n) = S n.
  Proof. induction n as [|? IHn]; [|simpl; rewrite IHn]; done. Qed.

  Lemma elem_of_list_generated_by (f : nat → A) n x :
    x ∈ list_generated_by f n ↔ ∃ m, m ≤ n ∧ x = f m.
  Proof.
    split.
    - induction n; simpl.
      + intros ->%elem_of_list_singleton; eauto.
      + intros [->|Hn]%elem_of_cons; [by eauto|].
        apply IHn in Hn as (?&?&?); eauto.
    - intros [m [Hm1 ->]].
      revert m Hm1; induction n; intros m Hm.
      + replace m with 0 by lia.
        apply elem_of_list_singleton; done.
      + destruct (decide (m = S n)) as [->|].
        * simpl; apply elem_of_cons; auto.
        * simpl; apply elem_of_cons; auto with lia.
  Qed.

  Lemma list_generated_by_NoDup (f : nat → A) n :
    injective f → NoDup (list_generated_by f n).
  Proof.
    intros Hf.
    induction n; simpl.
    - repeat constructor; set_solver.
    - constructor; [|done].
      intros (?&?&?%Hf)%elem_of_list_generated_by; lia.
  Qed.

  Lemma finite_smaller_card_nat : Finite A → smaller_card A nat.
  Proof.
    destruct 1 as [enum Henum Hin].
    intros f Hf.
    assert (length (list_generated_by f (length enum)) ≤ length enum) as Hlen.
    { apply submseteq_length.
      apply NoDup_submseteq; auto using list_generated_by_NoDup. }
    rewrite list_generated_by_length in Hlen; lia.
  Qed.

End finite_smaller_card_nat.

Definition surjective {A B} (f : A → B) := ∀ y, ∃ x, f x = y.

Section smaller_card_nat_finite.
  Context {A} `{!EqDecision A}.

  Section no_fin_inj.
    Context (Hnfin : Finite A → False).

    Lemma no_fin_new_elem_exist (l : list A) : ∃ x, x ∉ l.
    Proof.
      destruct (ExcludedMiddle (∀ x : A, x ∈ l)); last first.
      { apply not_forall_exists_not; done. }
      exfalso; apply Hnfin.
      refine {| enum := remove_dups l |}.
      - apply NoDup_remove_dups.
      - intros; apply elem_of_remove_dups; done.
    Qed.

    Fixpoint no_fin_make_list (l : list A) (n : nat) : list A :=
      match n with
      | 0 => l
      | S n' =>
        no_fin_make_list l n' ++
        [epsilon (no_fin_new_elem_exist (no_fin_make_list l n'))]
      end.

    Lemma no_fin_make_list_length l n :
      length (no_fin_make_list l n) = length l + n.
    Proof.
      induction n as [|n IHn]; [simpl; lia|].
      simpl; rewrite app_length, IHn; simpl; lia.
    Qed.

    Lemma no_fin_make_list_prefix l n1 n2 :
      n1 ≤ n2 → (no_fin_make_list l n1) `prefix_of` (no_fin_make_list l n2).
    Proof.
      induction 1 as [|n2 IHn12]; [done|].
      simpl; apply prefix_app_r; done.
    Qed.

    Lemma no_fin_make_list_NoDup l n : NoDup l → NoDup (no_fin_make_list l n).
    Proof.
      revert l; induction n; intros l Hl; [done|].
      simpl.
      apply NoDup_app; split; [auto; done|].
      split; [|apply NoDup_singleton].
      intros x Hx ->%elem_of_list_singleton.
      apply (epsilon_correct _ (no_fin_new_elem_exist (no_fin_make_list l n)));
        done.
    Qed.

    Definition no_fin_make_inj_fun (n : nat) : A :=
      default (epsilon (no_fin_new_elem_exist [])) (no_fin_make_list [] (S n) !! n).

    Lemma no_fin_make_inj_fun_inj : injective no_fin_make_inj_fun.
    Proof.
      assert (∀ n m, n ≤ m → no_fin_make_inj_fun n = no_fin_make_inj_fun m → n = m)
        as Hnm.
      { intros n m Hnm Hfnm.
        unfold no_fin_make_inj_fun in Hfnm.
        pose proof (lookup_lt_is_Some_2 (no_fin_make_list [] (S n)) n) as [k Hk].
        { rewrite no_fin_make_list_length; lia. }
        pose proof (lookup_lt_is_Some_2 (no_fin_make_list [] (S m)) m) as [l Hl].
        { rewrite no_fin_make_list_length; lia. }
        rewrite Hk, Hl in Hfnm; simpl in Hfnm; simplify_eq.
        apply (NoDup_lookup (no_fin_make_list [] (S m)) n m l); [| |done].
        - apply no_fin_make_list_NoDup, NoDup_nil_2.
        - apply  (prefix_lookup
                    (no_fin_make_list [] (S n)) (no_fin_make_list [] (S m)) n l);
            [done|].
          apply no_fin_make_list_prefix; lia.
      }
      intros n m.
      destruct (decide (n < m)).
      - apply Hnm; lia.
      - intros; symmetry; apply Hnm; [lia|done].
    Qed.

  End no_fin_inj.

  Lemma smaller_card_nat_finite : smaller_card A nat → Finite A.
  Proof.
    intros HA.
    apply (epsilon (P := λ _, True)).
    destruct (ExcludedMiddle (∃ _ : Finite A, True)); [done|].
    assert (∀ x : Finite A, False) as Hnfin.
    { cut (∀ x : Finite A, ¬ True); [tauto|].
      eapply not_exists_forall_not; done. }
    exfalso.
    apply (HA (no_fin_make_inj_fun Hnfin)).
    apply no_fin_make_inj_fun_inj.
  Qed.

End smaller_card_nat_finite.

(* move *)

Lemma NoDup_list_prod {A B} (l : list A) (l' : list B) :
  NoDup l → NoDup l' → NoDup (list_prod l l').
Proof.
  revert l'; induction l as [|a l]; intros l' Hl Hl'.
  { apply NoDup_nil_2. }
  inversion Hl; simplify_eq.
  simpl.
  apply NoDup_app; split; [|split].
  - apply NoDup_fmap; [|done].
    intros ? ?; inversion 1; trivial.
  - intros [x y] [z [Hz1 Hz2]]%elem_of_list_fmap; simplify_eq.
    intros Hin%elem_of_list_In.
    apply in_prod_iff in Hin as [Hin1%elem_of_list_In Hin2]; done.
  - apply IHl; done.
Qed.

Section finite_lemmas.
  Context `{!EqDecision A} `{!EqDecision B}.

  Program Instance sig_finite_and (P : A → Prop) (Q : B → Prop)
        `{!∀ x, Decision (P x)} `{!∀ x, ProofIrrel (P x)}
        `{!∀ x, Decision (Q x)} `{!∀ x, ProofIrrel (Q x)}
        (HfP : Finite {x : A | P x})
        (HfQ : Finite {x : B | Q x}) :
    Finite {x : A * B | P (fst x) ∧ (Q (snd x))} :=
    {| enum :=
         (λ x, sig_prod_and x.1 x.2)
           <$> (list_prod (@enum _ _ HfP) (@enum _ _ HfQ)) |}.
  Next Obligation.
  Proof.
    intros.
    apply NoDup_fmap.
    { intros [[] []] [[] []].
      unfold sig_prod_and; simpl; inversion 1; simplify_eq.
      f_equal; apply sig_eq; done. }
    apply NoDup_list_prod; apply NoDup_enum.
  Qed.
  Next Obligation.
  Proof.
    intros ? ? ? ? ? ? ? ? [[a b] [Ha Hb]].
    apply elem_of_list_fmap.
    exists (a ↾ Ha, b ↾ Hb); split.
    { apply sig_eq; done. }
    apply elem_of_list_In, in_prod_iff.
    split; apply elem_of_list_In, elem_of_enum.
  Qed.

  Program Definition sig_finite_and2 (P : A → Prop) (Q : A → Prop)
        `{!∀ x, Decision (P x)} `{!∀ x, ProofIrrel (P x)}
        `{!∀ x, Decision (Q x)} `{!∀ x, ProofIrrel (Q x)}
        (HfP : Finite {x : A | P x}) :
    Finite {x : A | P x ∧ Q x} :=
    {| enum := sig_and_list P Q (@enum _ _ HfP) |}.
  Next Obligation.
  Proof.
    intros.
    assert (NoDup (enum {x : A | P x})) as HNoDup by apply NoDup_enum.
    induction enum as [|e enum IHenum]; [by apply NoDup_nil|]=> /=.
    destruct (decide (Q (`e))); [|by eapply IHenum, NoDup_cons_1_2].
    apply NoDup_cons.
    split; [|by eapply IHenum, NoDup_cons_1_2].
    apply NoDup_cons in HNoDup as [HNoDup1 HNoDup2].
    intros Hin. apply HNoDup1.
    by eapply sig_and_list_le.
  Qed.
  Next Obligation.
  Proof.
    intros.
    assert (∀ (x : {x : A | P x}), x ∈ enum {x : A | P x})
      as Hin by apply elem_of_enum.
    destruct x as [x [HP HQ]].
    specialize (Hin (exist _ _ HP)).
    induction enum as [|e enum IHenum]; [by apply elem_of_nil in Hin|].
    apply elem_of_cons in Hin as [Hin|Hin]; simplify_eq /=.
    - case_decide as HQ'; [|done].
      pose proof (proof_irrel HQ HQ') as <-; simplify_eq.
      apply elem_of_cons. by left.
    - case_decide; [right|]; by apply IHenum.
  Qed.

  Program Instance sig_finite_eq1 (a : A) : Finite {x : A | x = a} :=
    {| enum := [a ↾ eq_refl] |}.
  Next Obligation.
  Proof. intros; apply NoDup_singleton. Qed.
  Next Obligation.
  Proof. intros ? [? ?]; apply elem_of_list_singleton; apply sig_eq; done. Qed.

  Program Instance sig_finite_eq2 (a : A) : Finite {x : A | a = x} :=
    {| enum := [a ↾ eq_refl] |}.
  Next Obligation.
  Proof. intros; apply NoDup_singleton. Qed.
  Next Obligation.
  Proof. intros ? [? ?]; apply elem_of_list_singleton; apply sig_eq; done. Qed.

  Program Instance sig_finite_or (P : A → Prop) (Q : A → Prop)
          `{!∀ x, Decision (P x)} `{!∀ x, ProofIrrel (P x)}
          `{!∀ x, Decision (Q x)} `{!∀ x, ProofIrrel (Q x)}
          `{!EqDecision {x : A | P x ∨ Q x}}
          (HfP : Finite {x : A | P x})
          (HfQ : Finite {x : A | Q x}) :
    Finite {x : A | P x ∨ Q x} :=
    {| enum :=
         remove_dups ((sig_prod_or_l <$> (@enum _ _ HfP))
            ++ (sig_prod_or_r <$> (@enum _ _ HfQ))) |}.
  Next Obligation.
  Proof. intros; apply NoDup_remove_dups. Qed.
  Next Obligation.
  Proof.
    intros ? ? ? ? ? ? ? ? ? [a [Ha|Ha]].
    - pose proof (@elem_of_enum _ _ HfP (a ↾ Ha)).
      apply elem_of_remove_dups.
      apply elem_of_app.
      left.
      apply elem_of_list_fmap; eexists; split; last done; done.
    - pose proof (@elem_of_enum _ _ HfQ (a ↾ Ha)).
      apply elem_of_remove_dups.
      apply elem_of_app.
      right.
      apply elem_of_list_fmap; eexists; split; last done; done.
  Qed.

End finite_lemmas.

Section in_gset_finite.
  Context `{!EqDecision A, !Countable A}.
  Context {P : A → Prop} `{!∀ x : A, ProofIrrel (P x)}.

  Local Instance: ∀ x, Decision (P x).
  Proof. intros ?; apply make_decision. Qed.

  Program Fixpoint Forall_to_sig (l : list A) : Forall P l → list (sig P) :=
    match l as u return Forall P u → list (sig P) with
    | [] => λ _, []
    | a :: l' => λ Hal, (exist P a _) :: Forall_to_sig l' _
    end.
  Next Obligation.
  Proof. intros ?; inversion 1; simplify_eq; done. Qed.
  Next Obligation.
  Proof. intros ?; inversion 1; simplify_eq; done. Qed.

  Lemma elem_of_Forall_to_sig_1 l HPl x : x ∈ Forall_to_sig l HPl → `x ∈ l.
  Proof.
    revert HPl; induction l as [|a l IHl]; simpl; intros HPl Hx.
    - by apply elem_of_nil in Hx.
    - apply elem_of_cons; apply elem_of_cons in Hx as [->|]; simpl in *; eauto.
  Qed.

  Lemma elem_of_Forall_to_sig_2 l HPl x :
    x ∈ l → ∃ Hx, x ↾ Hx ∈ Forall_to_sig l HPl.
  Proof.
    revert HPl; induction l as [|a l IHl]; simpl; intros HPl Hx.
    - by apply elem_of_nil in Hx.
    - inversion HPl as [|? ? Ha HPl']; simplify_eq.
      apply elem_of_cons in Hx as [->|]; simpl in *.
      + exists Ha; apply elem_of_cons; left; apply sig_eq; done.
      + edestruct IHl as [Hx Hxl]; first done.
        exists Hx; apply elem_of_cons; eauto.
  Qed.

  Lemma Forall_to_sig_NoDup l HPl : NoDup l → NoDup (Forall_to_sig l HPl).
  Proof.
    revert HPl; induction l as [|a l IHl]; simpl;
      intros HPl; first by constructor.
    inversion 1; inversion HPl; simplify_eq.
    constructor; last by apply IHl.
    intros ?%elem_of_Forall_to_sig_1; done.
  Qed.

  Lemma in_gset_finite (g : gset A) : (∀ x, P x → x ∈ g) → Finite {x : A | P x}.
  Proof.
    intros Hg.
    assert (Forall P (filter P (elements g))) as Hels.
    { apply Forall_forall. intros ?; rewrite elem_of_list_filter; tauto. }
    refine {| enum := Forall_to_sig (filter P (elements g)) Hels |}.
    - apply Forall_to_sig_NoDup. apply NoDup_filter. apply NoDup_elements.
    - intros x.
      edestruct (elem_of_Forall_to_sig_2 _ Hels) as [Hx' ?].
      { apply elem_of_list_filter; split; first apply (proj2_sig x).
        apply elem_of_elements, Hg; apply (proj2_sig x). }
      replace x with (`x ↾ Hx'); last by apply sig_eq.
      done.
  Qed.

End in_gset_finite.

Section in_list_finite.
  Context `{!EqDecision A}.
  Context {P : A → Prop} `{!∀ x : A, ProofIrrel (P x)}.

  Local Instance: ∀ x, Decision (P x).
  Proof. intros ?; apply make_decision. Qed.

  Lemma in_list_finite (l : list A) : (∀ x, P x → x ∈ l) → Finite {x : A | P x}.
  Proof.
    intros Hl.
    assert (Forall P (filter P (remove_dups l))) as Hels.
    { apply Forall_forall. intros ?; rewrite elem_of_list_filter; tauto. }
    refine {| enum := Forall_to_sig (filter P (remove_dups l)) Hels |}.
    - apply Forall_to_sig_NoDup. apply NoDup_filter, NoDup_remove_dups.
    - intros x.
      edestruct (elem_of_Forall_to_sig_2 _ Hels) as [Hx' ?].
      { apply elem_of_list_filter; split; first apply (proj2_sig x).
        apply elem_of_remove_dups, Hl; apply (proj2_sig x). }
      replace x with (`x ↾ Hx'); last by apply sig_eq.
      done.
  Qed.

End in_list_finite.

Require Import Coq.Logic.Epsilon.
Require Import Coq.Sorting.Permutation.

Section finite_range_gmap.
  Context `{!EqDecision K, !Countable K}.

  Definition set_choose_L' (X: gset K) (Hne: X ≠ ∅): { k : K | k ∈ X } :=
    constructive_indefinite_description _ (set_choose_L X Hne).

  Fixpoint enumerate_gmaps (D: list K) (N: nat) : list (gmap K nat) :=
    match D with
    | [] => [ ∅ ]
    | k::ks =>
        m1 ← enumerate_gmaps ks N;
        new ← seq 0 (N+1);
        mret (<[ k := new ]> m1)
  end.

  Local Instance all_the_instances A (P: A -> Prop) : ∀ x, Decision (P x).
  Proof. intros ?; apply make_decision. Qed.

  Lemma enumerate_gmaps_spec N l D m :
    elements D ≡ₚ l ∧ dom m = D ∧
             map_Forall (λ (_ : K) (v : nat), v ≤ N) m → m ∈ enumerate_gmaps l N.
  Proof.
    revert l D m.
    induction l; intros D m.

    { simpl. intros (Hel&Hl&?). eapply list.Permutation_nil_r in Hel. apply elements_empty_inv in Hel.
      rewrite leibniz_equiv_iff in Hel. rewrite Hel in *.
      apply dom_empty_inv_L in Hl as ->. set_solver. }
    simpl. intros (Hel & Hl & Hbound).

    assert (Hdecomp: ∃ m1 m2, m = m1 ∪ m2 ∧ dom m1 = {[a]} ∧ dom m2 = list_to_set l).
    { assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)).
      { by rewrite Hel. }
      rewrite list_to_set_elements_L in H. simpl in H. rewrite <-Hl in H.
      apply dom_union_inv_L in H as (m1&m2&Hunion&Hmdisj&[Hdom1 Hdom2]); eauto.
      assert (a ∉ l); last set_solver.
      assert (NoDup (a :: l)).
      - rewrite <-Hel. apply NoDup_elements.
      - by apply NoDup_cons_1_1. }

    destruct Hdecomp as (m1&m2&Hunion&Hdom1&Hdom2). rewrite Hunion in *.
    assert (Hanotin: a ∉ dom m2).
    { rewrite Hdom2, elem_of_list_to_set.
      apply NoDup_cons_1_1. rewrite <-Hel. apply NoDup_elements. }
    apply dom_singleton_inv_L in Hdom1 as [v ->].
    apply elem_of_list_bind. exists m2; split; last first.
    - apply (IHl (dom m2)). repeat split.
      + rewrite <-Hl in Hel. rewrite dom_union in Hel.
        rewrite dom_singleton in Hel.
        rewrite elements_union_singleton in Hel; last done.
        by eapply Permutation_cons_inv.
      + eapply map_Forall_union_1_2; eauto.
        apply map_disjoint_singleton_l_2. by apply not_elem_of_dom.
    - apply elem_of_list_bind. exists v; split; last first.
      { specialize (Hbound a v). rewrite <-insert_union_singleton_l, lookup_insert in Hbound.
        specialize (Hbound eq_refl).
        apply elem_of_seq. split; lia. }
      rewrite insert_union_singleton_l. set_solver.
  Qed.

  Local Instance proof_irrel_P D N (m: gmap K nat):
    ProofIrrel (dom m = D ∧ map_Forall (λ _ v, v <= N) m).
  Proof. apply make_proof_irrel. Qed.

  Lemma bounded_maps_finite (D: gset K) (N : nat):
    Finite { m : gmap K nat | dom m = D ∧ map_Forall (λ _ v, v <= N) m}.
  Proof.
    apply (in_list_finite (enumerate_gmaps (elements D) N)).
    intros **. by eapply enumerate_gmaps_spec.
  Qed.

  Definition enum_gmap_bounded (D: gset K) (N : nat): list (gmap K nat) :=
    enumerate_gmaps (elements D) N.

  Lemma enum_gmap_bounded_spec N D m:
    dom m = D ∧ map_Forall (λ (_ : K) (v : nat), v ≤ N) m → m ∈ enum_gmap_bounded D N.
  Proof.
    intros **. unfold enum_gmap_bounded. eapply enumerate_gmaps_spec; done.
  Qed.

  Lemma enum_gmap_dom N D:
    Forall (λ m, dom m = D) (enum_gmap_bounded D N).
  Proof.
    assert (Hok: forall l D,
      elements D ≡ₚ l -> Forall (λ m, dom m = D) (enumerate_gmaps l N)
    ); last first.
    { rewrite Forall_forall. setoid_rewrite Forall_forall in Hok. by apply Hok. }
    induction l.
    { intros ? Hp. eapply list.Permutation_nil_r in Hp. eauto. apply elements_empty_inv in Hp.
      rewrite leibniz_equiv_iff in Hp. rewrite Hp. simpl. by rewrite Forall_singleton, dom_empty_L. }
    clear D. intros D Hel. simpl. rewrite Forall_forall. intros m Hin.
    apply elem_of_list_bind in Hin as (m'&Hin&Hin').

    assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)).
    { by rewrite Hel. }
    rewrite list_to_set_elements_L in H. simpl in H.
    rewrite H in Hel. rewrite elements_union_singleton in Hel; last first.
    { rewrite elem_of_list_to_set. apply NoDup_cons_1_1. rewrite <-Hel.
      apply NoDup_elements. }

    apply Permutation_cons_inv in Hel; eauto.
    setoid_rewrite Forall_forall in IHl. specialize (IHl (list_to_set l) Hel _ Hin').

    rewrite H.
    apply elem_of_list_bind in Hin as (?&Hfin&Hseq).
    apply elem_of_list_singleton in Hfin as ->.
    rewrite dom_insert_L, IHl. done.
  Qed.

  Definition enum_gmap_bounded' (D: gset K) (N : nat): list { m : (gmap K nat) | dom m = D }:=
    Forall_to_sig _ (enum_gmap_dom N D).

  Lemma enum_gmap_bounded'_spec N D m Hdom:
    dom m = D ∧ map_Forall (λ (_ : K) (v : nat), v ≤ N) m → m ↾ Hdom ∈ enum_gmap_bounded' D N.
  Proof.
    intros * H. apply enum_gmap_bounded_spec,
                (elem_of_Forall_to_sig_2 _ (enum_gmap_dom N D)) in H as [Hdom' ?].
    assert (Hdom = Hdom') as -> by apply ProofIrrelevance. done.
  Qed.

End finite_range_gmap.

Section finite_range_gmap.
  Context {A : Type}.
  Context `{!EqDecision K, !Countable K, !EqDecision A}.

  Fixpoint enumerate_range_gmaps (D: list K) (lr: list A) : list (gmap K A) :=
    match D with
    | [] => [ ∅ ]
    | k::ks =>
        m1 ← enumerate_range_gmaps ks lr;
        new ← lr;
        mret (<[ k := new ]> m1)
  end.

  Local Instance all_the_range_instances B (P: B -> Prop) : ∀ x, Decision (P x).
  Proof. intros ?; apply make_decision. Qed.

  Lemma enumerate_range_gmaps_spec l lr D m:
    elements D ≡ₚ l ∧ dom m = D ∧
             map_Forall (λ (_ : K) (v : A), v ∈ lr) m → m ∈ enumerate_range_gmaps l lr.
  Proof.
    revert l D m.
    induction l; intros D m.

    { simpl. intros (Hel&Hl&?). eapply list.Permutation_nil_r in Hel. apply elements_empty_inv in Hel.
      rewrite leibniz_equiv_iff in Hel. rewrite Hel in *.
      apply dom_empty_inv_L in Hl as ->. set_solver. }
    simpl. intros (Hel & Hl & Hbound).

    assert (Hdecomp: ∃ m1 m2, m = m1 ∪ m2 ∧ dom m1 = {[a]} ∧ dom m2 = list_to_set l).
    { assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)).
      { by rewrite Hel. }
      rewrite list_to_set_elements_L in H. simpl in H. rewrite <-Hl in H.
      apply dom_union_inv_L in H as (m1&m2&Hunion&Hmdisj&[Hdom1 Hdom2]); eauto.
      assert (a ∉ l); last set_solver.
      assert (NoDup (a :: l)).
      - rewrite <-Hel. apply NoDup_elements.
      - by apply NoDup_cons_1_1. }

    destruct Hdecomp as (m1&m2&Hunion&Hdom1&Hdom2). rewrite Hunion in *.
    assert (Hanotin: a ∉ dom m2).
    { rewrite Hdom2, elem_of_list_to_set.
      apply NoDup_cons_1_1. rewrite <-Hel. apply NoDup_elements. }
    apply dom_singleton_inv_L in Hdom1 as [v ->].
    apply elem_of_list_bind. exists m2; split; last first.
    - apply (IHl (dom m2)). repeat split.
      + rewrite <-Hl in Hel. rewrite dom_union in Hel.
        rewrite dom_singleton in Hel.
        rewrite elements_union_singleton in Hel; last done.
        by eapply Permutation_cons_inv.
      + eapply map_Forall_union_1_2; eauto.
        apply map_disjoint_singleton_l_2. by apply not_elem_of_dom.
    - apply elem_of_list_bind. exists v; split; last first.
      { specialize (Hbound a v). rewrite <-insert_union_singleton_l, lookup_insert in Hbound.
        by specialize (Hbound eq_refl). }
      rewrite insert_union_singleton_l. set_solver.
  Qed.

  Local Instance proof_irrel_range_P D (lr : list A) (m: gmap K A):
    ProofIrrel (dom m = D ∧ map_Forall (λ _ v, v ∈ lr) m).
  Proof. apply make_proof_irrel. Qed.

  Lemma bounded_range_maps_finite (D: gset K) (lr: list A):
    Finite { m : gmap K A | dom m = D ∧ map_Forall (λ _ v, v ∈ lr) m}.
  Proof.
    apply (in_list_finite (enumerate_range_gmaps (elements D) lr)).
    intros **. by eapply enumerate_range_gmaps_spec.
  Qed.

  Definition enum_gmap_range_bounded (D: gset K) (lr : list A): list (gmap K A) :=
    enumerate_range_gmaps (elements D) lr.

  Lemma enum_gmap_range_bounded_spec D m (lr : list A):
    dom m = D ∧ map_Forall (λ (_ : K) (v : A), v ∈ lr) m → m ∈ enum_gmap_range_bounded D lr.
  Proof.
    intros **. unfold enum_gmap_range_bounded. eapply enumerate_range_gmaps_spec; done.
  Qed.

  Lemma enum_gmap_range_dom lr D:
    Forall (λ m, dom m = D) (enum_gmap_range_bounded D lr).
  Proof.
    assert (Hok: forall l D,
      elements D ≡ₚ l -> Forall (λ m, dom m = D) (enumerate_range_gmaps l lr)
    ); last first.
    { rewrite Forall_forall. setoid_rewrite Forall_forall in Hok. by apply Hok. }
    induction l.
    { intros ? Hp. eapply list.Permutation_nil_r in Hp. eauto. apply elements_empty_inv in Hp.
      rewrite leibniz_equiv_iff in Hp. rewrite Hp. simpl. by rewrite Forall_singleton, dom_empty_L. }
    clear D. intros D Hel. simpl. rewrite Forall_forall. intros m Hin.
    apply elem_of_list_bind in Hin as (m'&Hin&Hin').

    assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)).
    { by rewrite Hel. }
    rewrite list_to_set_elements_L in H. simpl in H.
    rewrite H in Hel. rewrite elements_union_singleton in Hel; last first.
    { rewrite elem_of_list_to_set. apply NoDup_cons_1_1. rewrite <-Hel.
      apply NoDup_elements. }

    apply Permutation_cons_inv in Hel; eauto.
    setoid_rewrite Forall_forall in IHl. specialize (IHl (list_to_set l) Hel _ Hin').

    rewrite H.
    apply elem_of_list_bind in Hin as (?&Hfin&Hseq).
    apply elem_of_list_singleton in Hfin as ->.
    rewrite dom_insert_L, IHl. done.
  Qed.

  Definition enum_gmap_range_bounded' (D: gset K) (lr : list A):
    list { m : (gmap K A) | dom m = D }
    := Forall_to_sig _ (enum_gmap_range_dom lr D).

  Lemma enum_gmap_range_bounded'_spec lr D m Hdom:
    dom m = D ∧ map_Forall (λ (_ : K) (v : A), v ∈ lr) m → m ↾ Hdom ∈ enum_gmap_range_bounded' D lr.
  Proof.
    intros * H. apply enum_gmap_range_bounded_spec,
                (elem_of_Forall_to_sig_2 _ (enum_gmap_range_dom lr D)) in H as [Hdom' ?].
    assert (Hdom = Hdom') as -> by apply ProofIrrelevance. done.
  Qed.

End finite_range_gmap.

Section enumerate_gsets.
  Context {A : Type}.
  Context `{!EqDecision A, !Countable A}.

  Fixpoint enumerate_dom_gsets (D: list A) : list (gset A) :=
    match D with
    | [] => [ ∅ ]
    | k::ks =>
        s_wo ← enumerate_dom_gsets ks;
        b ← [ true; false];
        if (b : bool) then mret s_wo else mret $ {[ k ]} ∪ s_wo
  end.

  Definition enumerate_dom_gsets' (D: gset A) : list (gset A) :=
    enumerate_dom_gsets (elements D).

  Local Instance all_the_range_instances' B (P: B -> Prop) : ∀ x, Decision (P x).
  Proof. intros ?; apply make_decision. Qed.

  Lemma enumerate_gsets_spec D l m :
    elements D ≡ₚ l ∧ m ⊆ D → m ∈ enumerate_dom_gsets l.
  Proof.
    revert l D m.
    induction l; intros D m.

    { simpl. intros (Hel&Hl). eapply list.Permutation_nil_r in Hel. apply elements_empty_inv in Hel.
      rewrite leibniz_equiv_iff in Hel. rewrite Hel in *. assert (m = ∅); set_solver. }
    simpl. intros (Hel & Hl).

    assert (Hdecomp: ∃ m1 m2, m = m1 ∪ m2 ∧ m1 ⊆ {[a]} ∧ m2 ⊆ list_to_set l).
    { assert (list_to_set (elements D) = (list_to_set (a :: l): gset _)).
      { by rewrite Hel. }
      rewrite list_to_set_elements_L in H. simpl in H. exists (m ∩ {[a]}), (m ∩ list_to_set l).
      split; last split; [set_solver|set_solver|set_solver]. }

    destruct Hdecomp as (m1&m2&Hunion&Hdom1&Hdom2). rewrite Hunion in *.
    assert (Hanotin: a ∉ m2).
    { intros contra. eapply elem_of_subseteq in contra; eauto. rewrite elem_of_list_to_set in contra.
      assert (a ∉ l); last done. apply NoDup_cons_1_1. rewrite <-Hel. apply NoDup_elements. }
    apply elem_of_list_bind. exists m2; split; last first.
    - apply (IHl (list_to_set l)). split; last set_solver. apply elements_list_to_set.
      eapply (NoDup_cons_1_2 a). rewrite <-Hel. apply NoDup_elements.
    - destruct (decide (a ∈ m1)).
      + assert (m1 = {[a]}) by set_solver. simplify_eq. set_solver.
      + assert (m1 = ∅) by set_solver. simplify_eq. rewrite union_empty_l_L. set_solver.
  Qed.

  Lemma enumerate_dom_gsets'_spec D s:
    s ⊆ D → s ∈ enumerate_dom_gsets' D.
  Proof.
    intros H. unfold enumerate_dom_gsets'. eapply (enumerate_gsets_spec D). split; set_solver.
  Qed.
End enumerate_gsets.


Require Import Reals.

Open Scope R_scope.
Inductive V0 (A : Type) : Type := V0Make.
(* Inductive V1 (A : Type) : Type := V1Make : A -> V1 A. *)

Record V1 {A : Type} := { v : A }.
Check Build_V1 R 3.
Hint Constructors V1.

Class Count (a : Type) := {
       count :  nat
                         }.
Open Scope nat.
Instance unitCount : Count unit := {
                                    count := 1%nat
                                  }.

Instance sumCount a b `{Count a} `{Count b}  : Count (a + b) :=
  {
   count := count + count
    }.

Instance prodCount a b `{Count a} `{Count b}  : Count (a * b) :=
  {
   count  := count * count
  }.
Instance boolCount  : Count bool :=
  {
   count  := 2
  }.

Class Enum (a : Type) `{c : Count a} :=  {
        toNat : a -> nat
      }.

Instance unitEnum : Enum unit := {
                                    toNat := fun _ => 0
                                 }.
Print sum.
Instance plusEnum {a b : Type} `{ea : Enum a} `{eb : Enum b} : Enum (a + b) :=
  {      toNat := fun x => match x with
                        | inl a => toNat a
                        | inr b => (toNat b) + count (a := a)
                        end

        }.

Compute toNat (a := (unit + unit)) (inr tt).

Check @count.
Compute count (a := unit * unit).
(* Compute count unitCount. *)

Open Scope nat.
Definition isdiv f := forall x y z, z * y <= x <-> z <= f x y.
Definition isdivy f y := forall x z, z * y <= x <-> z <= f x.
(*
It's strange. it's a spec for div. We don't need to assume a unique div op.

 *)
Require Import Psatz.

Goal forall x y, x <= y <= x -> x = y. intros. destruct H. Search ( _ <= _ -> _ <= _ -> _ = _). apply Nat.le_antisymm; auto. Qed.

Definition islog f := forall x z, 2 ^ z <= x <-> z <= f x.
Goal forall f, islog f -> f 1 = 0. intros. apply Nat.le_antisymm. unfold islog in H. auto with arith. Focus 2. unfold islog in H. apply H. simpl. constructor. assert (f 1 <= f 1). lia. apply H in H0. assert (forall x, 2 ^ x >= 1). intros. auto with arith. induction x. simpl. lia. simpl. lia.  destruct (f 1). lia.  simpl in H0. assert False. ring_simplify in H0. assert (2 * 1 <= 2 * 2^n ) . Search (_ * _ <= _ * _). apply Nat.mul_le_mono_l. apply H1. lia. destruct H2. Qed.

(* what a mess *)

Theorem pospow : forall y, 1 <= 2 ^ y. intros. auto with arith. Search (_ ^ _). assert (1 ^ y <= 2 ^ y). apply Nat.pow_le_mono_l. lia. Search (1 ^ _). rewrite Nat.pow_1_l in H. auto. Qed.

Goal forall f y, islog f -> (y <= f 1 <-> y <= 0). intros. unfold islog in H. split. intros. apply H in H0.  destruct y. lia. simpl in H0. pose (pospow y). lia. intros. apply H. assert ( y = 0). lia. rewrite H1. simpl. lia. Qed.

(*
Ok, a key fact is that 2^n is monotonic. That makes sense.

2^x <=

 *)

Record Iso {A} {B} (f : A -> B) (g : B -> A) := { to : forall x, f (g x) = x ;
                    from : forall y,  g (f y) = y
                                              }.
Definition id {A : Type} (x : A) := x.

Goal forall A, Iso (A:= A) id id. constructor; intros; unfold id; reflexivity. Qed.

Theorem thingo : {n : nat | n <= 0}. exists 0. auto. Qed.
(*
Goal Iso (A := unit) (B := {n : nat |  Nat.le n 0}) (fun _ => thingo ) (fun _ => tt). constructor. intros. destruct x. destruct x. destruct thingo. destruct x.
*)

(*

isomorphism between n <= m and

Program Instance let's you fill in partial typeclasses

*)

Compute count.
Compute count.

(*  I'm of half a mind to just use pair. *)
Close Scope nat.

Inductive V2 (A : Type) : Type := V2Make : A -> A -> V2 A.
Inductive Kron (f : Type -> Type) (g : Type -> Type) (a : Type) := MkKron : (f (g a)) -> Kron f g a.
Inductive DSum (f : Type -> Type) (g : Type -> Type) (a : Type) := MkDSum : f a -> g a -> DSum f g a.
(* Definition kron f g a := f ( g a)
Definition V2 a := (a,a)

*)

Require Import Psatz.
Definition convex f := forall x y l, 0 <= l <= 1 -> f((1 - l) *  x + l * y) <= (1 - l) * f x + l * f y.
Goal convex (fun x => x). unfold convex. intros. lra. Qed.

Theorem cert1 : forall a x l c, a * x >= 0 -> l >= 0 -> l * a = c -> c * x >= 0.
  Proof. intros. assert (l * (a * x) >= l * 0). Search (_ * _ >= _ * _). apply Rmult_ge_compat_l; auto. ring_simplify in H2. rewrite H1 in H2. auto. Qed.

Definition convex2 f := forall x y lx ly, 0 <= lx <= 1 -> 0 <= ly <= 1 -> lx + ly = 1 ->  f(lx *  x + ly * y) <= lx * f x + ly * f y.
(* Definition convex f := forall x y l, 0 <= l <= 1 -> f((1 - l) *  x + l * y) <= (1 - l) * f x + l * f y. *)
Goal convex (fun x => x * x). unfold convex. intros. psatz R . Qed.
(*   Note on compling csdp for mac os x. i had to remove static flag from flags
and export CC=gcc-9
 *)

Goal forall x, (x * x - 7 * x + 9) ^ 2 >= 0. intros. ring_simplify. (* blow it up *)
                                       try nia. try psatz R. Qed.

Goal convex (fun x => x * x). unfold convex. intros. ring_simplify. assert (l ^ 2 <= l). nra. assert ((x - y)^2 >= 0). assert (Rsqr (x - y) = (x - y)^2). unfold Rsqr. simpl. ring. rewrite <- H1. auto with real. nra. Qed.

Definition epigraph (f : R -> R) (x : R)  y := (f x) <= y.

(*
 compositional rules of convexity

positive Scalar multiples are convex
composition rule

*)
Goal forall a f, a >= 0 -> convex f -> convex (fun x => a * (f x)). Abort.

(* quite an opaque proof as written
https://math.stackexchange.com/questions/580856/proof-of-convexity-of-fx-x2

                                                                                *)

                           (* Search (_ + _ <= _ + _). apply Rplus_le_compat_r.  assert (lx * x * ly * y <= 0).   psatz R 2.
                            *)

(*

Definition min

Given a dual certificate
prove minimality of

we can do the 1d version, and the 2d version.
cert : A * x >= 0 -> l >= 0 -> l * A = c -> c x >= l a

ocaml-python
sympy tactic

find formula using sympy, assert it's truth.

use python solve.
esympy

*)

Definition vsumv1 x y := Build_V1 (v x + v y).
Definition smulv1 s x := Build_V1 (s *(v x)).
Definition vzerov1 : V1 := Build_V1 R 0.
Check vzerov1.
Check vzerov1.
(* Check vsumv1 vzerov1 vzerov1. *)

(* We need to get the ring theory in there. *)
(*
Class Linear (f : Type -> Type) := {
                                   vsum : f R -> f R -> f R ;
                                   smul : R -> f R -> f R;
                                   vzero : f R;

                                 }.
*)

Class LinOps (v : Type) := {
                                   vsum : v -> v -> v;
                                   smul : R -> v -> v;
                                   vzero : v;

                          }.
Require Import Program.Tactics.
Class Linear (a : Type) `{l : LinOps a} := {
       dist_smul : forall x y s, smul s (vsum x y) = vsum (smul s x) (smul s y);
       assoc_vsum : forall x y z, vsum (vsum x y) z = vsum x (vsum y z);
       assoc_smul : forall s s' v, smul s (smul s' v) = smul (s * s') v;
       dist_smul2 : forall s s' v, smul (s + s') v = vsum (smul s v) (smul s' v);
       vsum_comm : forall x y, vsum x y = vsum y x;
       smul_id : forall v, smul 1 v = v;
       vzero_id : forall v, vsum v vzero = v
                             }.

Print Linear.

Notation "s *^ v" := (smul s v) (at level 75, right associativity).
Notation "v ^+^ w" := (vsum v w) (at level 70, right associativity).
Locate "+".
Locate "*".
Instance linOpsR : (LinOps R) := {
                      vsum := Rplus;
                      smul := Rmult;
                      vzero := 0%R

                                }.

Instance linearR : (Linear R). split; intros; simpl; lra.  Qed.

Print linearR.
Print vsum.
(* Print HintDb typeclass_instances. *)

(*
Set Typeclasses Debug.

a -> Prop is morally very much like a -> bool
The difference is in decidability questions, which aren't really where I play
Coq has way more introspection into a -> bool than a runtime/haskell/evulation only model does. It can see the textual definition.

Definition MySet a := a -> Prop
Definition MyRel a b := (a -> Prop) -> (b -> Prop) -> Prop
Definition MyPro a b := (a -> bool) -> list b ->
(a -> Prop) -> Prop  ? Partialy applied
(a -> bool) -> bool -- finitely probing?
(a -> Prop) -> a

class Canon a where
   canon :: a -> a

canonicalizing a relationship for quotienting. Very natrual

DSum f g = (f,g) -- no i already did this.

Solving systems -- QR is easiest.

Duality
A x == 0
A^T l == 0

[x,y,z...] = 0

 f f = identity matrix

Class basisOps v := {
      basis : list v {- list is a little weak
}
Laws?
Class basis v := {
      complete : forall v, exists l, v = vsum smul l basis
      independnet : not (exists l vsum basis = head basis)
}

complete : sum u <u,x> u = x
orthonormal :

instance basis R {
         basis = [1]
}

instance basis unit {
    basis = []
}
instance basis (x,y) {
    basis = (map dsum vzero basis) append (map dsum x  vzero basis)
    orthonormal = forall u1 u2, u1 elem basis, u2 elem basis, Reflect (dot u1 u2 ?= 1) (u1 = u2)

}

instance Outer R x := x

instance Outer Unit x = Unit

instance Outer (a,b) x := Outer a x, Outer ta x :=

class Scalar {}

*)

Instance linopsunit : (LinOps unit) := {
                                        vsum := fun _ _ => tt;
                                        smul := fun _ _ => tt;
                                        vzero := tt
                                      }.

Instance linearunit : (Linear unit). split; intros; simpl; auto; destruct v0. auto. auto. Qed.

Instance linopspair a b `{LinOps a} `{LinOps b}  : LinOps (a * b) :=
  {

    vsum := fun v1 v2 => ( (fst v1) ^+^ (fst v2) , (snd v1) ^+^ (snd v2 ));
    smul := fun s v => ( s *^ (fst v) , s *^ (snd v));
    vzero := (vzero, vzero)
    }.

Instance linearpair a b `{lina : Linear a} `{ linb : Linear b}  : Linear (a * b).  destruct lina. destruct linb. split; intros; simpl; try congruence.
- destruct v0. simpl. rewrite smul_id1; rewrite smul_id0; auto.
- destruct v0. simpl.  rewrite vzero_id1; rewrite vzero_id0; auto.
Qed.

Print nat.

Fixpoint V (n : nat) := match n with
                      | O => unit
                      | S n' => prod R (V n')
                      end.

Compute (vzero : (V 4)).
Compute (vzero : (V 5)).

Theorem vzero_id_l A  `{l : Linear A} (v : A) :  vsum vzero v = v.
  Proof. rewrite vsum_comm. rewrite vzero_id. auto. Qed.

(*
Norm?
Metric

I shouldn't call these metric. Hilbert maybe?

*)

 Class MetricOps v `{LinOps v} := {
                      dot : v -> v -> R
                      }.

 Class Metric v `{MetricOps v} `{Linear v} := {
                  pos_dot : forall v, 0 <= dot v v;
                  sym_dot : forall v w, dot v w = dot w v;
                  lin_dot : forall v w u, dot v (w ^+^ u) = (dot v w) + (dot v u);
                  lin_dot2 : forall v w s, dot v (s *^ w) = s * (dot v w)

                                             }.

 Instance metopunit : MetricOps unit := {
   dot := fun _ _ => 0
                                       }.

 Instance metopreal : MetricOps R := { dot := fun x y => x * y }.

 Instance metoprod a b `{MetricOps a} `{MetricOps b} : MetricOps (a * b) := {
    dot := fun x y => (dot (fst x) (fst y)) + (dot (snd x) (snd y)) }.

 Instance metricunit : Metric unit.
 split; auto with real. Qed.

Search (0 <= Rsqr _).

Instance metricreal : Metric R.
split; intros; simpl; nra. Qed.

Instance metricprod a b `{ma : Metric a} `{mb : Metric b} : Metric (a * b).
Proof.
  destruct ma. destruct mb. split; intros; simpl.
  - simpl. Search (0 <= _ + _). apply Rplus_le_le_0_compat; auto.
  - simpl. rewrite sym_dot0. rewrite sym_dot1. auto.
  - simpl. rewrite lin_dot0. rewrite lin_dot1. simpl. lra.
  - simpl. rewrite lin_dot3. rewrite lin_dot4. simpl. lra.
Qed.

Definition Cone {A} `{Linear A} (P : A -> Prop) := forall l v, P v -> l >= 0 -> P (smul l v).
Goal Cone (fun x => x >= 0). unfold Cone. intros. simpl. nra. Qed.
Goal Cone (fun (v : R*R) => let ( x, y ) := v in x >= 0 /\ y >= 0). unfold Cone. simpl. intros. destruct v0. simpl. nra. Qed.
Goal forall {a} `{la : Metric a} (w : a), Cone (fun v => dot w v >= 0).
  intros. unfold Cone. intros. rewrite lin_dot2. nra. Qed.

Class Quadrant a  `{Linear a} := {  quadrant : a -> Prop; conequad : Cone quadrant}.
Instance quadr : Quadrant R := {  quadrant := fun x => x >= 0}.
unfold Cone. intros. simpl. nra. Qed.

Instance quadprod a b `{Quadrant a} `{Quadrant b} : Quadrant (a * b) := {quadrant := fun x => quadrant (fst x) /\  quadrant (snd x)  }.
unfold Cone. intros. simpl.  destruct H3. split; apply conequad; auto.  Qed.

Theorem cone_conj : forall P Q, Cone P -> Cone Q -> Cone (fun x => P x /\ Q x).
  intros. unfold Cone. intros. destruct H1. split; auto. Qed.

Definition DualCone {A} `{Metric A} (P : A -> Prop) := fun w => forall x, P x -> dot w x >= 0.

Theorem dcone : forall A `{Metric A} (P : A -> Prop), Cone (DualCone P). intros. unfold Cone. intros. unfold DualCone. intros. rewrite sym_dot. rewrite lin_dot2. rewrite sym_dot.

(*

Contlens
| _ => : Is this constructive point-wise continuity?

Contructive cones.
(a -> Prop) -> Prop
feels rather non contrusctive (I wouldn't necessarily want this in Haskell)
cone :: (a -> Bool) -> Bool would never be a function I write

Why not list?
Need to trim upper zeros. That's not so bad

*)

Search R.
Require Import QArith.
Search (Q -> Q -> bool).
Print Scope Q_scope.
Print Qeq.
Print Qeq_bool.
Search nil.
Print list.
Close Scope R.

Fixpoint trimzero (l : list Q) : list Q  := match l with
             | List.cons x xs => if (Qeq_bool 0 x)%Q then trimzero xs else l
             | List.nil     =>  List.nil
             end.
Definition canonlist l : list Q := List.rev (trimzero (List.rev l)).

Compute canonlist (List.cons 1 (List.cons 0 (List.nil))).

Fixpoint vsumlist l l' := match l, l' with
                            | List.cons x xs, List.cons y ys => List.cons (x + y) (vsumlist xs ys)
                            | List.nil, ys => ys
                            | xs, List.nil => xs
                            end.
Definition vzerolist {A} := @List.nil A.

Definition smullist s l := List.map (fun x => s * x) l.

(*

list is ambiently in an infinite dimensional space with finite nonzeros.

*)

Compute trimzero (List.cons 0 List.nil).

(*

Quadrant
Elementwise
Functor

*)

Compute ((1,2), 4) ^+^ ((1,3), 8).

Goal forall x y : R, (x ^+^ y) = (y ^+^ x). intros. auto with real. Qed.
Goal forall x y : R * R, (x ^+^ y) = (y ^+^ x). intros. destruct x. destruct y. unfold vsum. simpl.   auto with real.

(*
    Definition LinFun {Linear a} {Linear b} a b := {f : a -> b | f (vsum a a') = vsum (f a) (f a') /\
                             f (smul x a) = smul x (f a) }
*)

(*
     dist_smul : forall x y s, smul s (vsum x y) = vsum (smul s x) (smul s y);
        assoc_vsum : forall x y z, (vsum (vsum x y) z) = vsum (vsum x y) z;
            assoc_smul : forall s s' v, smul s (smul s' v) = smul (s * s') v;
       dist_smul2 : forall s s'smul (s + s') v = vsum (smul s v) (smul s' v);
         vsum_comm : vsum x y = vsum y x;
        smul_id : smul 1 v = v;
        vzero_id : vsum v vzero = v
*)

Definition cone P := forall l, l >= 0 -> P x -> P (l ^* x).

Program Instance linearV1 : Linear V1 := {

                         smul s v := match v with
                                     | (V1Make _ x) => V1Make _ (s * x)
                                     end;
                         vzero := V1Make _ 0
                         dist_smul :=
                                        }.

Instance linearDSum (f : Type -> Type) (g : Type -> Type) `{Linear f} `{Linear g}  : Linear (DSum f g) nat := {
                         vsum := fun v w => match v,w with
                                         | (MkDSum _ _ _ f g), (MkDSum _ _ _ f' g') => MkDSum _ _ _ (f ^+^ f') (g ^+^ g')
                                         end;
                         smul s v := match v with
                                     | (MkDSum _ _ _ f g) => MkDSum _ _ _ (s *^ f) (s *^ g)
                                     end;
                         vzero := MkDSum _ _ _ vzero vzero
                                  }.

Definition v1one := V1Make _ 1.
Compute v1one ^+^ v1one.
Definition v2one := MkDSum _ _ _ v1one v1one.
Compute v2one ^+^ v2one.

(*

Compute (1)%R.
Compute (1 + 1)%R.
Local Open Scope R_scope.

Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1.
Proof.
  destruct 1. red. auto with real. auto with real.
Qed.

Lemma Rle_refl : forall r, r <= r.
Proof.
  intro. red. right. reflexivity.
Qed.

Lemma Rge_refl : forall r, r <= r.
Proof. intro. right. reflexivity. Qed.
(* Proof. exact Rle_refl. Qed. *)

Print Rlt_asym.
Lemma Rlt_irrefl : forall r, ~ r < r.
Proof.
  intros r H. eapply Rlt_asym. apply H. apply H.
Qed.Lemma Rlt_irrefl : forall r, ~ r < r.

(* Solution at https://github.com/coq/coq/blob/master/theories/Reals/RIneq.v
I should try to do them on my own
*)
Theorem square_pos : forall (x : R),  0 <= Rmult x x.
Proof.
  (*
  apply Rle_0_sqr.
  Qed. *)
  intros r.
  Print Hint.
  case (Rlt_le_dec r 0).
  intro H.
  replace (r * r) with (- r * - r).
  auto with real. (* This is not working *)

  About Rlt_le_dec.
  auto with real.

  destruct (total_order_T x 0).
  destruct s.

  Rmult_lt_compat_l.

  (**

  Define LinOp
  record LinOp

  define contractive as
  |A v| <= |v|

  prove using complete basis
  Chain them

  Define polytope region using corner
  show that goes inside region in fitie time

  Define V1 V2 Product and Compose

  define Vector space type class
  vadd
  smul

  *)

  *)


Require Export CatSem.CAT.cat_TYPE.
Require Export CatSem.CAT.monad_haskell.
Require Export CatSem.CAT.rmonad.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.
Unset Transparent Obligations.

Obligation Tactic := simpl; intros;
   try unf_Proper; intros;
   repeat match goal with [H : option _ |- _ ] => destruct H end;
   auto.

Program Instance option_monad_s :
  Monad_struct (C:=TYPE) (option) := {
  weta := @Some ;
  kleisli a b f := fun t => match t with
                   | Some y => f y
                   | None => None
                   end
}.

Definition option_monad := Build_Monad option_monad_s.

Definition option_default (V W : TYPE) (f : V ---> W)
            (w: W): option V ---> W := fun v =>
  match v with
  | None => w
  | Some  v' => (f v')
  end.


(*** Barrett Reduction *)
(** This file implements Barrett Reduction on [ZLikeOps].  We follow
    [BarretReduction/ZHandbook.v]. *)
Require Import Coq.ZArith.ZArith Coq.Lists.List Coq.Classes.Morphisms Coq.micromega.Psatz.
Require Import Crypto.Arithmetic.BarrettReduction.HAC.
Require Import Crypto.LegacyArithmetic.ZBounded.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Notations.

Local Open Scope small_zlike_scope.
Local Open Scope large_zlike_scope.
Local Open Scope Z_scope.

Section barrett.
  Context (m b k μ offset : Z)
          (m_pos : 0 < m)
          (base_pos : 0 < b)
          (k_good : m < b^k)
          (μ_good : μ = b^(2*k) / m) (* [/] is [Z.div], which is truncated *)
          (offset_nonneg : 0 <= offset)
          (k_big_enough : offset <= k)
          (m_small : 3 * m <= b^(k+offset))
          (m_large : b^(k-offset) <= m + 1).
  Context {ops : ZLikeOps (b^(k+offset)) (b^(k-offset)) m} {props : ZLikeProperties ops}
          (μ' : SmallT)
          (μ'_good : small_valid μ')
          (μ'_eq : decode_small μ' = μ).

  Definition barrett_reduce : forall x : LargeT,
      { barrett_reduce : SmallT
      | medium_valid x
        -> decode_small barrett_reduce = (decode_large x) mod m
           /\ small_valid barrett_reduce }.
  Proof.
    intro x. evar (pr : SmallT); exists pr. intros x_valid.
    assert (0 <= decode_large x < b^(k+offset) * b^(k-offset)) by auto using decode_medium_valid.
    assert (0 <= decode_large x < b^(2 * k)) by (autorewrite with pull_Zpow zsimplify in *; omega).
    assert ((decode_large x) mod b^(k-offset) < b^(k-offset)) by auto with zarith omega.
    rewrite (barrett_reduction_small m b (decode_large x) k μ offset) by omega.
    rewrite <- μ'_eq.
    pull_zlike_decode; cbv zeta; pull_zlike_decode. (* Extra [cbv iota; pull_zlike_decode] to work around bug #4165 (https://coq.inria.fr/bugs/show_bug.cgi?id=4165) in 8.4 *)
    subst pr; split; [ reflexivity | exact _ ].
  Defined.

  Definition barrett_reduce_function : LargeT -> SmallT
    := Eval cbv [proj1_sig barrett_reduce]
      in fun x => proj1_sig (barrett_reduce x).
  Lemma barrett_reduce_correct x
    : medium_valid x
      -> decode_small (barrett_reduce_function x) = (decode_large x) mod m
         /\ small_valid (barrett_reduce_function x).
  Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg μ'_eq μ'_good μ_good.
    exact (proj2_sig (barrett_reduce x)).
  Qed.
End barrett.

Module BarrettBundled.
  Class BarrettParameters :=
    { m : Z;
      b : Z;
      k : Z;
      offset : Z;
      μ := b ^ (2 * k) / m;
      ops : ZLikeOps (b ^ (k + offset)) (b ^ (k - offset)) m;
      μ' : SmallT }.
  Global Existing Instance ops.

  Class BarrettParametersCorrect {params : BarrettParameters} :=
    { m_pos : 0 < m;
      base_pos : 0 < b;
      offset_nonneg : 0 <= offset;
      k_big_enough : offset <= k;
      m_small : 3 * m <= b ^ (k + offset);
      m_large : b ^ (k - offset) <= m + 1;
      props : ZLikeProperties ops;
      μ'_good : small_valid μ';
      μ'_eq : decode_small μ' = μ }.
  Global Arguments BarrettParametersCorrect : clear implicits.
  Global Existing Instance props.

  Module Export functions.
    Definition barrett_reduce_function_bundled {params : BarrettParameters}
    : LargeT -> SmallT
      := barrett_reduce_function m b k offset μ'.
    Definition barrett_reduce_correct_bundled {params : BarrettParameters} {params_proofs : BarrettParametersCorrect params}
      : forall x, medium_valid x
                  -> decode_small (barrett_reduce_function_bundled x) = (decode_large x) mod m
                     /\ small_valid (barrett_reduce_function_bundled x)
      := @barrett_reduce_correct
           m b k μ offset
           m_pos base_pos eq_refl offset_nonneg
           k_big_enough m_small m_large
           ops props μ' μ'_good μ'_eq.
  End functions.
End BarrettBundled.
Export BarrettBundled.functions.
Global Existing Instance BarrettBundled.ops.
Global Arguments BarrettBundled.BarrettParametersCorrect : clear implicits.
Global Existing Instance BarrettBundled.props.


Require Import Arith List.
Require Import BellantoniCook.Lib BellantoniCook.BC BellantoniCook.BCI BellantoniCook.BCI_to_BC.

Fixpoint convI (e : BC) : BCI :=
  match e with
    | zero => zeroI
    | proj n s i =>
      if leb (S i) n then projIn i else projIs (i - n)
    | succ b => succI b
    | pred => predI
    | cond => condI
    | rec g h0 h1 => recI (convI g) (convI h0) (convI h1)
    | comp n s g ln ls =>
      compI (convI g) (map convI ln) (map convI ls)
  end.

Opaque maxl.

Lemma convI_inf_correct : forall (e : BC) n s,
  arities e = ok_arities n s ->
  exists n', exists s',
    n' <= n /\ s' <= s /\ inf (convI e) = I n' s'.
Proof.
  apply BC_ind_inf; simpl; intros.
  exists 0; exists 0; auto.

  destruct n; simpl.
  exists 0; exists (S (i - 0)).
  repeat (split; try omega).
  case_eq (leb i n); intros; simpl.
  apply leb_complete in H0.
  exists (S i); exists 0.
  repeat (split; try omega).
  apply leb_complete_conv in H0.
  exists 0; exists (S (i - S n)).
  repeat (split; try omega).

  exists 0; exists 1; auto.
  exists 0; exists 1; auto.
  exists 0; exists 4; auto.

  destruct H2 as (ne1 & se1 & He1).
  destruct H3 as (ne2 & se2 & He2).
  destruct H4 as (ne3 & se3 & He3).
  decompose [and] He1; decompose [and] He2; decompose [and] He3.
  clear He1 He2 He3.
  rewrite H5, H8, H11.
  eexists; eexists.
  split; try split.
  3: eauto.
  apply maxl_bound; omega.
  apply maxl_bound; omega.

  destruct H2 as (ne & se & He).
  decompose [and] He; clear He.
  rewrite H7.
  repeat rewrite leb_correct.
  simpl.
  case_eq ( inf_list (map inf (map convI rl)) ) ; intros.
  case_eq ( inf_list (map inf (map convI tl)) ) ; intros.
  case_eq (beq_nat n1 0); intros.
  eexists; eexists; split; try split.
  3: eauto.
  apply Nat.max_lub.
  apply inf_list_maxl_l in H5.
  rewrite H5.
  rewrite map_map.
  rewrite map_map.
  apply maxl_bound_in.
  intros.
  apply in_map_iff in H10.
  destruct H10 as [? [? ?]].
  destruct (H3 x H11) as (? & ? & ?).
  decompose [and] H12.
  subst.
  rewrite H16; simpl; trivial.
  apply inf_list_maxl_l in H8.
  rewrite H8.
  rewrite map_map.
  rewrite map_map.
  apply maxl_bound_in.
  intros.
  apply in_map_iff in H10.
  destruct H10 as [? [? ?]].
  destruct (H4 x H11) as (? & ? & ?).
  decompose [and] H12.
  subst.
  rewrite H16; simpl; trivial.
  apply inf_list_maxl_r in H8.
  rewrite H8.
  rewrite map_map.
  rewrite map_map.
  apply maxl_bound_in.
  intros.
  apply in_map_iff in H10.
  destruct H10 as [? [? ?]].
  destruct (H4 x H11) as (? & ? & ?).
  decompose [and] H12.
  subst.
  rewrite H16; simpl; trivial.
  apply beq_nat_false in H9.
  elim H9.
  apply inf_list_maxl_r in H5.
  rewrite H5, map_map, map_map.
  apply maxl_map_0.
  intros.
  destruct (H3 x H10) as (? & ? & ?).
  decompose [and] H11.
  subst.
  rewrite H15; simpl; trivial.
  omega.

  elimtype False.
  apply in_inf_list_err_conv in H8.
  destruct H8.
  rewrite map_map in H8.
  apply in_map_iff in H8.
  destruct H8 as [? [? ?]].
  destruct (H4 x0 H9) as (? & ? & ?).
  decompose [and] H10.
  rewrite H8 in H14; discriminate.

  elimtype False.
  apply in_inf_list_err_conv in H5.
  destruct H5.
  rewrite map_map in H5.
  apply in_map_iff in H5.
  destruct H5 as [? [? ?]].
  destruct (H3 x0 H8) as (? & ? & ?).
  decompose [and] H9.
  rewrite H5 in H13; discriminate.

  rewrite map_length; omega.
  rewrite map_length; omega.
Qed.

Lemma convI_correct : forall e n s,
  arities e = ok_arities n s ->
  forall vnl vsl,
  semI (convI e) vnl vsl = sem e vnl vsl.
Proof.
  refine (BC_ind_inf _ _ _ _ _ _ _ _); simpl; intros; trivial.
  destruct n; simpl; trivial.
  case_eq (leb i n); intros; simpl; trivial.
  induction (hd nil vnl); simpl; intros; auto.
  rewrite IHl; case a; auto.
  rewrite H2.
  f_equal.
  rewrite map_map.
  apply map_ext2; auto.
  rewrite map_map.
  apply map_ext2; auto.
Qed.


(** * 6.887 Formal Reasoning About Programs - Lab 3
    * Model Checking, including abstraction *)

Require Import Frap.

Set Implicit Arguments.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(* Examples based on ideas introduced in ModelChecking.v, from the book source.
 * Key definitions about model checking are imported from the Frap library. *)

(* Use model checking to verify the following program
 * against the property that j==3 when the program finishes.

  <<
  int i = 0;
  int j = 0;

  void foo() {
    while (i <= 2){
      ++i;
      ++j;
    }
  }
  >>
*)

(* CHALLENGE #1: We've made a small mistake in formalizing this program as a
 * transition system.  Correct the mistake.  (Otherwise, the program will not,
 * in fact, satisfy the spec!) *)

Inductive pc :=
| Loop
| i_add_1
| j_add_1
| Done.

Record vars := {
  I : nat;
  J : nat
}.

Record state := {
  Pc : pc;
  Vars : vars
}.

Definition foo_init := { {| Pc := Loop; Vars := {| I := 0; J := 0 |} |} }.

Inductive step : state -> state -> Prop :=
| Step_Loop_done : forall i j, i = 3 /\ j = 3 ->
    step {| Pc := Loop; Vars := {| I := i;
                                   J := j |} |}
         {| Pc := Done; Vars := {| I := i;
                                   J := j |} |}
| Step_Loop_enter : forall i j, i < 3 /\ j < 3 ->
    step {| Pc := Loop; Vars := {| I := i;
                                   J := j |} |}
         {| Pc := i_add_1; Vars := {| I := i;
                                      J := j |} |}
| Step_i_add_1 : forall i j,
    step {| Pc := i_add_1; Vars := {| I := i;
                                      J := j |} |}
         {| Pc := j_add_1; Vars := {| I := 1 + i;
                                      J := j |} |}
| Step_j_add_1 : forall i j,
    step {| Pc := j_add_1; Vars := {| I := i;
                                      J := j |} |}
         {| Pc := Loop; Vars := {| I := i;
                                   J := 1 + j |} |}.

Definition foo_sys := {|
  Initial := foo_init;
  Step := step
|}.

Definition foo_correct (st : state) :=
  st.(Pc) = Done -> st.(Vars).(J) = 3.

(* A hint to help the model checker, related to when to unfold definitions *)
Arguments foo_correct / .

(* CHALLENGE #2: Prove the system correct.
 * WARNING: with the broken system above, the model checker is likely to run for
 * intractably long!  However, when you fix the system definition, this should
 * be a very easy proof, thanks to the magic of automatic state-space
 * exploration. *)
Theorem foo_ok :
  invariantFor foo_sys foo_correct.
Proof.
  model_check.
Qed.

(* Next, we'll look at verifying the following two-thread producer/consumer
 * program against the property that MIN <= x <= MAX always holds.

  <<
  x = MIN;

  void producer(){
    while(true){
      lock();
      if (x < MAX) {
        ++x;
      }
      unlock();
    }
  }

  void consumer(){
    while(true){
      lock();
      if (x > MIN) {
        --x;
      }
      unlock();
    }
  }
  >>
*)

(* Here's our formal encoding of the system, which this time you can trust to be
 * correct. *)

Notation num := nat.

Section prco.
  (* We use sections and variables to introduce local, unknown parameters. *)
  Variable MIN : num.
  Variable MAX : num.

  Record shared_state val := { Locked : bool; X : val }.

  Inductive producer_pc :=
  | PrLock
  | PrTest
  | PrInc
  | PrUnlock.

  Definition producer_state := threaded_state (shared_state num) producer_pc.

  Definition producer_init := { {| Shared := {| Locked := false; X := MIN |};
                                   Private := PrLock |} }.

  Inductive producer_step : producer_state -> producer_state -> Prop :=
  | PrStep_Lock : forall x,
      producer_step {| Shared := {| Locked := false; X := x|}; Private := PrLock |}
                    {| Shared := {| Locked := true; X := x|}; Private := PrTest |}
  | PrStep_Test_true : forall l x,
      x < MAX ->
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := PrInc |}
  | PrStep_Test_false : forall l x,
      x >= MAX ->
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := PrUnlock |}
  | PrStep_Inc : forall l x,
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrInc |}
                    {| Shared := {| Locked := l; X := 1 + x|}; Private := PrUnlock |}
  | PrStep_Unlock : forall l x,
      producer_step {| Shared := {| Locked := l; X := x|}; Private := PrUnlock |}
                    {| Shared := {| Locked := false; X := x|}; Private := PrLock |}.

  Definition producer_sys := {|
    Initial := producer_init;
    Step := producer_step
  |}.

  Inductive consumer_pc :=
  | CoLock
  | CoTest
  | CoDec
  | CoUnlock.

  Definition consumer_state := threaded_state (shared_state num) consumer_pc.

  Definition consumer_init := { {| Shared := {| Locked := false; X := MIN |};
                                   Private := CoLock |} }.

  Inductive consumer_step : consumer_state -> consumer_state -> Prop :=
  | CoStep_Lock : forall x,
      consumer_step {| Shared := {| Locked := false; X := x|}; Private := CoLock |}
                    {| Shared := {| Locked := true; X := x|}; Private := CoTest |}
  | CoStep_Test_true : forall l x,
      x > MIN ->
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := CoDec |}
  | CoStep_Test_false : forall l x,
      x <= MIN ->
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoTest |}
                    {| Shared := {| Locked := l; X := x|}; Private := CoUnlock |}
  | CoStep_Dec : forall l x,
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoDec |}
                    {| Shared := {| Locked := l; X := x - 1|}; Private := CoUnlock |}
  | CoStep_Unlock : forall l x,
      consumer_step {| Shared := {| Locked := l; X := x|}; Private := CoUnlock |}
                    {| Shared := {| Locked := false; X := x|}; Private := CoLock |}.

  Definition consumer_sys := {|
    Initial := consumer_init;
    Step := consumer_step
  |}.

  Definition prco_sys := parallel producer_sys consumer_sys.

  Definition prco_state := threaded_state (shared_state num) (producer_pc * consumer_pc).

  Definition prco_correct (s : prco_state) :=
    MIN <= s.(Shared).(X) <= MAX.

  (* Let's re-express the combined initial state as a singleton set. *)
  Theorem prco_init_is :
    parallel1 producer_init consumer_init = { {| Shared := {| Locked := false; X := MIN|};
                                                 Private := (PrLock, CoLock) |} }.
  Proof.
    simplify.
    apply sets_equal; simplify.
    propositional.
    {
      invert H; invert H2; invert H4; equality.
    }
    invert H0.
    repeat constructor.
  Qed.

End prco.

Hint Rewrite prco_init_is.
Arguments prco_correct / .

(* We can try model checking [proco_sys] with different [MIN] and [MAX]
 * values. *)
Theorem prco_ok_example :
  invariantFor (prco_sys 1 2) (prco_correct 1 2).
Proof.
  Time model_check_find_invariant.
  model_check_finish.
Qed.

(* But the time for model checking grows rapidly with larger constants.
 * We should apply abstraction. *)

(* CHALLENGE #3: Come up with a suitable abstraction of this system and use it
 * to verify the original program *for all [MIN] and [MAX] values (assuming 0 < MIN < MAX)*, by reduction
 * to a finite-state system that can be model checked. *)

Section prco_a.

  Variable MIN : num.
  Variable MAX : num.
  (* We make this assumption about MIN and MAX, which becomes a hypothesis that can be used in the following part of the section *)
  Hypothesis MIN_MAX : 0 < MIN < MAX.

  Theorem prco_ok :
    invariantFor (prco_sys MIN MAX) (prco_correct MIN MAX).
  Proof.
  Admitted.

End prco_a.


Require Import List EqdepClass.
Require Export EquivDec.

Set Implicit Arguments.
Set Strict Implicit.

Theorem EquivDec_refl_left (T : Type) {c : EqDec T (@eq T)} :
  forall (n : T), equiv_dec n n = left (refl_equal _).
Proof.
  intros. destruct (equiv_dec n n); try congruence.
  Require Eqdep_dec.
  rewrite (Eqdep_dec.UIP_dec (A := T) (@equiv_dec _ _ _ c) e (refl_equal _)).
  reflexivity.
Qed.

Class SemiDec (t : Type) : Type :=
{ seq_dec : forall a b : t, option (a = b) }.
Global Instance EquivDec_SemiDec t (EQ : EqDec t (@eq t)) : SemiDec t :=
{ seq_dec := fun a b =>
  match equiv_dec a b with
    | left pf => Some pf
    | right _ => None
  end
}.

Theorem SemiDec_EquivDec_refl_left : forall T (equ : EqDec T (@eq T)),
  forall x, @seq_dec T (@EquivDec_SemiDec _ equ) x x = Some refl_equal.
Proof.
  intros; unfold seq_dec, EquivDec_SemiDec. rewrite EquivDec_refl_left. reflexivity.
Qed.

Global Instance EquivDec_bool : EqDec bool (@eq bool).
red.
refine (
  fun a b =>
    match a as a , b as b return {a === b} + {a =/= b} with
      | true , true => left (refl_equal true)
      | false , false => left (refl_equal false)
      | _ , _ => right _
    end); abstract congruence.
Defined.

Global Instance EquivDec_nat : EqDec nat (@eq nat) :=
  Peano_dec.eq_nat_dec.

Global Instance SemiDec_option T (S : SemiDec T) : SemiDec (option T) :=
{ seq_dec := fun a b =>
  match a as a, b as b return option (a = b) with
    | None , None => Some (refl_equal _)
    | Some x , Some y =>
      match seq_dec x y with
        | None => None
        | Some pf =>
          match pf in _ = t return option (Some x = Some t) with
            | refl_equal => Some (refl_equal _)
          end
      end
    | _ , _ => None
  end
}.

Global Instance SemiDec_list T (S : SemiDec T) : SemiDec (list T) :=
{ seq_dec := fix seq_dec' a b : option (a = b) :=
  match a as a, b as b return option (a = b) with
    | nil , nil => Some (refl_equal _)
    | x :: xs , y :: ys =>
      match seq_dec x y with
        | None => None
        | Some pf =>
          match seq_dec' xs ys with
            | None => None
            | Some pf' =>
              match pf in _ = t , pf' in _ = t' return option (x :: xs = t :: t') with
                | refl_equal , refl_equal => Some (refl_equal _)
              end
          end
      end
    | _ , _ => None
  end
}.

Inductive dcomp T (a b : T) : Type :=
| Lt | Gt | Eq : a = b -> dcomp a b.

Class Comparable (t : Type) : Type :=
{ cmp_dec : forall a b : t, dcomp a b }.
Class SemiComparable (t : Type) : Type :=
{ scmp_dec : forall a b : t, option (dcomp a b) }.
Global Instance Comparable_SemiComparable t (SC : Comparable t)
  : SemiComparable t :=
{ scmp_dec := fun a b => Some (cmp_dec a b) }.

Global Instance Comparable_nat : Comparable nat :=
{| cmp_dec :=
   fun a b => match Compare_dec.lt_eq_lt_dec a b with
                | inleft (left _) => Lt _ _
                | inleft (right pf) => Eq pf
                | inright _ => Gt _ _
              end
|}.


Require Export Coq.PArith.BinPosDef.
Require Export Coq.ZArith.BinIntDef.
Require Export Coq.Strings.BinaryString.
Require Export Coq.Strings.HexString.
Require Export Ascii String.
Require Export Coq.Strings.Ascii.
Require Export Coq.Strings.String.
Require Export Coq.Lists.List.
Require Export NArith.
Require Export Psatz.

Require Export Constants.
Require Export Byte.

Export ListNotations.

Export N.

Definition word_size := 32%N.
Definition half_word_size := 16%N.
Definition modulus_ws := shiftl 1 word_size.
Definition half_modulus_ws := div2 modulus_ws.
Definition hfws_modulus := shiftl 1 half_word_size.
Definition mask_ws := sub modulus_ws 1.
Definition mask_hfws := sub half_modulus_ws 1.

Definition shiftr1_cyc (len : N)(n : N) : N :=
  let half_modulus := shiftl 1 (len - 1) in
    match n with
    | N0 => N0
    | Npos p =>
        match p with
        | xH => half_modulus
        | xO p' => Npos p'
        | xI p' => half_modulus + Npos p'
        end
    end.

(* n >>> t*)
Definition shiftr_cyc (len : N)(n : N) (t : N) : N :=
  N.iter t (shiftr1_cyc len) n.

Definition shiftr_cyc_ws := shiftr_cyc word_size.

Infix ">>>" := shiftr_cyc_ws (at level 35).

Definition shiftl_cyc (len : N)(n: N) (t : N) : N :=
  shiftr_cyc len n (len - (t mod len)).

Definition shiftl_cyc_ws := shiftl_cyc word_size.

Infix "<<<" := shiftl_cyc_ws (at level 35).
Infix "$" := lxor (at level 50).

Definition mask_14 (A : N) : N :=
  shiftr (land A (shiftl mask_ws (word_size * 3))) (word_size * 3).
Definition mask_24 (A : N) : N :=
  shiftr (land A (shiftl mask_ws (word_size * 2))) (word_size * 2).
Definition mask_34 (A : N) : N :=
  shiftr (land A (shiftl mask_ws (word_size * 1))) (word_size * 1).
Definition mask_44 (A : N) : N :=
  land A mask_ws.
(* https://en.cppreference.com/w/c/language/operator_precedence *)
(* Bit-wise operation are below + -*)
Infix "/\" := N.land : N_scope.
Infix "\/" := N.lor : N_scope.
(* ~ n with respect to word_size *)
Definition neg_ws (n : N) : N :=
  n $ mask_ws.
Notation "~ n" := (neg_ws n) (at level 75, right associativity) : N_scope.

Definition add_ws (m : N)(n : N) : N :=
  (m + n) /\ mask_ws.

Infix "+ws" := add_ws (at level 50): N_scope.

(* Replace old with acc within s *)
Fixpoint RepChar_tail (s : string)(old : ascii)(new acc : string) : string :=
  match s with
  | "" => acc
  | String h t =>
      RepChar_tail t old new (acc ++
        if Ascii.eqb h old then new else (String h "")
      )
  end.

Definition RepChar (s : string)(old : ascii)(new : string) : string :=
  RepChar_tail s old new "".

(* returns the prefix of length k * the rest *)
Fixpoint partList_tail (A : Type)(l : list A)(len : nat)(acc : list A * list A) : list A * list A :=
  match len with
  | O => acc
  | S len' =>
      match l with
      | [] => acc
      | h :: tl =>
          partList_tail A tl len' ((List.app (fst acc) [h]), List.tl (snd acc))
      end
  end.

Definition partList {A} (l : list A)(len : nat) :=
  partList_tail A l len ([], l).

Definition partListBack {A} (l : list A)(backLen : nat) :=
  partList l ((List.length l) - backLen).

Fixpoint subList_tail {A} (start : nat)(length : nat)(l : list A)(acc : list A) :=
  match l with
  | [] => acc
  | h :: tl =>
    match start with
    | S start' => subList_tail start' length tl acc
    | O =>
       match length with
       | O => acc
       | S length' =>
          subList_tail start length' tl (acc ++ [h])
       end
    end
  end.

Definition subList {A} (start : nat)(length : nat)(l : list A) :=
  subList_tail start length l [].

(* ceil(x/y) *)
Definition div_ceil_nat (x : nat)(y : nat) : nat :=
  Nat.div (x + y - 1%nat) y.
Definition div_ceil_N (x : N)(y : N) : N :=
  N.div (x + y - 1%N) y.

Inductive optErr (A : Type) : Type :=
| Normal : A -> optErr A
| Error : string -> optErr A.

Arguments Normal {A} _.
Arguments Error {A}.

Fixpoint Nlist_tail (k : nat)(acc : list N) : list N :=
  match k with
  | O => acc
  | S k' =>
      Nlist_tail k' ((N.of_nat k') :: acc)
  end.

(*Generates [0; 1; 2; ... ; len - 1]*)
Definition Nlist (len : N) : list N :=
  Nlist_tail (N.to_nat len) [].

(* Try each element x in l with func : option N.
* If func x is not None then return its value otherwise keep trying.
* If all None then return None. *)
Fixpoint TryFunWithList (func : N -> option N)(l : list N) : option N :=
  match l with
  | [] => None
  | x :: tl =>
      match func x with
      | Some y => Some y
      | None => TryFunWithList func tl
      end
  end.

(*funcs upon prefix..XXXX, where XXXX is of length len *)
Fixpoint BinaryMapLen_fix (func : N -> N)(len : nat)(prefix : N) : list N :=
  match len with
  | O => [func prefix] (* only one number *)
  | S len' =>
      (BinaryMapLen_fix func len' (double prefix)) ++ (* appending a 0 to prefix, len-- *)
      (BinaryMapLen_fix func len' (succ_double prefix)) (* appending a 1 to prefix, len-- *)
  end.

(*maps func on all Ns within length len*)
Definition BinaryMapLen (func : N -> N)(len : nat) : list N :=
  BinaryMapLen_fix func len 0.

(*
Compute BinaryMapLen N.square 4. (*Correct*)
*)

Open Scope list_scope.
(* This approach does work. But accumulated modifying func could be too complicated *)
(*
Fixpoint BinaryMap_pos (func : positive -> N)(p : positive) : list N :=
  let sub := fun x => (BinaryMap_pos func x) ++ (* maps [1,  x] *)
      (BinaryMap_pos (fun y => func (Pos.add y x)) x) in (* maps [x + 1, 2x] *)
  match p with
  | xH => [func p]
  | xO p' => sub p'
  | xI p' => sub p' ++ [func p]
  end.

Definition BinaryMap (func : N -> N)(n : N) : list N :=
  match n with
  | N0 => [func N0]
  | Npos p => [func N0] ++ (BinaryMap_pos (fun x => func (Npos x)) p)
  end.

Compute BinaryMap N.square 20. (* Correct *)
*)

Fixpoint BinaryMap_pos (func : positive -> N)(p : positive)(base : N) : list N :=
  let current := match base with
  | N0 => [func p]
  | Npos q => [func (Pos.add p q)]
  end in
  let sub := fun x => (BinaryMap_pos func x base) ++ (* maps [1,  x] *)
      (BinaryMap_pos func x (base + (Npos x))) in (* maps [x + 1, 2x] *)
  match p with
  | xH => current
  | xO p' => sub p'
  | xI p' => sub p' ++ current
  end.

Definition BinaryMap (func : N -> N)(n : N) : list N :=
  match n with
  | N0 => [func N0]
  | Npos p => [func N0] ++ (BinaryMap_pos (fun x => func (Npos x)) p 0)
  end.

(*
Compute BinaryMap N.square 10. (* Correct *)
*)
(*
Time Compute BinaryMap N.square 10000. (* Correct *)
Finished transaction in 1.209 secs
Both approach cost nearly the same time.
*)

(* TODO Consider utilizing TryBinary_Len for each 1 from left to right after NtobL *)
(* Finds the first positive in [1, p] that trusifies func. *)
Fixpoint TryBinary_fix (func : positive -> bool)(p : positive)(base : N) : option positive :=
  let shifted := match base with
  | N0 => p
  | Npos q => Pos.add p q
  end in
  let sub :=
    fun x =>
      match TryBinary_fix func x base with
      | Some r => Some r
      | None => TryBinary_fix func x (base + (Npos x))
      end in
  match p with
  | xH => if func shifted then Some shifted else None
  | xO p' => sub p'
  | xI p' =>
      match sub p' with
      | Some r => Some r
      | None => if func shifted then Some shifted else None
      end
  end.

Definition TryBinary_pos (func : positive -> bool)(p : positive) : option positive :=
  TryBinary_fix func p 0.

(*
Compute TryBinary_pos (Pos.leb 5) 4.
Compute TryBinary_pos (Pos.leb 5) 40.
*)

Definition TryBinary (func : N -> bool)(n : N) : option N :=
  match n with
  | N0 => if func N0 then Some N0 else None
  | Npos p =>
      match TryBinary_pos (fun x => func (Npos x)) p with
      | Some r => Some (Npos r)
      | None => None
      end
  end.

(*
Compute TryBinary (N.leb 5) 40.
Compute TryBinary (N.leb 5) 0.
*)

Definition TryBinarySampler (func : N -> bool)(smpl : N -> N)(n : N) :=
	TryBinary (fun x => func(smpl x)) n.

Fixpoint TryBinaryLen_fix (func : N -> bool)(len : nat)(prefix : N) : option N :=
  match len with
  | O => if func prefix then Some prefix else None
  | S len' =>
      match TryBinaryLen_fix func len' (double prefix) with
      | Some n => Some n
      | None => TryBinaryLen_fix func len' (succ_double prefix)
      end
  end.

(*Find the smallest N within length len that satisfies func *)
Definition TryBinaryLen (func : N -> bool)(len : nat) : option N :=
  TryBinaryLen_fix func len 0.

(*
Compute (fix func (x : nat) : nat :=
  match x with
  | O => 1%nat
  | S x' => Nat.mul x (func x')
  end)
  5%nat.
  *)

(*
Compute TryBinaryLen (fun x => leb 20 x) 4.
Compute TryBinaryLen (fun x => leb 20 x) 5.
Compute TryBinaryLen (fun x => leb 20 x) 6.
Compute TryBinaryLen (fun x => leb 20000000 x) 2000.
Correct *)

Inductive timed (A : Type)(B : Type) : Type :=
(* the process returns A within the time limit *)
| Cvg : A -> timed A B
(* the process did not halt in time, not sure would ever halt *)
(* Returns B for continued process *)
| Tmo : B -> timed A B
(* the process would never halt *)
| Dvg : timed A B
.

Arguments Cvg {A} {B} _.
Arguments Dvg {A} {B}.
Arguments Tmo {A} {B} _.

Fixpoint TryTrans_fix (A : Type)(func : N -> option A)(trans : N -> N)(initial : N)(last : N)
  (loop_count : positive) : timed A N :=
  let check_dvg :=
      fun x : N =>
        (let next := trans x in
          if next =? initial then Dvg else Tmo next) in
  match loop_count with
  | xH =>
    match func last with
    | Some r => Cvg r
    | None => check_dvg last
    end
  | xO lc' | xI lc' =>
    (*if andb (negb first_pass) (last =? initial) then Dvg else (* finished a period *)*)
    match TryTrans_fix A func trans initial last lc' with
    | Cvg r => Cvg r
    | Dvg => Dvg
    | Tmo trans_r =>
        match TryTrans_fix A func trans initial trans_r lc' with
        | Cvg r => Cvg r
        | Dvg => Dvg
        | Tmo trans_r' =>
            match loop_count with
            | xO lc' => Tmo trans_r'
            | _ =>
                match func trans_r' with
                | Some r => Cvg r
                | None => check_dvg trans_r'
                end
            end
        end
    end
  end.

(* If func returns Some A within loop_limit tests, then return Cvg *)
(* If a period has been traversed, then return Dvg *)
(* O.W. returns Imo next_input *)
Definition TryTrans (A : Type)(func : N -> option A)(trans : N -> N)(initial : N)
  (loop_limit : N) : timed A N :=
  match loop_limit with
  | N0 => Tmo initial
  | Npos lp =>
      TryTrans_fix A func trans initial initial lp
      (*
      match TryTrans_fix A func trans initial initial lp true with
      | Dvg => Dvg
      | Cvg r => Cvg r
      | Tmo last =>
          if last =? initial then Dvg else Tmo last
      end
      *)
  end.

 (*
(* 3 -> 3 *)
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => x mod 7) 3 2.
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => x mod 7) 3 1.
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => x mod 7) 3 0.

(* 1 -> 2 -> 4 -> 1 *)
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 1 2 .
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 1 3 .
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 1 4 .

(* 3 -> 6 -> 5 *)
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 3 0.
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 3 1.
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 3 2.
Compute TryTrans N (fun x => if (N.eqb 5 x) then Some x else None) (fun x => (N.double x) mod 7) 3 7.
*)