(** * Sieve of Eratosthenes with algebraic coinduction. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
  Basics
  Equivalence
  Lia
  Morphisms
  Equality
  List
  Nat
.
Local Open Scope program_scope.
Local Open Scope equiv_scope.
Import ListNotations.

From Coq Require Import
  Reals
  Raxioms
  Rpower
  FunctionalExtensionality
  ClassicalChoice
.

From algco Require Import aCPO axioms misc colist cpo order sieve sieve2 tactics.

Local Open Scope order_scope.

(** One way to prove things like this is by the uniqueness lemma, but
that requires doing an ad hoc continuity proof for the non-comorphism
side which is annoying. *)

Lemma sieve_aux_eq (l : colist nat) :
  sieve.sieve_aux l = sieve_aux l.
Proof with eauto with aCPO colist order.
  unfold sieve_aux, asieve_aux.
  apply alist_eq_colist_eq; intro i.
  rewrite <- sieve_aux_prefix.
  revert l; induction i; intro l; simpl.
  { constructor. }
  destruct l; simpl.
  - rewrite co_fold_nil'; constructor.
  - rewrite co_fold_tau'...
    2: { intro; apply monotone_compose... }
    rewrite IHi; reflexivity.
  - rewrite co_fold_cons'...
    2: { intro; apply continuous_compose... }
    rewrite prefix_cofilter, IHi; reflexivity.
Qed.

Lemma sieve_eq :
  sieve.sieve = sieve2.sieve.
Proof. apply sieve_aux_eq. Qed.


Require Import
        Fiat.BinEncoders.Env.Common.Specs.

Set Implicit Arguments.

Definition compose E B
           (transformer : Transformer B)
           (encode1 : E -> B * E)
           (encode2 : E -> B * E) :=
  fun e0 =>
    let (p, e1) := encode1 e0 in
    let (q, e2) := encode2 e1 in
    (transform p q, e2).

Lemma compose_encode_correct A A' B
      (cache : Cache)
      (transformer : Transformer B)
      (project : A -> A')
      (predicate : A -> Prop)
      (predicate' : A' -> Prop)
      (encode1 : A' -> CacheEncode -> B * CacheEncode)
      (encode2 : A -> CacheEncode -> B * CacheEncode)
      (decode1 : B -> CacheDecode -> A' * B * CacheDecode)
      (decode1_pf : encode_decode_correct cache transformer predicate' encode1 decode1)
      (decode2 : A' -> B -> CacheDecode -> A * B * CacheDecode)
      (decode2_pf : forall proj,
          encode_decode_correct cache transformer
            (fun data => predicate data /\ project data = proj)
            encode2
            (decode2 proj))
  : encode_decode_correct cache transformer (fun a => predicate' (project a) /\ predicate a)
     (fun (data : A) (ctx : CacheEncode) =>
      compose transformer (encode1 (project data)) (encode2 data) ctx)
     (fun (bin : B) (env : CacheDecode) =>
      let (bundle, env') := decode1 bin env in let (proj, rest) := bundle in decode2 proj rest env').
Proof.
  intros env env' xenv xenv' data data' bin ext ext' env_pm pred_pm com_pf.
  unfold compose in com_pf.
  destruct (encode1 (project data) env) as [b1 e1] eqn: eq1.
  destruct (encode2 data e1) as [b2 e2] eqn: eq2.
  destruct (decode1 (transform b1 (transform b2 ext)) env') as [ [d1 r1] e1'] eqn: eq1'.
  destruct (decode1_pf _ _ _ _ _ _ _ _ _ env_pm (proj1 pred_pm) eq1 eq1') as [de [dp dt] ].
  inversion com_pf; subst; clear com_pf.
  rewrite <- transform_assoc. rewrite eq1'.
  destruct (decode2 (project data) (transform b2 ext) e1') as [ [d2 r2] e2'] eqn: eq2'.
  specialize (decode2_pf (project data)  _ _ _ _ _ _ _ _ _ de (conj (proj2 pred_pm) eq_refl) eq2 eq2').
  inversion 1. subst. intuition.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal27.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (l1:lst) (n0:natural) (l3:lst) (IHl3:@eq lst (append (Cons n l1) (append Nil l3))
  (append (append (Cons n l1) Nil) l3)):@eq lst (Cons n (append l1 (Cons n0 l3)))
  (Cons n (append (append l1 Nil) (Cons n0 l3))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal27_append_assoc_42_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (l1:lst) (n0:natural) (l3:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"l1:" ++ "(" ++ show l1 ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"l3:" ++ "(" ++ show l3 ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  l1 n0 l3.
QuickChick collect_data.
Success.


(* External import(s). *)
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Import         ListNotations.
(* Internal import(s). *)
Require Import Basics.Identifier.
Require Import Basics.Aux.
Require Import Basics.Map.
Require Import Languages.WHILE.Syntax.
Require Import Languages.WHILE.Semantics.

Definition path       : Type := list cfg.

Definition baseCaseSet_varsAEqual: cfg -> cfg -> Prop :=
  fun c1 c2 =>
    match (c1, c2) with
    | ([_ | e1], [_ | e2]) => find A e1 = find A e2
    end.

Definition baseCaseSet_varsABCEqual: cfg -> cfg -> Prop :=
  fun c1 c2 =>
    match (c1, c2) with
    | ([_ | e1], [_ | e2]) =>
        find A e1 = find A e2 /\
        find B e1 = find B e2 /\
        find C e1 = find C e2
    end.

Definition baseCaseSet_varsABCDEqual: cfg -> cfg -> Prop :=
  fun c1 c2 =>
    match (c1, c2) with
    | ([_ | e1], [_ | e2]) =>
        find A e1 = find A e2 /\
        find B e1 = find B e2 /\
        find C e1 = find C e2 /\
        find D e1 = find D e2
    end.

Definition baseCaseSet_envsEqual: cfg -> cfg -> Prop :=
  fun c1 c2 => c1 = c2.

Definition isCompletePath (p: path): Prop :=
  match p with
  | nil         => False
  | _           =>
    match (last p emptyCfg) with
    | [EmptyStack | _] => True
    | _                => False
    end
  end.

Inductive isCompletePath_R: cfg -> cfg -> Prop :=
  | CPR_BaseCase: forall P,
      runStep P = None -> isCompletePath_R P P

  | CPR_IndCase : forall P P' P'',
      runStep P = Some P' /\ isCompletePath_R P' P'' ->
        isCompletePath_R P P''.

Definition fullSimulation (P Q: cfg) (baseCaseSet: cfg->cfg->Prop): Prop :=
  forall P', isCompletePath_R P P' ->
    exists Q', isCompletePath_R Q Q' /\
      baseCaseSet P' Q'.

Definition fullEquivalence (P Q:cfg) (baseCaseSet: cfg->cfg->Prop): Prop :=
  fullSimulation P Q baseCaseSet /\ fullSimulation Q P baseCaseSet.

Lemma stepLeft: forall P Q P' baseCaseSet,
  runStep P = Some P' /\ fullSimulation P' Q baseCaseSet  ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart PNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepLeft H] P' H'.
  inversion H'.
  - subst. rewrite HStepLeft in H0.
    inversion H0.
  - subst. destruct H0.
    rewrite HStepLeft in H0.
    injection H0.
    intro HInj.
    rewrite <- HInj in H1.
    specialize (H P').
    specialize (H H1).
    apply H.
Qed.

Lemma stepRight: forall P Q Q' baseCaseSet,
  runStep Q = Some Q' /\ fullSimulation P Q' baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart QNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepRight H] P' H'.
  specialize (H P').
  apply H in H'.
  destruct H', H0.
  assert (isCompletePath_R QStart x). {
    eapply CPR_IndCase.
    split.
    - apply HStepRight.
    - assumption.
  }
  exists x.
  split; assumption.
Qed.

Lemma stepLeftN (n:nat): forall P Q P' baseCaseSet,
  runNSteps n P = Some P' /\ fullSimulation P' Q baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart PNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepLeftN H] P' H'.
  inversion H'.
  - subst.
    unfold runNSteps, ret, bind in HStepLeftN.
    destruct (Nat.eqb n 0) eqn:H_eqb_n_0.
    + Search Nat.eqb.
      apply EqNat.beq_nat_true in H_eqb_n_0.
      rewrite H_eqb_n_0 in HStepLeftN.
      injection HStepLeftN as HInj.
      subst.
      apply H.
      assumption.
    + apply EqNat.beq_nat_false in H_eqb_n_0.
      assert (HAux: exists n', n = S n'). {
        exists (Nat.pred n).
        Search Nat.pred.
        symmetry.
        apply PeanoNat.Nat.succ_pred.
        assumption.
      }
      destruct HAux.
      rewrite H1 in HStepLeftN.
      simpl in HStepLeftN.
      unfold bind in HStepLeftN.
      rewrite H0 in HStepLeftN.
      inversion HStepLeftN.
  - subst. destruct H0.
    generalize dependent PStart.
    generalize dependent QStart.
    generalize dependent PNext.
    generalize dependent P'.
    generalize dependent P'0.
    induction n; intros.
    + unfold runNSteps, ret, bind in HStepLeftN.
      injection HStepLeftN as HInj.
      subst.
      apply H.
      assumption.
    + unfold runNSteps, ret, bind in HStepLeftN.
      rewrite H0 in HStepLeftN.
      inversion H1.
      * subst.
        destruct (Nat.eqb n 0) eqn:H_eqb_n_0.
        -- apply EqNat.beq_nat_true in H_eqb_n_0.
           rewrite H_eqb_n_0 in HStepLeftN.
           injection HStepLeftN as HInj.
           subst.
           apply H.
           assumption.
        -- apply EqNat.beq_nat_false in H_eqb_n_0.
           assert (HAux: exists n', n = S n'). {
            exists (Nat.pred n).
            Search Nat.pred.
            symmetry.
            apply PeanoNat.Nat.succ_pred.
            assumption.
           }
           destruct HAux.
           rewrite H3 in HStepLeftN.
           rewrite H2 in HStepLeftN.
           inversion HStepLeftN.
       * subst.
         destruct H2.
         specialize (IHn P'1).
         specialize (IHn P').
         specialize (IHn H3).
         specialize (IHn PNext).
         specialize (IHn QStart).
         specialize (IHn H).
         specialize (IHn P'0).
         specialize (IHn HStepLeftN).
         specialize (IHn H1).
         specialize (IHn H2).
         apply IHn.
Qed.

Lemma stepRightN (n:nat): forall P Q Q' baseCaseSet,
  runNSteps n Q = Some Q' /\ fullSimulation P Q' baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart QNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepRightN H] P' H'.
  generalize dependent PStart.
  generalize dependent QStart.
  generalize dependent QNext.
  generalize dependent P'.
  induction n; intros.
  - unfold runNSteps, ret, bind in HStepRightN.
    injection HStepRightN as HInj.
    subst.
    apply H.
    assumption.
  - assert (H'': exists Q' : cfg, isCompletePath_R QNext Q' /\ baseCaseSet P' Q'). {
      apply H.
      apply H'.
    }
    destruct H'', H0.
    unfold runNSteps, bind in HStepRightN.
    destruct (runStep QStart) eqn:H_step_QStart.
    + specialize (IHn P').
      specialize (IHn QNext).
      specialize (IHn c).
      specialize (IHn HStepRightN).
      specialize (IHn PStart).
      specialize (IHn H).
      specialize (IHn H').
      destruct IHn.
      destruct H2.
      exists x0.
      split.
      * eapply CPR_IndCase.
        split.
        -- apply H_step_QStart.
        -- apply H2.
      * apply H3.
    + inversion HStepRightN.
Qed.

Ltac stepLN n :=
  eapply (stepLeftN n); split;
  [reflexivity | unfold find, update, id_eqb];
  simpl.
Ltac stepRN n :=
  eapply (stepRightN n); split;
  [reflexivity | unfold find, update, id_eqb];
  simpl.

Ltac stepLNRM n m :=
  stepLN n; stepRN m.
Ltac stepLRN n :=
  stepLNRM n n.

Ltac stepL :=
  stepLN 1.
Ltac stepR :=
  stepRN 1.
Ltac stepLR :=
  stepLRN 1.

Ltac stepLUntilDone :=
  repeat stepL.
Ltac stepRUntilDone :=
  repeat stepR.
Ltac stepLRUntilDone :=
  stepLUntilDone; stepRUntilDone.

Ltac destLinIneq_native eqName :=
  match goal with
  | [ |- context[Nat.ltb ?x ?y] ] =>
      destruct (Nat.ltb x y) eqn:eqName;
       [(* - *)
        apply PeanoNat.Nat.ltb_lt in eqName;
        try (
         assert (~ x < y) by lia;
         contradiction
        ) |
        (* - *)
        apply PeanoNat.Nat.ltb_ge in eqName;
        try (
          assert (~ y <= x) by lia;
          contradiction
        )]
  | [ |- context[Nat.eqb ?x ?y] ] =>
      destruct (Nat.eqb x y) eqn:eqName;
      [(* - *)
       apply PeanoNat.Nat.eqb_eq in eqName;
       try (
        assert (~ x = y) by lia;
        contradiction
       ) |
       (* - *)
       apply PeanoNat.Nat.eqb_neq in eqName;
       try (
        assert (~ x <> y) by lia;
        contradiction
       )]
  end.

Tactic Notation "destLinIneq" :=
  let H := fresh in destLinIneq_native H.
Tactic Notation "destLinIneq" simple_intropattern(eqName) :=
  destLinIneq_native eqName.

Ltac destAndClearLinIneq_native eqName :=
  destLinIneq eqName; clear eqName.

Tactic Notation "destAndClearLinIneq" :=
  let H := fresh in destAndClearLinIneq_native H.
Tactic Notation "destAndClearLinIneq" simple_intropattern(eqName) :=
  destAndClearLinIneq_native eqName.

Ltac stepLUntilAfterIte :=
  stepLUntilDone;
  repeat destAndClearLinIneq;
  stepL.
Ltac stepRUntilAfterIte :=
  stepRUntilDone;
  repeat destAndClearLinIneq;
  stepR.
Ltac stepLRUntilAfterIte :=
  stepLUntilAfterIte;
  stepRUntilAfterIte.

Ltac fullSim base_case_set :=
  repeat (
    stepLRUntilDone;
    repeat destAndClearLinIneq);
  unfold fullSimulation;
  intros P' H_CPR;
  (exists P'; split;
     [(* - *)
      inversion H_CPR as [| config config' config'' contra];
       [(* + *)
        apply CPR_BaseCase; compute; reflexivity |
        (* + *)
        destruct contra as [contra]; inversion contra
       ] |
      (* - *)
      unfold base_case_set;
      inversion H_CPR as [| config config' config'' contra];
       [(* + *)
        unfold find; simpl; try (congruence || reflexivity) |
        (* + *)
        destruct contra as [contra]; inversion contra
       ]
     ];
     try intuition
  ) ||
  (eexists; split; simpl;
    [(* - *)
     inversion H_CPR as [| config config' config'' contra];
      [(* + *)
       apply CPR_BaseCase; compute; reflexivity |
       (* + *)
       destruct contra as [contra]; inversion contra
      ] |
     (* - *)
     unfold base_case_set;
     inversion H_CPR as [| config config' config'' contra];
      [(* + *)
       unfold find; simpl; try (congruence || reflexivity) |
       (* + *)
       destruct contra as [contra]; inversion contra
      ]
    ];
    try intuition
  ).


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  A very simple module for two flags on existential types.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.
Require Import Coq.Structures.Equalities.

Require Export BooleanEqualityDef.

Require Export CpdtTactics.
Require Export Case.
Require Export NatLemmas.

Module PhiModule <: BooleanEquality.

Module Types.
Inductive Phi : Type :=
 | witnesschanges  : Phi                            (* Allowing witness changes. \delta *)
 | aliases        : Phi.                            (* Allowing aliases as the opened type. \amp *)
End Types.
Include Types.

Definition t := Phi.

Function eqb (p p' : Phi) : bool :=
  match p, p' with
    | witnesschanges, witnesschanges => true
    | aliases, aliases => true
    | _, _ => false
  end.
Hint Unfold  eqb.
Hint Resolve eqb.

Fixpoint eq (a b : t) : Prop :=
    match eqb a b with
     | false => False
     | true => True
    end.

Lemma eqb_refl:
  forall (k : Phi),
    eqb k k = true.
Proof.
  destruct k.
  reflexivity.
  reflexivity.
Qed.
Hint Resolve eqb_refl.

Lemma eq_refl:
 forall (a : t),
   eq a a.
Proof.
  destruct a;  crush.
Qed.

Lemma eqb_sym : forall x y : Phi, eqb x y = eqb y x.
Proof.
  intros.
  destruct x;  destruct y; crush.
Qed.
Hint Immediate eqb_sym.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
  destruct x; destruct y; crush.
Qed.

Lemma eqb_trans :
  forall x y z,
    eqb x y = true -> eqb y z = true -> eqb x z = true.
Proof.
   destruct x; destruct y; destruct z; crush.
Qed.
Hint Resolve eqb_trans.

Lemma eq_trans :
  forall x y z,
    eq x y -> eq y z -> eq x z.
Proof.
  destruct x; destruct y; destruct z; crush.
Qed.

Lemma eqb_to_eq:
  forall (k k': Phi),
    eqb k k' = true ->
    k = k'.
Proof.
  intros.
  destruct k; destruct k'.
  reflexivity.
  inversion H.
  inversion H.
  reflexivity.
Qed.
Hint Resolve eqb_to_eq.

Lemma eqb_to_neq:
  forall (k k': Phi),
    eqb k k' = false ->
    k <> k'.
Proof.
  intros.
  destruct k; destruct k'.
  inversion H.
  discriminate.
  discriminate.
  inversion H.
Qed.
Hint Resolve eqb_to_neq.

Lemma eqb_iff_eq:    forall a b, eqb a b = true <-> a = b.
Proof.
  destruct a; destruct b; crush.
Qed.
Hint Resolve eqb_iff_eq.

Lemma eqb_iff_neq:   forall a b, eqb a b = false <-> a <> b.
Proof.
  destruct a; destruct b; crush.
Qed.
Hint Resolve eqb_iff_neq.

Instance eq_equiv : Equivalence eq.
Proof.
  split.
  exact eq_refl.
  exact eq_sym.
  exact eq_trans.
Defined.

Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
Proof.
  intros.
  destruct x; destruct y;  unfold eq; unfold eqb; crush.
Qed.

Lemma eqb_eq : forall x y : t, eqb x y = true <-> eq x y.
Proof.
  destruct x; destruct y;  crush.
Qed.

End PhiModule.


Require Import Classical CSLSets ClassicalEpsilon FunctionalExtensionality.

Set Implicit Arguments.

Module Type S.
  Parameter fmap : Type -> Type -> Type.

  Parameter empty : forall A B, fmap A B.
  Parameter lookup : forall A B, fmap A B -> A -> option B.
  Parameter add : forall A B, fmap A B -> A -> B -> fmap A B.

  Parameter remove : forall A B, fmap A B -> A -> fmap A B.
  Parameter join : forall A B, fmap A B -> fmap A B -> fmap A B.
  Parameter merge : forall A B, (option B -> option B -> option B) -> fmap A B -> fmap A B -> fmap A B.
  Parameter restrict : forall A B, (A -> Prop) -> fmap A B -> fmap A B.
  Parameter includes : forall A B, fmap A B -> fmap A B -> Prop.

  Notation "$0" := (empty _ _).
  Notation "m $+ ( k , v )" := (add m k v) (at level 50, left associativity).
  Infix "$-" := remove (at level 50, left associativity).
  Infix "$++" := join (at level 50, left associativity).
  Infix "$?" := lookup (at level 50, no associativity).
  Infix "$<=" := includes (at level 90).

  Parameter dom : forall A B, fmap A B -> set A.

  Axiom fmap_ext : forall A B (m1 m2 : fmap A B),
    (forall k, m1 $? k = m2 $? k)
    -> m1 = m2.

  Axiom lookup_empty : forall A B k, empty A B $? k = None.

  Axiom includes_lookup : forall A B (m m' : fmap A B) k v,
    m $? k = Some v
    -> m $<= m'
    -> lookup m' k = Some v.

  Axiom includes_add : forall A B (m m' : fmap A B) k v,
    m $<= m'
    -> add m k v $<= add m' k v.

  Axiom lookup_add_eq : forall A B (m : fmap A B) k1 k2 v,
    k1 = k2
    -> add m k1 v $? k2 = Some v.

  Axiom lookup_add_ne : forall A B (m : fmap A B) k k' v,
    k' <> k
    ->  add m k v $? k' = m $? k'.

  Axiom lookup_remove_eq : forall A B (m : fmap A B) k1 k2,
    k1 = k2
    -> remove m k1 $? k2 = None.

  Axiom lookup_remove_ne : forall A B (m : fmap A B) k k',
    k' <> k
    ->  remove m k $? k' = m $? k'.

  Axiom lookup_join1 : forall A B (m1 m2 : fmap A B) k,
    k \in dom m1
    -> (m1 $++ m2) $? k = m1 $? k.

  Axiom lookup_join2 : forall A B (m1 m2 : fmap A B) k,
    ~k \in dom m1
    -> (m1 $++ m2) $? k = m2 $? k.

  Axiom join_comm : forall A B (m1 m2 : fmap A B),
    dom m1 \cap dom m2 = {}
    -> m1 $++ m2 = m2 $++ m1.

  Axiom join_assoc : forall A B (m1 m2 m3 : fmap A B),
    (m1 $++ m2) $++ m3 = m1 $++ (m2 $++ m3).

  Axiom lookup_merge : forall A B f (m1 m2 : fmap A B) k,
    merge f m1 m2 $? k = f (m1 $? k) (m2 $? k).

  Axiom merge_empty1 : forall A B f (m : fmap A B),
    (forall x, f None x = x)
    -> merge f (@empty _ _) m = m.

  Axiom merge_empty2 : forall A B f (m : fmap A B),
    (forall x, f x None = x)
    -> merge f m (@empty _ _) = m.

  Axiom merge_empty1_alt : forall A B f (m : fmap A B),
    (forall x, f None x = None)
    -> merge f (@empty _ _) m = @empty _ _.

  Axiom merge_empty2_alt : forall A B f (m : fmap A B),
    (forall x, f x None = None)
    -> merge f m (@empty _ _) = @empty _ _.

  Axiom merge_add1 : forall A B f (m1 m2 : fmap A B) k v,
    (forall x y, f (Some x) y = None -> False)
    -> ~k \in dom m1
    -> merge f (add m1 k v) m2 = match f (Some v) (lookup m2 k) with
                                 | None => merge f m1 m2
                                 | Some v => add (merge f m1 m2) k v
                                 end.

  Axiom merge_add2 : forall A B f (m1 m2 : fmap A B) k v,
    (forall x y, f x (Some y) = None -> False)
    -> ~k \in dom m2
    -> merge f m1 (add m2 k v) = match f (lookup m1 k) (Some v) with
                                 | None => merge f m1 m2
                                 | Some v => add (merge f m1 m2) k v
                                 end.

  Axiom merge_add1_alt : forall A B f (m1 m2 : fmap A B) k v,
    (forall x y, f (Some x) (Some y) = None -> False)
    -> ~k \in dom m1
    -> k \in dom m2
    -> merge f (add m1 k v) m2 = match f (Some v) (lookup m2 k) with
                                 | None => merge f m1 m2
                                 | Some v => add (merge f m1 m2) k v
                                 end.

  Axiom empty_includes : forall A B (m : fmap A B), empty A B $<= m.

  Axiom dom_empty : forall A B, dom (empty A B) = {}.

  Axiom dom_add : forall A B (m : fmap A B) (k : A) (v : B),
    dom (add m k v) = {k} \cup dom m.

  Axiom lookup_restrict_true : forall A B (P : A -> Prop) (m : fmap A B) k,
    P k
    -> lookup (restrict P m) k = lookup m k.

  Axiom lookup_restrict_false : forall A B (P : A -> Prop) (m : fmap A B) k,
    ~P k
    -> lookup (restrict P m) k = None.

  Axiom lookup_restrict_true_fwd : forall A B (P : A -> Prop) (m : fmap A B) k v,
    lookup (restrict P m) k = Some v
    -> P k.

  Hint Extern 1 => match goal with
                     | [ H : lookup (empty _ _) _ = Some _ |- _ ] =>
                       rewrite lookup_empty in H; discriminate
                   end.

  Hint Resolve includes_lookup includes_add empty_includes.

  Hint Rewrite lookup_empty lookup_add_eq lookup_add_ne lookup_remove_eq lookup_remove_ne
       lookup_merge lookup_restrict_true lookup_restrict_false using congruence.

  Hint Rewrite dom_empty dom_add.

  Ltac maps_equal :=
    apply fmap_ext; intros;
      repeat (subst; autorewrite with core; try reflexivity;
        match goal with
          | [ |- context[lookup (add _ ?k _) ?k' ] ] => destruct (classic (k = k')); subst
        end).

  Hint Extern 3 (_ = _) => maps_equal.

  Axiom lookup_split : forall A B (m : fmap A B) k v k' v',
    (m $+ (k, v)) $? k' = Some v'
    -> (k' <> k /\ m $? k' = Some v') \/ (k' = k /\ v' = v).

  Hint Rewrite merge_empty1 merge_empty2 using solve [ eauto 1 ].
  Hint Rewrite merge_empty1_alt merge_empty2_alt using congruence.

  Hint Rewrite merge_add1 using solve [ eauto | unfold CSLSets.In; autorewrite with core in *; simpl in *; intuition congruence ].
  Hint Rewrite merge_add1_alt using solve [ congruence | unfold CSLSets.In; autorewrite with core in *; simpl in *; intuition congruence ].

  Axiom includes_intro : forall K V (m1 m2 : fmap K V),
      (forall k v, m1 $? k = Some v -> m2 $? k = Some v)
      -> m1 $<= m2.

  Axiom lookup_Some_dom : forall K V (m : fmap K V) k v,
      m $? k = Some v
      -> k \in dom m.

  Axiom lookup_None_dom : forall K V (m : fmap K V) k,
      m $? k = None
      -> ~ k \in dom m.

  (* Bits meant for separation logic *)
  Section splitting.
    Variables K V : Type.

    Definition disjoint (h1 h2 : fmap K V) : Prop :=
      forall a, h1 $? a <> None
                -> h2 $? a <> None
                -> False.

    Definition split (h h1 h2 : fmap K V) : Prop :=
      h = h1 $++ h2.

    Axiom split_empty_fwd : forall h h1,
        split h h1 $0
        -> h = h1.

    Axiom split_empty_fwd' : forall h h1,
      split h $0 h1
      -> h = h1.

    Axiom split_empty_bwd : forall h,
      split h h $0.

    Axiom split_empty_bwd' : forall h,
      split h $0 h.

    Axiom disjoint_hemp : forall h,
      disjoint h $0.

    Axiom disjoint_hemp' : forall h,
      disjoint $0 h.

    Axiom disjoint_comm : forall h1 h2,
      disjoint h1 h2
      -> disjoint h2 h1.

    Axiom split_comm : forall h h1 h2,
      disjoint h1 h2
      -> split h h1 h2
      -> split h h2 h1.

    Axiom split_assoc1 : forall h h1 h' h2 h3,
      split h h1 h'
      -> split h' h2 h3
      -> split h (join h1 h2) h3.

    Axiom split_assoc2' : forall h h1 h' h2 h3,
      split h h1 h'
      -> split h' h2 h3
      -> disjoint h1 h'
      -> disjoint h2 h3
      -> split h h2 (join h3 h1).

    Axiom split_assoc2 : forall h h1 h' h2 h3,
      split h h' h1
      -> split h' h2 h3
      -> disjoint h' h1
      -> disjoint h2 h3
      -> split h h2 (join h3 h1).

    Axiom disjoint_assoc1 : forall h h1 h' h2 h3,
      split h h1 h'
      -> split h' h2 h3
      -> disjoint h1 h'
      -> disjoint h2 h3
      -> disjoint (join h1 h2) h3.

    Axiom disjoint_assoc2 : forall h h1 h' h2 h3,
      split h h' h1
      -> split h' h2 h3
      -> disjoint h' h1
      -> disjoint h2 h3
      -> disjoint h2 (join h3 h1).

    Axiom split_join : forall h1 h2,
      split (join h1 h2) h1 h2.

    Axiom split_disjoint : forall h h1 h2 h' h3,
      split h h1 h'
      -> split h' h2 h3
      -> disjoint h1 h'
      -> disjoint h2 h3
      -> disjoint h1 h2.

    Axiom disjoint_assoc3 : forall h h1 h2 h3,
      disjoint h h2
      -> split h h1 h3
      -> disjoint h1 h3
      -> disjoint h3 h2.
  End splitting.

  Hint Immediate disjoint_comm split_comm.
  Hint Immediate split_empty_bwd disjoint_hemp disjoint_hemp' split_assoc1 split_assoc2.
  Hint Immediate disjoint_assoc1 disjoint_assoc2 split_join split_disjoint disjoint_assoc3.
End S.

Module M : S.
  Definition fmap (A B : Type) := A -> option B.

  Definition empty A B : fmap A B := fun _ => None.

  Section decide.
    Variable P : Prop.

    Lemma decided : inhabited (sum P (~P)).
    Proof.
      destruct (classic P).
      constructor; exact (inl _ H).
      constructor; exact (inr _ H).
    Qed.

    Definition decide : sum P (~P) :=
      epsilon decided (fun _ => True).
  End decide.

  Definition add A B (m : fmap A B) (k : A) (v : B) : fmap A B :=
    fun k' => if decide (k' = k) then Some v else m k'.
  Definition remove A B (m : fmap A B) (k : A) : fmap A B :=
    fun k' => if decide (k' = k) then None else m k'.
  Definition join A B (m1 m2 : fmap A B) : fmap A B :=
    fun k => match m1 k with
               | None => m2 k
               | x => x
             end.
  Definition merge A B f (m1 m2 : fmap A B) : fmap A B :=
    fun k => f (m1 k) (m2 k).
  Definition lookup A B (m : fmap A B) (k : A) := m k.
  Definition restrict A B (P : A -> Prop) (m : fmap A B) : fmap A B :=
    fun k => if decide (P k) then m k else None.
  Definition includes A B (m1 m2 : fmap A B) :=
    forall k v, m1 k = Some v -> m2 k = Some v.

  Definition dom A B (m : fmap A B) : set A := fun x => m x <> None.

  Theorem fmap_ext : forall A B (m1 m2 : fmap A B),
    (forall k, lookup m1 k = lookup m2 k)
    -> m1 = m2.
  Proof.
    intros; extensionality k; auto.
  Qed.

  Theorem lookup_empty : forall A B (k : A), lookup (empty B) k = None.
  Proof.
    auto.
  Qed.

  Theorem includes_lookup : forall A B (m m' : fmap A B) k v,
    lookup m k = Some v
    -> includes m m'
    -> lookup m' k = Some v.
  Proof.
    auto.
  Qed.

  Theorem includes_add : forall A B (m m' : fmap A B) k v,
    includes m m'
    -> includes (add m k v) (add m' k v).
  Proof.
    unfold includes, add; intuition.
    destruct (decide (k0 = k)); auto.
  Qed.

  Theorem lookup_add_eq : forall A B (m : fmap A B) k1 k2 v,
    k1 = k2
    -> lookup (add m k1 v) k2 = Some v.
  Proof.
    unfold lookup, add; intuition.
    destruct (decide (k2 = k1)); try tauto.
    congruence.
  Qed.

  Theorem lookup_add_ne : forall A B (m : fmap A B) k k' v,
    k' <> k
    -> lookup (add m k v) k' = lookup m k'.
  Proof.
    unfold lookup, add; intuition.
    destruct (decide (k' = k)); intuition.
  Qed.

  Theorem lookup_remove_eq : forall A B (m : fmap A B) k1 k2,
    k1 = k2
    -> lookup (remove m k1) k2 = None.
  Proof.
    unfold lookup, remove; intuition.
    destruct (decide (k2 = k1)); try tauto.
    congruence.
  Qed.

  Theorem lookup_remove_ne : forall A B (m : fmap A B) k k',
    k' <> k
    -> lookup (remove m k) k' = lookup m k'.
  Proof.
    unfold lookup, remove; intuition.
    destruct (decide (k' = k)); try tauto.
  Qed.

  Theorem lookup_join1 : forall A B (m1 m2 : fmap A B) k,
    k \in dom m1
    -> lookup (join m1 m2) k = lookup m1 k.
  Proof.
    unfold lookup, join, dom, In; intros.
    destruct (m1 k); congruence.
  Qed.

  Theorem lookup_join2 : forall A B (m1 m2 : fmap A B) k,
    ~k \in dom m1
    -> lookup (join m1 m2) k = lookup m2 k.
  Proof.
    unfold lookup, join, dom, In; intros.
    destruct (m1 k); try congruence.
    exfalso; apply H; congruence.
  Qed.

  Theorem join_comm : forall A B (m1 m2 : fmap A B),
    dom m1 \cap dom m2 = {}
    -> join m1 m2 = join m2 m1.
  Proof.
    intros; apply fmap_ext; unfold join, lookup; intros.
    apply (f_equal (fun f => f k)) in H.
    unfold dom, intersection, constant in H; simpl in H.
    destruct (m1 k), (m2 k); auto.
    exfalso; rewrite <- H.
    intuition congruence.
  Qed.

  Theorem join_assoc : forall A B (m1 m2 m3 : fmap A B),
    join (join m1 m2) m3 = join m1 (join m2 m3).
  Proof.
    intros; apply fmap_ext; unfold join, lookup; intros.
    destruct (m1 k); auto.
  Qed.

  Theorem lookup_merge : forall A B f (m1 m2 : fmap A B) k,
      lookup (merge f m1 m2) k = f (m1 k) (m2 k).
  Proof.
    auto.
  Qed.

  Theorem merge_empty1 : forall A B f (m : fmap A B),
    (forall x, f None x = x)
    -> merge f (@empty _ _) m = m.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge; auto.
  Qed.

  Theorem merge_empty2 : forall A B f (m : fmap A B),
    (forall x, f x None = x)
    -> merge f m (@empty _ _) = m.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge; auto.
  Qed.

  Theorem merge_empty1_alt : forall A B f (m : fmap A B),
    (forall x, f None x = None)
    -> merge f (@empty _ _) m = @empty _ _.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge; auto.
  Qed.

  Theorem merge_empty2_alt : forall A B f (m : fmap A B),
    (forall x, f x None = None)
    -> merge f m (@empty _ _) = @empty _ _.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge; auto.
  Qed.

  Theorem merge_add1 : forall A B f (m1 m2 : fmap A B) k v,
    (forall x y, f (Some x) y = None -> False)
    -> ~k \in dom m1
    -> merge f (add m1 k v) m2 = match f (Some v) (lookup m2 k) with
                                 | None => merge f m1 m2
                                 | Some v => add (merge f m1 m2) k v
                                 end.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge, add; intros.
    destruct (decide (k0 = k)); auto; subst.
    case_eq (f (Some v) (m2 k)); intros.
    case_eq (decide (k = k)); congruence.
    exfalso; eauto.

    case_eq (f (Some v) (m2 k)); intros.
    destruct (decide (k0 = k)); congruence.
    auto.
  Qed.

  Theorem merge_add2 : forall A B f (m1 m2 : fmap A B) k v,
    (forall x y, f x (Some y) = None -> False)
    -> ~k \in dom m2
    -> merge f m1 (add m2 k v) = match f (lookup m1 k) (Some v) with
                                 | None => merge f m1 m2
                                 | Some v => add (merge f m1 m2) k v
                                 end.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge, add; intros.
    destruct (decide (k0 = k)); auto; subst.
    case_eq (f (m1 k) (Some v)); intros.
    case_eq (decide (k = k)); congruence.
    exfalso; eauto.

    case_eq (f (m1 k) (Some v)); intros.
    destruct (decide (k0 = k)); congruence.
    auto.
  Qed.

  Theorem merge_add1_alt : forall A B f (m1 m2 : fmap A B) k v,
    (forall x y, f (Some x) (Some y) = None -> False)
    -> ~k \in dom m1
    -> k \in dom m2
    -> merge f (add m1 k v) m2 = match f (Some v) (lookup m2 k) with
                                 | None => merge f m1 m2
                                 | Some v => add (merge f m1 m2) k v
                                 end.
  Proof.
    intros; apply fmap_ext; unfold lookup, merge, add; intros.
    destruct (decide (k0 = k)); auto; subst.
    case_eq (f (Some v) (m2 k)); intros.
    case_eq (decide (k = k)); congruence.
    case_eq (m2 k); intros.
    rewrite H3 in H2.
    exfalso; eauto.
    congruence.

    case_eq (f (Some v) (m2 k)); intros.
    destruct (decide (k0 = k)); congruence.
    auto.
  Qed.

  Theorem empty_includes : forall A B (m : fmap A B), includes (empty (A := A) B) m.
  Proof.
    unfold includes, empty; intuition congruence.
  Qed.

  Theorem dom_empty : forall A B, dom (empty (A := A) B) = {}.
  Proof.
    unfold dom, empty; intros; sets idtac.
  Qed.

  Theorem dom_add : forall A B (m : fmap A B) (k : A) (v : B),
    dom (add m k v) = {k} \cup dom m.
  Proof.
    unfold dom, add; simpl; intros.
    sets ltac:(simpl in *; try match goal with
                                 | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
                               end; intuition congruence).
  Qed.

  Lemma lookup_split : forall A B (m : fmap A B) k v k' v',
    lookup (add m k v) k' = Some v'
    -> (k' <> k /\ lookup m k' = Some v') \/ (k' = k /\ v' = v).
  Proof.
    unfold lookup, add; simpl; intros.
    destruct (decide (k' = k)); intuition congruence.
  Qed.

  Theorem lookup_restrict_true : forall A B (P : A -> Prop) (m : fmap A B) k,
    P k
    -> lookup (restrict P m) k = lookup m k.
  Proof.
    unfold lookup, restrict; intros.
    destruct (decide (P k)); tauto.
  Qed.

  Theorem lookup_restrict_false : forall A B (P : A -> Prop) (m : fmap A B) k,
    ~P k
    -> lookup (restrict P m) k = None.
  Proof.
    unfold lookup, restrict; intros.
    destruct (decide (P k)); tauto.
  Qed.

  Theorem lookup_restrict_true_fwd : forall A B (P : A -> Prop) (m : fmap A B) k v,
    lookup (restrict P m) k = Some v
    -> P k.
  Proof.
    unfold lookup, restrict; intros.
    destruct (decide (P k)); intuition congruence.
  Qed.

  Lemma includes_intro : forall K V (m1 m2 : fmap K V),
      (forall k v, lookup m1 k = Some v -> lookup m2 k = Some v)
      -> includes m1 m2.
  Proof.
    auto.
  Qed.

  Lemma lookup_Some_dom : forall K V (m : fmap K V) k v,
      lookup m k = Some v
      -> k \in dom m.
  Proof.
    unfold lookup, dom, In; congruence.
  Qed.

  Lemma lookup_None_dom : forall K V (m : fmap K V) k,
      lookup m k = None
      -> ~ k \in dom m.
  Proof.
    unfold lookup, dom, In; congruence.
  Qed.

  Section splitting.
    Variables K V : Type.

    Notation "$0" := (@empty K V).
    Notation "m $+ ( k , v )" := (add m k v) (at level 50, left associativity).
    Infix "$-" := remove (at level 50, left associativity).
    Infix "$++" := join (at level 50, left associativity).
    Infix "$?" := lookup (at level 50, no associativity).
    Infix "$<=" := includes (at level 90).

    Definition disjoint (h1 h2 : fmap K V) : Prop :=
      forall a, h1 $? a <> None
                -> h2 $? a <> None
                -> False.

    Definition split (h h1 h2 : fmap K V) : Prop :=
      h = h1 $++ h2.

    Hint Extern 2 (_ <> _) => congruence.

    Ltac splt := unfold disjoint, split, join, lookup in *; intros; subst;
                 try match goal with
                     | [ |- @eq (fmap K V) _ _ ] => let a := fresh "a" in extensionality a; simpl
                     end;
                 repeat match goal with
                        | [ a : K, H : forall a : K, _ |- _ ] => specialize (H a)
                        end;
                 repeat match goal with
                        | [ H : _ |- _ ] => rewrite H
                        | [ |- context[match ?E with Some _ => _ | None => _ end] ] => destruct E
                        | [ _ : context[match ?E with Some _ => _ | None => _ end] |- _  ] => destruct E
                        end; eauto; try solve [ exfalso; eauto ].

    Lemma split_empty_fwd : forall h h1,
        split h h1 $0
        -> h = h1.
    Proof.
      splt.
    Qed.

    Lemma split_empty_fwd' : forall h h1,
      split h $0 h1
      -> h = h1.
    Proof.
      splt.
    Qed.

    Lemma split_empty_bwd : forall h,
      split h h $0.
    Proof.
      splt.
    Qed.

    Lemma split_empty_bwd' : forall h,
      split h $0 h.
    Proof.
      splt.
    Qed.

    Lemma disjoint_hemp : forall h,
      disjoint h $0.
    Proof.
      splt.
    Qed.

    Lemma disjoint_hemp' : forall h,
      disjoint $0 h.
    Proof.
      splt.
    Qed.

    Lemma disjoint_comm : forall h1 h2,
      disjoint h1 h2
      -> disjoint h2 h1.
    Proof.
      splt.
    Qed.

    Lemma split_comm : forall h h1 h2,
      disjoint h1 h2
      -> split h h1 h2
      -> split h h2 h1.
    Proof.
      splt.
    Qed.

    Hint Immediate disjoint_comm split_comm.

    Lemma split_assoc1 : forall h h1 h' h2 h3,
      split h h1 h'
      -> split h' h2 h3
      -> split h (join h1 h2) h3.
    Proof.
      splt.
    Qed.

    Lemma split_assoc2' : forall h h1 h' h2 h3,
      split h h1 h'
      -> split h' h2 h3
      -> disjoint h1 h'
      -> disjoint h2 h3
      -> split h h2 (join h3 h1).
    Proof.
      splt.
    Qed.

    Lemma split_assoc2 : forall h h1 h' h2 h3,
      split h h' h1
      -> split h' h2 h3
      -> disjoint h' h1
      -> disjoint h2 h3
      -> split h h2 (join h3 h1).
    Proof.
      intros; eapply split_assoc2'; eauto.
    Qed.

    Lemma disjoint_assoc1 : forall h h1 h' h2 h3,
      split h h1 h'
      -> split h' h2 h3
      -> disjoint h1 h'
      -> disjoint h2 h3
      -> disjoint (join h1 h2) h3.
    Proof.
      splt.
    Qed.

    Lemma disjoint_assoc2 : forall h h1 h' h2 h3,
      split h h' h1
      -> split h' h2 h3
      -> disjoint h' h1
      -> disjoint h2 h3
      -> disjoint h2 (join h3 h1).
    Proof.
      splt.
    Qed.

    Lemma split_join : forall h1 h2,
      split (join h1 h2) h1 h2.
    Proof.
      splt.
    Qed.

    Lemma split_disjoint : forall h h1 h2 h' h3,
      split h h1 h'
      -> split h' h2 h3
      -> disjoint h1 h'
      -> disjoint h2 h3
      -> disjoint h1 h2.
    Proof.
      splt.
    Qed.

    Lemma disjoint_assoc3 : forall h h1 h2 h3,
      disjoint h h2
      -> split h h1 h3
      -> disjoint h1 h3
      -> disjoint h3 h2.
    Proof.
      splt.
    Qed.
  End splitting.
End M.

Export M.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Basic configuration (Library, Notations, Warning, etc.)
  author    : ZhengPu Shi
  date      : 2022.06

  remark    :
  1. Basic libraries in whole project
  3. Reserved notations for consistence.
    https://coq.inria.fr/distrib/V8.13.2/refman/language/coq-library.html
  3. Eliminate some warning.
    https://coq.inria.fr/distrib/V8.13.2/refman/user-extensions/
    syntax-extensions.html?highlight=warning
  4. Customized tactics.
*)

(* ######################################################################### *)
(** * Basic libraries *)

Require Export Coq.Classes.Morphisms.     (* respectful, ==> *)
Require Export Coq.Setoids.Setoid.        (*  *)
Require Export Coq.Classes.SetoidTactics. (* add_morphism_tactic *)
Require Export Coq.Relations.Relations.   (* equivalence *)
Require Export Coq.Bool.Bool.             (* reflect *)
Require Export Ring.                      (* ring *)
Require Export Field.                     (* field *)

Require Import Coq.Logic.Description. (* constructive_definite_description *)
Require Export Coq.Logic.Classical.
Require Export Coq.Logic.FunctionalExtensionality.

(* ######################################################################### *)
(** * Reserved Notations *)

(** Reserved Notations, to keep same precedence and associativity *)
Reserved Infix    "=="      (at level 70, no associativity).
Reserved Notation "a != b"  (at level 70, no associativity).
Reserved Infix    "=?"      (at level 70, no associativity).
Reserved Infix    "+"       (at level 50, left associativity).
Reserved Infix    "-"       (at level 50, left associativity).
Reserved Infix    "*"       (at level 40, left associativity).
Reserved Infix    "/"       (at level 40, left associativity).
Reserved Infix    "c*"      (at level 40, left associativity).
Reserved Infix    "*c"      (at level 40, left associativity).
Reserved Notation "- a"     (at level 35, right associativity).
Reserved Notation "/ a"     (at level 35, right associativity).
Reserved Notation "a 'ᵀ'"   (at level 35).
(* this level is consistent with Mathcomp.ssreflect.ssrnotations.v *)
Reserved Notation "v .[ i ]"
   (at level 2, left associativity, format "v .[ i ]").

(* ######################################################################### *)
(** * Eliminate Warning. *)

(* Export Set Warnings "-notation-overridden". *)

(* ######################################################################### *)
(** * Customized tactics *)

(** ** Tactics with a short name *)

Global Ltac gd k := generalize dependent k.

(* repeat split *)
Ltac ssplit :=
  repeat
  match goal with
  | |- _ /\ _ => split
  end.

(* ######################################################################### *)
(** * Global notations *)

(* this level is consistent with coq.ssr.ssrbool.v *)
Notation "~~ b" := (negb b) (at level 35, right associativity) : bool_scope.

(* ######################################################################### *)
(** * Global coercions *)

(** bool to Prop *)
Definition is_true (b : bool) : Prop := b = true.
Coercion is_true : bool >-> Sortclass.

Goal true.
apply eq_refl. Qed.

Goal ~~false.
simpl. apply eq_refl. Qed.

Example eqnP (n m : nat) : reflect (n = m) (Nat.eqb n m).
Proof.
  gd m. induction n; intros [|m]; simpl; try constructor; auto.
  destruct IHn with m; subst; constructor; auto.
Qed.

(* ######################################################################### *)
(** * General propeties of algebraic structures *)

Section general_props.

  Context {A B : Type}.
  Variable fa ga : A -> A -> A.
  Infix "+" := fa.
  Infix "*" := ga.
  Variable fb : B -> B -> B.
  Infix "⊕" := fb (at level 50).

  Definition decidable := forall (a b : A), {a = b} + {a <> b}.

  Definition associative := forall a b c, a + (b + c) = (a + b) + c.

  Definition commutative := forall a b, a + b = b + a.

  Definition distributive_left := forall a b c, (a + b) * c = a * c + b * c.
  Definition distributive_right := forall a b c, a * (b + c) = a * b + a * c.

  Definition cancel_left := forall a b c, a + b = a + c -> b = c.
  Definition cancel_right := forall a b c, a + c = b + c -> a = b.

  Definition injective (phi : A -> B) := forall (a1 a2 : A),
    a1 <> a2 -> phi a1 <> phi a2.

  (** Second form of injective *)
  Definition injective_form2 (phi : A -> B) := forall (a1 a2 : A),
    phi a1 = phi a2 -> a1 = a2.

  (** These two forms are equal *)
  Lemma injective_eq_injective_form2 (phi : A -> B) :
    injective phi <-> injective_form2 phi.
  Proof.
    split; intros H1 a1 a2 H2.
    - pose (H1 a1 a2) as H3.
      apply imply_to_or in H3. destruct H3.
      + unfold not in H. apply NNPP in H. auto.
      + easy.
    - pose (H1 a1 a2) as H3.
      apply imply_to_or in H3. destruct H3; auto.
  Qed.

  Definition surjective (phi : A -> B) := forall (b : B),
    (exists (a : A), phi a = b).

  Definition bijective (phi : A -> B) :=
    injective phi /\ surjective phi.

  (** phi is a homomorphic mapping from <A,+> to <B,⊕> *)
  Definition homomorphic (phi : A -> B) : Prop :=
    forall (a b : A), phi (a + b) = (phi a) ⊕ (phi b).

  (** phi is a homomorphic and injective mapping *)
  Definition homo_inj (phi : A -> B) : Prop :=
    homomorphic phi /\ injective phi.

  (** phi is a homomorphic and surjective mapping *)
  Definition homo_surj (phi : A -> B) : Prop :=
    homomorphic phi /\ surjective phi.

End general_props.

(** If there exist a homomorphic and surjective mapping from <A,+> to <B,⊕>,
  then we said <A,+> and <B,⊕> is homomorphism *)
Definition homomorphism {A B : Type} (fa : A -> A -> A) (fb : B -> B -> B) :=
  exists (phi : A -> B), homo_surj fa fb phi.

(** If there exist two homomorphic and surjective mapping from <A,+> to <B,⊕>
  and from <A,*> to <B,⊗>, then we said <A,+,*> and <B,⊕,⊗> is homomorphism *)
Definition homomorphism2 {A B : Type} (fa ga : A -> A -> A)
  (fb gb: B -> B -> B) :=
  exists (phi : A -> B), homo_surj fa fb phi /\ homo_surj ga gb phi.

(** If there exist a homomorphic and bijective mapping from <A,+> to <B,⊕>,
  then we said <A,+> and <B,⊕> is isomorphism *)
Definition isomorphism {A B : Type} (fa : A -> A -> A) (fb : B -> B -> B) :=
  exists (phi : A -> B), homomorphic fa fb phi /\ bijective phi.

(** If there exist two homomorphic and bijective mapping from <A,+> to <B,⊕>
  and from <A,*> to <B,⊗>, then we said <A,+,*> and <B,⊕,⊗> is isomorphism *)
Definition isomorphism2 {A B : Type} (fa ga : A -> A -> A)
  (fb gb: B -> B -> B) :=
  exists (phi : A -> B),
  homomorphic fa fb phi /\ homomorphic ga gb phi /\ bijective phi.

(* sig version. Type *)
Definition inversefun_of_bij {A B : Type} (phi : A -> B) (Hbij : bijective phi)
  : {psi : B -> A |
    (forall a : A, psi (phi a) = a) /\
    (forall b : B, phi (psi b) = b)}.
Proof.
  destruct Hbij as [Hinj Hsurj].
  apply injective_eq_injective_form2 in Hinj.
  (* ref: https://stackoverflow.com/questions/62464821/
    how-to-make-an-inverse-function-in-coq
    TIPS: ex is Prop, sig is Type. this axiom construct a sig with ex. *)
  apply constructive_definite_description.
  assert (H : forall b, exists! a, phi a = b).
  { intros b.
    destruct (Hsurj b) as [a Ha]. exists a. split; auto.
    intros a' Ha'. apply Hinj. subst. auto. }
  exists (fun b => proj1_sig (constructive_definite_description _ (H b))).
  split. (* unique *)
  - split.
    + intros a. destruct (constructive_definite_description). simpl.
      apply Hinj. auto.
    + intros b. destruct (constructive_definite_description). simpl.
      auto.
  - intros g [H1 H2].
    apply functional_extensionality.
    intros b. destruct (constructive_definite_description). simpl.
    rewrite <- e. rewrite H1. auto.
Defined.

(* ex version. Prop *)
(* Definition inversefun_of_bij_Prop {A B : Type} (phi : A -> B)
  (Hbij : bijective phi)
  : exists (psi : B -> A),
    (forall a : A, psi (phi a) = a) /\
    (forall b : B, phi (psi b) = b).
Proof.
  constructor.
  Check (exists g, (fun
  eexists. split.
  - intros a. destruct Hbij as [Hinj Hsurj].
    destruct (Hsurj (phi a)). *)

(* ######################################################################### *)
(** * Usually used scopes *)

(** Scope for matrix type *)
Declare Scope mat_scope.
Delimit Scope mat_scope with M.
Open Scope M.

(** Scope for vector type *)
Declare Scope vec_scope.
Delimit Scope vec_scope with V.
Open Scope vec_scope.


Require Import StructTact.StructTactics.
Require Import Net.

Require Import FunctionalExtensionality.

Section OU.
  Context `{params : MultiParams}.

  Lemma update_diff :
    forall A sigma x (v : A) y,
      x <> y ->
      update sigma x v y = sigma y.
  Proof using.
    unfold update.
    intros.
    break_if; congruence.
  Qed.

  Lemma update_nop :
    forall A sigma x y,
      update (A:=A) sigma x (sigma x) y = sigma y.
  Proof using.
    unfold update.
    intros. break_if; congruence.
  Qed.

  Lemma update_eq :
    forall A sigma x y (v : A),
      x = y ->
      update sigma x v y = v.
  Proof using.
    intros. subst.
    unfold update.
    break_if; congruence.
  Qed.

  Lemma update_same :
    forall A sigma x (v : A),
      update sigma x v x = v.
  Proof using.
    intros.
    rewrite update_eq; auto.
  Qed.

  Lemma update_nop_ext :
    forall A sigma h,
      update (A:=A) sigma h (sigma h) = sigma.
  Proof using.
    intros.
    apply functional_extensionality.
    intros.
    apply update_nop.
  Qed.

  Lemma update_fun_comm :
    forall A B (f : A -> B) st y v x,
      f (update st y v x) = update (fun x => f (st x)) y (f v) x.
  Proof using.
    intros.
    destruct (name_eq_dec x y); subst;
    repeat first [rewrite update_diff by congruence |
           rewrite update_eq  by auto ]; auto.
  Qed.

  Lemma update_nop_ext' :
    forall A (sigma : name -> A) y v,
      sigma y = v ->
      update sigma y v = sigma.
  Proof using.
    intros.
    subst.
    apply update_nop_ext.
  Qed.

  Lemma update_overwrite :
    forall A (sigma : name -> A) h st st',
      update (update sigma h st) h st' = update sigma h st'.
  Proof using.
    intros.
    apply functional_extensionality.
    intros. destruct (name_eq_dec h x).
    - repeat rewrite update_eq; auto.
    - repeat rewrite update_diff; auto.
  Qed.
End OU.

Ltac update_destruct :=
  match goal with
  | [ |- context [ update _ ?y _ ?x ] ] => destruct (name_eq_dec y x)
  end.

Ltac rewrite_update' H :=
  first [rewrite update_diff in H by congruence |
         rewrite update_eq in H by auto ].

Ltac rewrite_update :=
  repeat match goal with
           | [ H : context [ update _ _ _ _ ] |- _ ] =>
             rewrite_update' H; repeat rewrite_update' H
           | [ |- _ ] => repeat (try rewrite update_diff by congruence;
                                 try rewrite update_eq by auto)
         end.


Require Import Coq.Program.Basics.
Require Export functor.

(** The constant functor. *)
Instance Fmap_const A : Fmap (const A) := fun _ _ _ => id.

Instance Functor_const A : Functor (const A).
Proof. firstorder. Qed.

Instance Fmap_const' A : Fmap (fun _ => A) := Fmap_const A.
Instance Functor_const' A : Functor (fun _ => A) := Functor_const A.


(* * Syntax and semantics of the Jasmin source language *)

(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import Psatz xseq.
Require Export strings warray_.
Import Utf8.

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

Definition sem_t (t : stype) : Type :=
  match t with
  | sbool    => bool
  | sint     => Z
  | sarr n   => WArray.array n
  | sword s  => word s
  end.

Definition sem_prod ts tr := lprod (map sem_t ts) tr.

Definition sem_ot (t:stype) : Type :=
  if t is sbool then option bool
  else sem_t t.

Definition sem_tuple ts := ltuple (map sem_ot ts).

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

Definition curry A B (n: nat) (f: seq (sem_t A) → B) : sem_prod (nseq n A) B :=
  (fix loop n :=
   match n return seq (sem_t A) → sem_prod (nseq n A) B with
   | 0 => f
   | n'.+1 => λ acc a, loop n' (a :: acc)
   end) n [::].

Fixpoint sem_prod_const {A} (lt: seq stype) (a: A) : sem_prod lt A :=
  match lt with
  | [::]     => a
  | _ :: lt' => fun _ => sem_prod_const lt' a
  end.

Definition sem_prod_id (t: stype) : sem_t t -> sem_ot t :=
  if t is sbool
  then Some
  else id.

Fixpoint sem_prod_app {A B} (lt: seq stype) :
  sem_prod lt A -> (A -> B) -> sem_prod lt B :=
  match lt with
  | [::]     => fun a g => g a
  | _ :: lt' => fun f g x => sem_prod_app (f x) g
  end.

(* Construct an n-tuple.
 * Return a t1 -> ... -> tn -> (t1, ..., tn) function where t1, ..., tn are the
 * semantics of a list of stype.
 *)
Fixpoint sem_prod_tuple (lt: seq stype) : sem_prod lt (sem_tuple lt) :=
  match lt return sem_prod lt (sem_tuple lt) with
  | [::] =>
      tt
  | t :: lt' =>
      let f := match lt'
               return sem_prod lt' (sem_tuple lt')
                      -> sem_prod (t :: lt') (sem_tuple (t :: lt'))
               with
               | [::] =>
                   fun _ => @sem_prod_id t
               | _ :: _ =>
                   fun rec_lt' x => sem_prod_app rec_lt' (fun p => (sem_prod_id x, p))
               end in
      f (sem_prod_tuple lt')
  end.

Definition sem_prod_cat lt0 lt1 A :
  sem_prod (lt0 ++ lt1) A = sem_prod lt0 (sem_prod lt1 A).
Proof.
  induction lt0 as [|t lt0' IH];
    first done.
  rewrite /sem_prod /=.
  rewrite /sem_prod /= in IH.
  by rewrite IH.
Defined.

Definition add_arguments {A} {lt0 lt1} (f: sem_prod lt0 (sem_prod lt1 A))
  : sem_prod (lt0 ++ lt1) A.
  rewrite sem_prod_cat.
  by apply: f.
Defined.

Definition behead_tuple tin tout :
  sem_prod tin (exec (sem_tuple tout))
  -> sem_prod tin (exec (sem_tuple (behead tout))) :=
  match tout
  return sem_prod tin (exec (sem_tuple tout))
         -> sem_prod tin (exec (sem_tuple (behead tout)))
  with
  | [::] =>
      fun f => sem_prod_app f (fun x => Let _ := x in ok tt)
  | t :: tout' =>
      match tout'
      return sem_prod tin (exec (sem_tuple (t :: tout')))
             -> sem_prod tin (exec (sem_tuple tout'))
      with
      | [::] =>
          fun f => sem_prod_app f (fun x => Let _ := x in ok tt)
      | _ =>
          fun f => sem_prod_app f (fun x => Let: (r, p) := x in ok p)
      end
  end.

Section APP.

Context (T : Type) (of_T : forall t : stype, T -> exec (sem_t t)).

Fixpoint app_sopn A ts : sem_prod ts (exec A) → seq T → exec A :=
  match ts return sem_prod ts (exec A) → seq T → exec A with
  | [::] => λ (o : exec A) (vs: seq T), if vs is [::] then o else type_error
  | t :: ts => λ (o: sem_t t → sem_prod ts (exec A)) (vs: seq T),
    if vs is v :: vs
    then Let v := of_T t v in app_sopn (o v) vs
    else type_error
  end.

End APP.


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.base.

Local Open Scope nat_scope.

Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A)  :=
{ af_unage : forall x':A, exists x, age1 x = Some x'
; af_level1 : forall x, age1 x = None <-> level x = 0
; af_level2 : forall x y, age1 x = Some y -> level x = S (level y)
}.

Arguments af_unage [A] [level] [age1] _ _.
Arguments af_level1 [A] [level] [age1] _ _.
Arguments af_level2 [A] [level] [age1] _ _ _ _.

Class ageable (A:Type) := mkAgeable
{ level : A -> nat
; age1 : A -> option A
; age_facts : ageable_facts A level age1
}.

Definition age {A} `{ageable A} (x y:A) := age1 x = Some y.

Lemma af_wf {A} `{ageable A} :
 well_founded (fun x y => age y x).
Proof.
  intros.
  intro.
  remember (level a).
  revert a Heqn.
  induction n; intros; constructor; intros.
  apply (af_level2 age_facts) in H0.
  rewrite H0 in Heqn.
  inversion Heqn.
  copy H0.
  apply (af_level2 age_facts) in H0.
  apply IHn.
  omega.
Qed.
Arguments af_wf [A] _ _.

Definition age_induction {A} `{ageable A} :=
  well_founded_induction (af_wf _).

Definition fashionR {A1} `{ageable A1} {A2}`{ageable A2} (x:A1) (y: A2) : Prop :=
  level x = level y.

Lemma fashionR_refl {A} `{ageable A} : reflexive _ fashionR.
Proof.
  repeat intro; hnf; auto.
Qed.

Lemma fashionR_trans {A} `{ageable A} {B} `{ageable B} {C} `{ageable C} :
    forall (x: A) (y: B) (z: C), fashionR x y -> fashionR y z -> fashionR x z.
Proof.
  unfold fashionR; intros; congruence.
Qed.

Lemma fashionR_sym {A} `{ageable A} {B} `{ageable B}:
   forall (x: A) (y: B), fashionR x y -> fashionR y x.
Proof.
  unfold fashionR; intros; auto.
Qed.

Lemma age_level {A} `{ageable A} : forall (x y:A),
  age x y -> level x = S (level y).
Proof.
  intros.
  apply (af_level2 age_facts); auto.
Qed.

Lemma age1_level0 {A} `{ageable A} : forall (x:A),
  age1 x = None <-> level x = 0.
Proof.
  intros; apply (af_level1 age_facts).
Qed.

Section level'.
  Variable A:Type.
  Variable ag:ageable A.

  Require Coq.funind.Recdef.
  Function level' (x:A) { wf (fun x y => @age A ag y x)  x } : nat :=
(*  Function level' (x:A) { wf (transp _ (@age A ag)) x } : nat := *)
    match age1 x with
    | None => 0
    | Some x' => S (level' x')
    end.
    intros. hnf. assumption.
    unfold transp. apply (af_wf _).
  Defined.

  Theorem level_level' : forall x:A, level x = level' x.
  Proof.
    intro x; induction x using age_induction; intros.
    rewrite level'_equation.
    case_eq (age1 x); intros.
    rewrite (af_level2 age_facts x a); auto.
    rewrite <- age1_level0; auto.
  Qed.
End level'.

Lemma levelS_age1 {A} `{ageable A} : forall (x:A) n,
  level x = S n ->
  exists y, age1 x = Some y.
Proof.
  intros; rewrite level_level' in H0.
  rewrite level'_equation in H0.
  destruct (age1 x); eauto.
  inv H0.
Qed.

Lemma age1_levelS {A} `{ageable A} : forall (x y:A),
  age1 x = Some y ->
  exists n, level x = S n.
Proof.
  intros; rewrite level_level'.
  rewrite level'_equation.
  destruct (age1 x); eauto.
  inv H0.
Qed.

Lemma age1_level0_absurd {A} `{ageable A} : forall (x y:A),
  age1 x = Some y ->
  level x = 0 ->
  False.
Proof.
  intros.
  rewrite <- age1_level0 in H1.
  rewrite H0 in H1; discriminate.
Qed.

Lemma age1None_levelS_absurd {A} `{ageable A} : forall (x:A) n,
  age1 x = None ->
  level x = S n ->
  False.
Proof.
  intros.
  rewrite age1_level0 in H0.
  rewrite H0 in H1; discriminate.
Qed.

Section RtRft.
  Variable A:Type.
  Variable R:relation A.

  Let Rt := clos_trans A R.
  Let Rft := clos_refl_trans A R.

  Lemma Rt_Rft : forall x y, Rt x y -> Rft x y.
  Proof.
    intros; elim H; intros.
    apply rt_step; auto.
    eapply rt_trans; eauto.
  Qed.

  Lemma Rt_Rft_trans : forall x y z, Rt x y -> Rft y z -> Rt x z.
  Proof.
    intros x y z H H1; revert x H; elim H1; intros; auto.
    eapply t_trans; eauto; apply t_step; auto.
  Qed.

  Lemma Rft_Rt_trans : forall x y z, Rft x y -> Rt y z -> Rt x z.
  Proof.
    intros x y z H; revert z; elim H; intros; auto.
    eapply t_trans; eauto; apply t_step; auto.
  Qed.

  Lemma transpose_clos_trans : forall A R x y,
    clos_trans A (transp A R) x y <-> transp A (clos_trans A R) x y.
  Proof.
    unfold transp; intuition.

    elim H; intros.
    apply t_step; auto.
    apply t_trans with y0; auto.

    elim H; intros.
    apply t_step; auto.
    apply t_trans with y0; auto.
  Qed.
End RtRft.

Hint Resolve rt_refl.

Definition laterR {A} `{ageable A} : relation A := clos_trans A age.
Definition necR   {A} `{ageable A} : relation A := clos_refl_trans A age.

Require Coq.Wellfounded.Wellfounded.
Lemma laterR_wf {A} `{ageable A} :
  well_founded (transp _ laterR).
Proof.
  intros.
  hnf; intro.
  induction a using
    (well_founded_induction (Wellfounded.Transitive_Closure.wf_clos_trans _ (fun x y => age y x) (af_wf _))).
  constructor; intros.
  unfold laterR in H1.
  rewrite <- transpose_clos_trans in H1.
  apply H0; auto.
Qed.

Definition laterR_induction {A} `{ageable A} :=
  @well_founded_induction A (transp A laterR) laterR_wf.

Lemma age_irreflexive {A}  `{ageable A}: forall x, age x x -> False.
Proof.
  intros x.
  induction x using age_induction; intros.
  apply H0 with x; auto.
Qed.

Lemma laterR_irreflexive {A} `{HA: ageable A} : forall x, laterR x x -> False.
Proof.
  intros x.
  induction x using laterR_induction; intros.
  apply H with x; auto.
Qed.

Lemma nec_refl_or_later {A} `{ageable A} : forall x y,
  necR x y -> x = y \/ laterR x y.
Proof.
  intros.
  elim H0; intros; auto.
  right; apply t_step; auto.
  destruct H2; destruct H4; subst; auto.
  right; apply t_trans with y0; auto.
Qed.

Lemma necR_antisym {A} `{ageable A} : forall x y,
  necR x y -> necR y x -> x = y.
Proof.
  intros.
  apply nec_refl_or_later in H0.
  apply nec_refl_or_later in H1.
  intuition.
  elim (laterR_irreflexive x).
  eapply t_trans; eauto.
Qed.

Lemma age_later_nec {A} `{HA: ageable A} : forall x y z,
  age x y ->
  laterR x z ->
  necR y z.
Proof.
  intros x y z H H1; revert y H.
  induction H1; intros.
  replace y0 with y.
  apply rt_refl.
  unfold age in *; congruence.
  apply rt_trans with y; auto.
  apply IHclos_trans1; auto.
  apply Rt_Rft; auto.
Qed.

Lemma necR_level {A} `{X: ageable A} : forall (x y:A),
  necR x y ->
  level x >= level y.
Proof.
  intros x y H; induction H; auto.
  rewrite (age_level x y); auto.
  omega.
Qed.

Lemma laterR_level {A} `{X: ageable A} : forall (x y:A),
  laterR x y ->
  level x > level y.
Proof.
  intros x y H; induction H; auto.
  rewrite (age_level x y); auto.
  omega.
Qed.

Section NAT_AGEABLE.

  Definition natLevel (x:nat) : nat := x.
  Definition natAge1 (x:nat) : option nat :=
    match x with
    | 0 => None
    | S n => Some n
    end.
  Definition natUnage (x:nat) : nat := S x.

  Lemma ag_nat_facts :
    ageable_facts nat natLevel natAge1.
  Proof.
    constructor.
    intros; exists (S x'); compute; auto.
    intro x; destruct x; intuition; inv H.
    firstorder;
      destruct x; inv H; compute; eauto.
  Qed.

  Definition ag_nat : ageable nat :=
    mkAgeable nat natLevel natAge1 ag_nat_facts.

  Lemma nec_nat : forall (n n':nat),
    @necR _ ag_nat n n' <-> n' <= n.
  Proof.
    intros. split; intro.
    induction H.
    destruct x; inv H; auto.
    auto.
    omega.

    induction H.
    apply rt_refl.
    apply rt_trans with m.
    apply rt_step. compute; auto.
    auto.
  Qed.

  Lemma later_nat : forall (n n':nat),
    @laterR _ ag_nat n n' <-> n' < n.
  Proof.
    intros. split; intro.
    induction H.
    destruct x; simpl in H.
    inv H.
    inv H. omega.
    omega.
    hnf in H.
    inv H.
    apply t_step.
    compute; auto.
    apply Rt_Rft_trans with m.
    apply t_step. compute; auto.
    change (@necR _ ag_nat m n').
    rewrite nec_nat.
    omega.
  Qed.

End NAT_AGEABLE.

Lemma laterR_level' {A} `{H : ageable A}: forall {w1 w2: A}, laterR w1 w2 -> @laterR _ ag_nat (level w1) (level w2).
Proof.
induction 1.
constructor 1. apply age_level in H0. rewrite H0; reflexivity.
constructor 2 with (level y); auto.
Qed.

Lemma necR_nat {A} `{H : ageable A}:
    forall {x y: A}, necR x y -> @necR nat ag_nat (level x) (level y).
  Proof.
    intros. apply necR_level in H0.
     induction H0; simpl in *. constructor 2.
     constructor 3 with m. constructor 1. constructor.
     auto.
  Qed.

Section BIJECTION.
  Variable A B : Type.
  Variable ag: ageable A.
  Variable bijAB: bijection A B.

  Let levelB (x:B) : nat :=
    level (bij_g _ _ bijAB x).

  Let age1B  (x: B) : option B :=
     match age1 (bij_g _ _ bijAB x) with
     | Some y => Some (bij_f _ _ bijAB y)
     | None => None
     end.

  Let ageB (x y: B) :=age1B x = Some y.

  Lemma age_bij_unage :
    forall x', exists x, age1B x = Some x'.
  Proof.
    unfold age1B, levelB; simpl; intros.
    destruct bijAB as [f g fg gf]; simpl in *.
    destruct (af_unage age_facts (g x')) as [y ?].
   exists (f y). rewrite gf. rewrite H. f_equal. apply fg.
  Qed.

  Lemma age_bij_level1 :
    forall x, age1B x = None <-> levelB x = 0.
  Proof.
    intros.
    unfold age1B, levelB; simpl.
    destruct bijAB as [f g fg gf]; simpl.
    case_eq (age1 (g x)); intuition; try discriminate.
    rewrite <- age1_level0 in H1.
    rewrite H0 in H1; discriminate.
    rewrite <- age1_level0; auto.
  Qed.

  Lemma age_bij_level2 :
    forall x y, age1B x = Some y -> levelB x = S (levelB y).
  Proof.
    intros.
    unfold age1B, levelB in *; simpl in *.
    destruct bijAB as [f g fg gf]; simpl in *.
    case_eq (age1 (g x)); intros; rewrite H0 in H; inv H.
    rewrite gf.
    apply (af_level2 age_facts); auto.
  Qed.

  Lemma ag_bij_facts : ageable_facts B levelB age1B.
  Proof.
    constructor.
    exact age_bij_unage.
    exact age_bij_level1.
    exact age_bij_level2.
  Qed.

  Definition ag_bij : ageable B :=
    mkAgeable B levelB age1B ag_bij_facts.
End BIJECTION.

Section PROD.
  Variable A B : Type.
  Variable agA: ageable A.

  Let levelAB (x:prod A B) := level (fst x).
  Let age1AB (x:prod A B) :=
    match age1 (fst x) with
    | None => None
    | Some a' => Some (a',snd x)
    end.

  Lemma ag_prod_facts : ageable_facts (prod A B) levelAB age1AB.
  Proof.
    constructor.
    unfold levelAB, age1AB; simpl; intros.
    destruct (af_unage age_facts (fst x')) as [y1 ?].
    exists (y1, snd x'). simpl. rewrite H. f_equal. destruct x'; auto.
    intros [a b]; firstorder.
    unfold age1AB in H; simpl in H.
    case_eq (age1 a); intros; rewrite H0 in H; inv H.
    unfold levelAB; simpl.
    rewrite <- age1_level0; auto.
    unfold levelAB in H.
    simpl in H.
    rewrite <- age1_level0 in H.
    unfold age1AB; simpl.
    rewrite H; auto.
    intros.
    unfold age1AB in H.
    unfold levelAB.
    destruct x; simpl in *.
    case_eq (age1 a); intros; rewrite H0 in H; inv H.
    simpl.
    apply age_level; auto.
  Qed.

  Definition ag_prod :=
    mkAgeable (prod A B) levelAB age1AB ag_prod_facts.

  Lemma prod_nec_split : forall n x n' x',
    @necR (prod A B) ag_prod (n,x) (n',x') <-> necR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (n,x) as w.
    remember (n',x') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H. simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply rt_step. auto.
    inv Heqw'.
    split; auto.
    apply rt_refl.
    spec IHclos_refl_trans1 n x0 (fst y) (snd y).
    spec IHclos_refl_trans1; auto.
    spec IHclos_refl_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_refl_trans2 a b n' x'.
    spec IHclos_refl_trans2; auto.
    spec IHclos_refl_trans2; auto.
    intuition. eapply rt_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply rt_step. hnf.
    hnf in H. simpl.
    unfold age1AB. simpl. rewrite H. auto.
    apply rt_refl.
    eapply rt_trans; eauto.
  Qed.

  Lemma prod_later_split : forall n x n' x',
    @laterR (prod A B) ag_prod (n,x) (n',x') <-> laterR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (n,x) as w.
    remember (n',x') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H; simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply t_step. compute. auto.
    spec IHclos_trans1 n x0 (fst y) (snd y).
    spec IHclos_trans1; auto.
    spec IHclos_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_trans2 a b n' x'.
    spec IHclos_trans2; auto.
    spec IHclos_trans2; auto.
    intuition. eapply t_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply t_step.
    hnf; simpl. unfold age1AB. simpl; rewrite H. auto.
    eapply t_trans; eauto.
  Qed.

End PROD.

Section PROD'.
  Variable A B : Type.
  Variable agB: ageable B.

  Let levelAB (x:prod A B) := level (snd x).
  Let age1AB (x:prod A B) :=
    match age1 (snd x) with
    | None => None
    | Some a' => Some (fst x, a')
    end.

  Lemma ag_prod'_facts : ageable_facts (prod A B) levelAB age1AB.
  Proof.
    constructor.
    unfold levelAB, age1AB; simpl; intros.
    destruct (af_unage age_facts (snd x')) as [y2 ?].
    exists (fst x', y2). simpl. rewrite H. f_equal. destruct x'; auto.
    intros [a b]; firstorder.
    unfold age1AB in H; simpl in H.
    case_eq (age1 b); intros; rewrite H0 in H; inv H.
    unfold levelAB; simpl.
    rewrite <- age1_level0; auto.
    unfold levelAB in H.
    simpl in H.
    rewrite <- age1_level0 in H.
    unfold age1AB; simpl.
    rewrite H; auto.
    intros.
    unfold age1AB in H.
    unfold levelAB.
    destruct x; simpl in *.
    case_eq (age1 b); intros; rewrite H0 in H; inv H.
    simpl.
    apply age_level; auto.
  Qed.

  Definition ag_prod' :=
    mkAgeable (prod A B) levelAB age1AB ag_prod'_facts.

  Lemma prod'_nec_split : forall n x n' x',
    @necR (prod A B) ag_prod' (x,n) (x',n') <-> necR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (x,n) as w.
    remember (x',n') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H. simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply rt_step. auto.
    inv Heqw'.
    split; auto.
    apply rt_refl.
    spec IHclos_refl_trans1 n x0 (snd y) (fst y).
    spec IHclos_refl_trans1; auto.
    spec IHclos_refl_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_refl_trans2 b a n' x'.
    spec IHclos_refl_trans2; auto.
    spec IHclos_refl_trans2; auto.
    intuition. eapply rt_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply rt_step. hnf.
    hnf in H. simpl.
    unfold age1AB. simpl. rewrite H. auto.
    apply rt_refl.
    eapply rt_trans; eauto.
  Qed.

  Lemma prod'_later_split : forall n x n' x',
    @laterR (prod A B) ag_prod' (x,n) (x',n') <-> laterR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (x,n) as w.
    remember (x',n') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H; simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply t_step. compute. auto.
    spec IHclos_trans1 n x0 (snd y) (fst y).
    spec IHclos_trans1; auto.
    spec IHclos_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_trans2 b a n' x'.
    spec IHclos_trans2; auto.
    spec IHclos_trans2; auto.
    intuition. eapply t_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply t_step.
    hnf; simpl. unfold age1AB. simpl; rewrite H. auto.
    eapply t_trans; eauto.
  Qed.

End PROD'.

Fixpoint composeOptN (A: Type) (f: A -> option A)
         (n: nat) (w: A) {struct n} : option A :=
 match n  with
 | S n' => match f w with Some w' => composeOptN A f n' w' | None => None end
 | O => Some w
 end.
Arguments composeOptN [A] _ _ _.

Definition ageN {A} `{ageable A}: nat -> A -> option A := composeOptN age1.

Lemma ageN1  {A} `{ageable A}: ageN 1 = age1.
Proof.
intros.
unfold ageN. simpl.
extensionality phi.
case_eq (age1 phi); intros; try rewrite H; auto.
Qed.

Lemma ageN_compose {A} `{agA : ageable A}:
 forall a b c phi1 phi2 phi3,ageN a phi1 = Some phi2 ->
       ageN b phi2 = Some phi3 ->  (a+b=c)%nat ->  ageN c phi1 = Some phi3.
Proof.
unfold ageN in *.
induction a; simpl; intros.
subst. inversion H; clear H. auto.
subst c.
case_eq (age1 phi1); intros; rewrite H1 in H; try discriminate.
simpl.
rewrite H1.
eapply IHa; eauto.
Qed.

Lemma ageN_compose' {A} `{agA : ageable A}:
  forall a b phi1 phi3,
   ageN (a+b)%nat phi1 = Some phi3 -> exists phi2, ageN a phi1 = Some phi2 /\ ageN b phi2 = Some phi3.
Proof.
intros.
case_eq (ageN a phi1); intros.
rename a0 into phi.
exists phi.
split; auto.
case_eq (ageN b phi); intros.
rename a0 into phi0.
generalize (ageN_compose a b (a+b) phi1 _ _ H0 H1 (refl_equal _)); intro.
rewrite H in H2; auto.
elimtype False.
revert phi1 phi H H1 H0; induction a; intros.
simpl in *.
inv H0.
rewrite H in H1; discriminate.
replace (S a + b)%nat with (S (a+b))%nat in H by omega.
unfold ageN in *;
simpl in *.
case_eq (age1 phi1); intros; rewrite H2 in H; try discriminate.
rewrite H2 in H0.
eapply IHa; eauto.
elimtype False.
unfold ageN in *.
revert phi1 H H0; induction a; intros.
simpl in *. discriminate.
replace (S a + b)%nat with (S (a+b))%nat in H by omega.
simpl in *.
revert H H0; case_eq (age1 phi1); intros; try discriminate.
eapply IHa; eauto.
Qed.

Lemma necR_evolve {A} `{agA : ageable A}:
    necR = fun (phi phi': A) => exists n, ageN n phi = Some phi'.
Proof.
extensionality w w'.
apply prop_ext; split; intros.
unfold necR in H.
induction H.
exists 1%nat. rewrite ageN1.
simpl.
auto.
exists O; auto.
destruct IHclos_refl_trans1 as [n1 ?].
destruct IHclos_refl_trans2 as [n2 ?].
exists (n1+n2)%nat.
eapply ageN_compose; eauto.
destruct H as [n ?].
revert w w' H; induction n; intros.
inv H.
constructor 2.
unfold ageN in H.
simpl in H.
revert H; case_eq (age1 w); intros; try discriminate.
constructor 3 with a.
constructor 1; auto.
apply IHn; auto.
Qed.

Lemma age_noetherian  {A} `{ageable A}: forall phi, exists n, ageN n phi = None.
Proof.
  intros.
  induction phi using age_induction.
  rename x into phi.
  case_eq (age1 phi); intros.
  generalize H1; intros.
  apply H0 in H1.
  destruct H1 as [n ?].
  exists (S n).
  unfold ageN; simpl.
  rewrite H2; auto.
  exists (S O); simpl.
  unfold ageN; simpl.
  rewrite H1.
  auto.
Qed.

Lemma predicate_max:
  forall (F: nat -> Prop) (Fdec: forall n, {F n}+{~ F n}) n,
  F 0%nat ->
  ~ F n ->
  exists i, F i /\ (i<n)%nat /\ ~ F (S i).
Proof.
intros.
assert (forall m, (m <= n)%nat ->
         (forall k, (k<m)%nat -> F k) \/
         (exists i, F i /\ (i<m)%nat /\ ~ F (S i))).
induction m.
left; intros.
elimtype False; omega.
intro.
assert (m<=n)%nat; try omega.
destruct (IHm H2).
assert (m < n \/ m = n)%nat; try omega.
destruct H4.
destruct (Fdec m) as [?H|?H].
left.
intros.
assert (k < m \/ k = m)%nat; try omega.
destruct H7.
auto.
subst k; auto.
right.
exists (Peano.pred m).
destruct m.
contradiction.
replace (Peano.pred (S m)) with m; try omega.
split.
apply H3; try omega.
split; try omega.
auto.
subst m.
right.
destruct n.
contradiction.
exists n; repeat split; auto; try omega.
right.
destruct H3 as [i H4].
destruct H4.
destruct H4.
exists i; repeat split; auto; omega.
assert (n <= n)%nat; try omega.
destruct (H1 _ H2).
destruct n; try contradiction.
exists n; repeat split; auto; try omega.
auto.
Qed.

Lemma age_noetherian'  {A} `{agA : ageable A}:
       forall phi, exists! n, exists phi', ageN n phi = Some phi' /\ age1 phi' = None.
Proof.
intros.
destruct (age_noetherian phi) as [n ?].
assert (Fdec: forall n, {ageN n phi <> None}+{~( ageN n phi <> None)})
  by (intros; destruct (ageN n0 phi); auto; left; intro Hx; inversion Hx).
destruct (predicate_max (fun n => ageN n phi <> None) Fdec n) as [i [? [? ?]]].
intro. inv H0.
intro.
rewrite H in H0.
contradiction H0; auto.
exists i.
split.
revert H0; case_eq (ageN i phi); intros.
exists a; split; auto.
revert H2; case_eq (ageN (S i) phi); intros.
contradiction H4.
intro Hx; inv Hx.
clear - H0 H2.
revert phi a H0 H2; induction i; intros.
inv H0.
rewrite ageN1 in H2; auto.
unfold ageN in *.
simpl in H0.
revert H0; case_eq (age1 phi); intros; try discriminate.
simpl in H2.
rewrite H in H2.
eapply IHi.
eauto.
simpl.
auto.
contradiction H3; auto.
intros.
destruct H3 as [phi' [? ?]].
assert (ageN (S i) phi = None).
clear - H2.
revert H2; case_eq (ageN (S i) phi); intros.
contradict H2. intro Hx; inv Hx.
auto. clear H2.
clear - H0 H5 H3 H4.
revert H0; case_eq (ageN i phi); intros.
2: contradiction H0; auto.
clear H0.
assert (age1 a = None).
clear - H H5.
revert phi H5 H; induction i; intros.
inv H; rewrite ageN1 in H5; auto.
unfold ageN in *.
revert H H5; simpl. case_eq (age1 phi); intros; try discriminate.
eapply IHi; eauto.
clear H5.
assert (forall i d phi a a', ageN i phi = Some a -> ageN (i+d) phi = Some a' -> age1 a' = None -> age1 a = None -> d=0%nat).
clear.
induction i; intros.
inv H.
destruct d; auto.
simpl in H0.
unfold ageN in H0. simpl in H0.
rewrite H2 in H0. inv H0.
unfold ageN in H, H0. simpl in *.
revert H; case_eq (age1 phi); intros; try discriminate.
rewrite H in H0.
eauto.
assert (i<x' \/ i=x' \/ i>x')%nat by omega.
destruct H2 as [?| [?| ?]]; auto.
replace x' with (i+(x'-i))%nat in H3 by omega.
specialize (H1 _ _ _ _ _ H H3 H4 H0).
omega.
replace i with (x'+(i-x'))%nat in H by omega.
specialize (H1 _ _ _ _ _ H3 H H0 H4).
omega.
Qed.

Lemma ageable_ext:
   forall A (B C: ageable A),
      @age1 _ B = @age1 _ C -> @level _ B = @level _ C -> B=C.
Proof.
intros.
destruct B; destruct C.
simpl in *.
subst age3. subst level0.
replace age_facts1 with age_facts0; auto.
apply proof_irr.
Qed.

Lemma necR_linear {A} `{H : ageable A}:
  forall {a b c}, necR a b -> necR a c -> necR b c \/ necR c b.
Proof.
intros.
apply trans_rt1n in H0.
apply trans_rt1n in H1.
revert c H1; induction H0; intros; auto.
left; apply rt1n_trans; auto.
inversion H2; subst.
right.
apply rt_trans with y.
constructor 1; auto.
apply rt1n_trans; auto.
unfold age in H0,H3.
rewrite H0 in H3; inv H3.
destruct (IHclos_refl_trans_1n _ H4); auto.
Qed.

Lemma necR_linear' {A} `{H : ageable A}:
   forall {a b c}, necR a b -> necR a c -> level b = level c -> b=c.
Proof.
intros.
destruct (necR_linear H0 H1).
clear - H2 H3.
apply nec_refl_or_later in H3.
destruct H3; auto.
apply laterR_level in H0; unfold fashionR in H2; elimtype False; omega.
apply nec_refl_or_later in H3.
destruct H3; auto.
apply laterR_level in H3; unfold fashionR in H2; elimtype False; omega.
Qed.

Lemma laterR_necR {A} `{agA : ageable A}:
  forall {x y}, laterR x y -> necR x y.
Proof.
induction 1; intros.
constructor; auto.
econstructor 3; auto.
apply rt_trans with y; auto.
Qed.

Lemma necR_refl {A} `{H : ageable A}:
  forall phi, necR phi phi.
Proof.
intros; constructor 2.
Qed.

Hint Resolve @necR_refl.

Lemma necR_trans  {A} `{H : ageable A}:
  forall phi1 phi2 phi3, necR phi1 phi2 -> necR phi2 phi3 -> necR phi1 phi3.
Proof.
intros.
econstructor 3; eauto.
Qed.

Lemma necR_laterR {A} `{agA : ageable A}:
  forall w1 w2 w3, necR w1 w2 -> laterR w2 w3 -> laterR w1 w3.
Proof.
intros.
revert w3 H0; induction H; intros.
econstructor 2. constructor 1; eauto. apply H0.
auto.
auto.
Qed.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo240 : goal 240. Time solve_P. Time Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E F G H I Aprime Aprimeprime : Universe, ((wd_ A B /\ (wd_ A Aprime /\ (wd_ C B /\ (wd_ D E /\ (wd_ Aprimeprime B /\ (wd_ F E /\ (wd_ G H /\ (wd_ I H /\ (wd_ Aprime B /\ (wd_ Aprimeprime C /\ (wd_ Aprime C /\ (col_ A B C /\ col_ A B Aprime)))))))))))) -> col_ Aprime C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^171 - 19
Base: 21.375
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 21 + 3/8;
    bitwidth := 32;
    s := 2^171;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Theorem t : forall n, n = 0 \/ n > 0.
Proof.
  intro. destruct n.
  auto.
  + { right.
      - { { admit.
          }
        }
    }
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^194 - 33
Base: 24.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 24 + 1/4;
    bitwidth := 32;
    s := 2^194;
    c := [(1, 33)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus lv0 Zero))).
Admitted.
QuickChick conj27eqsynthconj3.