Require Import msl.base.
Require Import msl.ageable.
Require Import msl.sepalg.
Require Import msl.sepalg_generators.
Require Import msl.age_sepalg.
Require Import msl.predicates_hered.
Require Import msl.predicates_sl.

Local Open Scope pred.

Definition corable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
         (P: pred A) := forall w, P w = P (core w).

Lemma corable_spec: forall {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
  (P: pred A),
    corable P = forall x y:A, core x = core y -> P x -> P y.
Proof.
  unfold corable; intros; apply prop_ext; split; intros.
  + rewrite H in H1 |- *.
    rewrite <- H0.
    auto.
  + pose proof core_idem w.
    pose proof (H _ _ H0).
    pose proof (H _ _ (eq_sym H0)).
    apply prop_ext; split; auto.
Qed.

Lemma corable_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P && Q).
Proof.
 unfold corable; intros.
 apply prop_ext; split; intros [? ?]; split; congruence.
Qed.
Lemma corable_orp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P || Q).
Proof.
 unfold corable; intros.
 apply prop_ext; split; (intros [?|?]; [left|right]; congruence).
Qed.
Lemma corable_allp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall {B: Type} (P:  B -> pred A) ,
      (forall b, corable (P b)) -> corable (allp P).
Proof.
 unfold corable, allp; intros.
 apply prop_ext; split; simpl; intros.
 rewrite <- H; auto. rewrite H; auto.
Qed.
Lemma corable_exp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall {B: Type} (P:  B -> pred A) ,
      (forall b, corable (P b)) -> corable (exp P).
Proof.
 unfold corable, exp; intros.
 apply prop_ext; split; simpl; intros;  destruct H0 as [b ?]; exists b.
 rewrite <- H; auto. rewrite H; auto.
Qed.
Lemma corable_prop{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P, corable (prop P).
Proof.
 unfold corable, prop; intros.
 apply prop_ext; split; simpl; intros; auto.
Qed.

Lemma corable_imp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} {agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P --> Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold imp in *.
  simpl in *.
  intros.
  rename a' into y'.
  pose proof H3.
  apply necR_power_age in H5.
  destruct H5 as [n ?H].
  destruct (power_age_parallel' _ y' _ n (eq_sym H1) H5) as [x' [?H ?H]].
  apply (H0 _ _ (eq_sym H7)).
  apply H2.
  + apply necR_power_age; exists n; auto.
  + apply (H _ _ H7); auto.
Qed.

Lemma corable_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, corable P -> corable Q -> corable (P * Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold sepcon.
  intros.
  simpl in H2 |- *.
  destruct H2 as [x' [x'' [? [? ?]]]].
  pose proof join_core H2.
  pose proof join_core (join_comm H2).
  exists (core y), y.
  repeat split.
  + apply core_unit.
  + apply H with x'; auto.
    rewrite core_idem.
    congruence.
  + apply H0 with x''; auto.
    congruence.
Qed.

Lemma corable_wand: forall {A:Type} {agA:ageable A} {JA: Join A} {PA: Perm_alg A} {SaA: Sep_alg A} {XA: Age_alg A} (P Q: pred A), corable P -> corable Q -> corable (P -* Q).
Proof.
  intros.
  rewrite corable_spec in H, H0 |- *.
  unfold wand in *.
  simpl in *.
  intros.
  rename x' into y'.
  rename y0 into w'.
  rename z into z'.
  apply necR_power_age in H3.
  destruct H3 as [n ?H].
  pose proof power_age_parallel' _ y' _ n (eq_sym H1) H3.
  destruct H6 as [x' [?H ?H]].
  pose proof join_core H4.
  pose proof join_core (join_comm H4).
  apply H0 with x'; [congruence |].
  apply (H2  x' (core x') x').
  + apply necR_power_age.
    exists n; auto.
  + apply join_comm, core_unit.
  + apply H with w'; auto.
    rewrite core_idem.
    congruence.
Qed.

Lemma corable_later: forall {A:Type} {agA:ageable A} {JA: Join A} {PA: Perm_alg A} {SaA: Sep_alg A} {XA: Age_alg A} P, corable P -> corable (|> P).
Proof.
  intros.
  rewrite corable_spec in H |- *.
  intros.
  unfold box in *.
  simpl in *.
  intros.
  apply laterR_power_age in H2.
  destruct H2 as [n ?H].
  rename a' into y'.
  destruct (power_age_parallel' _ y' _ _ (eq_sym H0) H2) as [x' [? ?]].
  apply H with x'; auto.
  apply H1.
  apply laterR_power_age.
  exists n; auto.
Qed.

Hint Resolve @corable_andp @corable_orp @corable_allp @corable_exp
                    @corable_imp @corable_prop @corable_sepcon @corable_wand @corable_later.

Lemma corable_andp_sepcon1{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  (P && Q) * R = P && (Q * R).
Proof.
intros.
apply pred_ext.
intros w [w1 [w2 [? [[? ?] ?]]]].
split.
apply join_core in H0.
rewrite H in H1|-*. rewrite <- H0; auto.
exists w1; exists w2; split; [| split]; auto.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; [|split]; auto.
split; auto.
apply join_core in H1.
rewrite H in H0|-*. rewrite H1; auto.
Qed.

(* The following 3 lemmas should not be necessary *)
Lemma corable_andp_sepcon2{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  (Q && P) * R = P && (Q * R).
Proof.
intros. rewrite andp_comm. apply corable_andp_sepcon1. auto.
Qed.

Lemma corable_sepcon_andp1 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  Q  * (P && R) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

Lemma corable_sepcon_andp2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall P Q R, corable P ->  Q  * (R && P) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite andp_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

(* This hint doesn't work well, hence the extra clauses in normalize1 and normalize1_in *)
Hint Rewrite @corable_andp_sepcon1 @corable_andp_sepcon2
                    @corable_sepcon_andp1 @corable_sepcon_andp2 using solve [auto with normalize typeclass_instances].


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Datatypes.PropSet.
Require Import Coq.Lists.List. (* after SeparationLogic *)
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.DestructHead.

(* for [eauto with lia] *)
Require Import Crypto.Util.ZUtil.Hints.Core.

Import API.Compilers.
Import ListNotations Types.Notations.

Section UsedVarnames.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.
  Local Existing Instance Types.rep.Z.
  Local Instance varname_eqb_spec x y : BoolSpec _ _ _
    := Decidable.String.eqb_spec x y.
  Local Notation varname := String.string.

  Definition used_varnames nextn nvars : set varname :=
    of_list (map varname_gen (seq nextn nvars)).

  Lemma used_varnames_iff nextn nvars v :
    used_varnames nextn nvars v <->
    (exists n,
        v = varname_gen n /\ nextn <= n < nextn + nvars)%nat.
  Proof.
    cbv [used_varnames of_list]. revert nextn v.
    induction nvars; intros; cbn [seq map In];
      [ split; try tauto; intros; cleanup; lia | ].
    rewrite IHnvars.
    split; intros;
      repeat match goal with
             | _ => progress cleanup
             | _ => progress subst
             | H : _ \/ _ |- _ => destruct H
             | |- exists _, _ => eexists; solve [eauto with lia]
             end; [ ].
    match goal with H : _ <= _ |- _ =>
                    apply le_lt_or_eq in H; destruct H; [right | left]
    end.
    { eexists; eauto with lia. }
    { congruence. }
  Qed.

  Lemma used_varnames_disjoint n1 n2 l1 l2 :
    n1 + l1 <= n2 ->
    disjoint (used_varnames n1 l1) (used_varnames n2 l2).
  Proof.
    cbv [used_varnames].
    revert n1 n2 l2; induction l1; cbn [map seq]; intros;
      rewrite ?of_list_nil, ?of_list_cons;
      eauto using disjoint_empty_l.
    rewrite add_union_singleton.
    apply disjoint_union_l_iff; split; eauto with lia; [ ].
    apply disjoint_not_in. intro.
    repeat match goal with
           | _ => progress cleanup
           | H : In _ (map _ _) |- _ => rewrite in_map_iff in H
           | H : In _ (seq _ _) |- _ => rewrite in_seq in H
           | H : varname_gen _ = varname_gen _ |- _ =>
             apply varname_gen_unique in H
           | _ => lia
           end.
  Qed.

  Lemma used_varnames_succ_high n l :
    sameset (used_varnames n (S l))
            (add (used_varnames n l) (varname_gen (n + l))).
  Proof.
    intros. cbv [used_varnames].
    rewrite seq_snoc, map_app. cbn [map].
    rewrite of_list_app, of_list_cons.
    rewrite !add_union_singleton, of_list_nil, union_empty_r.
    apply union_comm.
  Qed.

  Lemma used_varnames_succ_low n m :
    PropSet.sameset (used_varnames n (S m))
                    (PropSet.add (used_varnames (S n) m)
                                 (varname_gen n)).
  Proof.
    apply sameset_iff. cbn. firstorder idtac.
  Qed.

  Lemma used_varnames_1 n :
    PropSet.sameset (used_varnames n 1)
                    (PropSet.singleton_set (varname_gen n)).
  Proof.
    apply sameset_iff. cbn. firstorder idtac.
  Qed.

  Lemma used_varnames_subset n1 n2 l1 l2 :
    (n2 <= n1)%nat ->
    (n1 + l1 <= n2 + l2)%nat ->
    PropSet.subset (used_varnames n1 l1)
                   (used_varnames n2 l2).
  Proof.
    cbv [PropSet.subset PropSet.elem_of];
      intros; rewrite !used_varnames_iff in *.
    cleanup; subst.
    eexists; split; [ reflexivity | lia ].
  Qed.

  Lemma used_varnames_union n m l :
    sameset (used_varnames n (m + l))
            (union (used_varnames n m) (used_varnames (n + m) l)).
  Proof.
    cbv [used_varnames].
    revert n m; induction l; cbn [map seq]; intros;
      rewrite ?Nat.add_0_r, ?of_list_nil, ?union_empty_r;
      try reflexivity; [ ].
    rewrite of_list_cons, add_union_singleton, union_assoc.
    rewrite <-Nat.add_succ_comm. rewrite IHl.
    rewrite seq_snoc, map_app. cbn [map].
    rewrite of_list_app, of_list_cons.
    rewrite !add_union_singleton, of_list_nil, union_empty_r.
    rewrite Nat.add_succ_r.
    reflexivity.
  Qed.

  Lemma used_varnames_shift n m l :
    subset (used_varnames (n + m) l)
           (used_varnames n (m + l)).
  Proof.
    cbv [subset]. intros.
    match goal with H : _ |- _ =>
                    apply used_varnames_iff in H end.
    apply used_varnames_iff.
    cleanup; subst. eexists; split; eauto.
    lia.
  Qed.

  Lemma used_varnames_subset_singleton n m l :
    n <= m < n + l ->
    subset (singleton_set (varname_gen m))
           (used_varnames n l).
  Proof.
    cbv [subset singleton_set elem_of]. intros.
    apply used_varnames_iff; subst.
    eexists; split; eauto; lia.
  Qed.

  Implicit Types l : locals.

  Lemma only_differ_zero nextn l :
    map.only_differ l (used_varnames nextn 0) l.
  Proof.
    cbv [map.only_differ used_varnames of_list elem_of].
    tauto.
  Qed.

  Lemma only_differ_succ nextn nvars l1 l2 v :
    map.only_differ (map.put l1 (varname_gen nextn) v)
                    (used_varnames (S nextn) nvars) l2 ->
    map.only_differ l1 (used_varnames nextn (S nvars)) l2.
  Proof.
    intros.
    eapply Proper_only_differ;
      [ reflexivity | | reflexivity | eapply only_differ_trans;
         solve [eauto using @only_differ_sym, @only_differ_put with typeclass_instances ] ].
    eapply sameset_iff; intros.
    cbv [used_varnames of_list elem_of union singleton_set].
    cbn [seq map In].
    tauto.
  Qed.

  Lemma only_differ_step nvars nvars' nextn l1 l2 l3 :
    map.only_differ l1 (used_varnames nextn nvars) l2 ->
    map.only_differ l2 (used_varnames (nextn + nvars) nvars') l3 ->
    map.only_differ l1 (used_varnames nextn (nvars + nvars')) l3.
  Proof.
    cbv [map.only_differ used_varnames of_list
                         elem_of].
    let H1 := fresh in
    let H2 := fresh in
    let x := fresh "x" in
    intros H1 H2 x; specialize (H1 x); specialize (H2 x).
    repeat match goal with
           | _ => progress cleanup
           | _ => progress subst
           | H : _ \/ _ |- _ => destruct H
           | |- context [In _ (map _ _)] => rewrite in_map_iff
           | H : In _ (map _ _) |- _ => apply in_map_iff in H
           | H : In _ (seq _ _) |- _ => apply in_seq in H
           | H : varname_gen _ = varname_gen _ |- _ =>
             apply varname_gen_unique in H
           | _ => solve [right; congruence]
           | _ => solve [left; eexists;
                         rewrite in_seq, varname_gen_unique; split;
                         eauto with lia ]
           end.
  Qed.

  Lemma disjoint_used_varnames_lt n nvars (vset : set varname) :
    (forall x, n <= x -> ~ vset (varname_gen x)) ->
    disjoint (used_varnames n nvars) vset.
  Proof.
    cbv [disjoint elem_of]; intros.
    apply Decidable.imp_simp.
    { cbv [used_varnames Decidable.decidable of_list ].
      match goal with
        |- In ?x ?l \/ ~ In ?x ?l =>
        destruct (in_dec string_dec x l); [left|right]
      end; tauto. }
    rewrite used_varnames_iff.
    intros; cleanup; subst.
    eauto with lia.
  Qed.

  Lemma disjoint_used_varnames_singleton n nvars m :
    m < n ->
    disjoint (used_varnames n nvars)
             (singleton_set (varname_gen m)).
  Proof.
    cbv [singleton_set elem_of]; intros.
    eapply disjoint_used_varnames_lt. intros.
    rewrite varname_gen_unique. lia.
  Qed.
End UsedVarnames.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.

Import HaskellListNotations.
Open Scope string.

Definition whole_prog := [(NonRecursive (Decl (0,"demote") DPrim)),(NonRecursive (Decl (1,"+") DPrim)),(NonRecursive (Decl (2,"-") DPrim)),(NonRecursive (Decl (3,"*") DPrim)),(NonRecursive (Decl (4,"/") DPrim)),(NonRecursive (Decl (5,"%") DPrim)),(NonRecursive (Decl (6,"^^") DPrim)),(NonRecursive (Decl (7,"lg2") DPrim)),(NonRecursive (Decl (9,"True") DPrim)),(NonRecursive (Decl (10,"False") DPrim)),(NonRecursive (Decl (11,"negate") DPrim)),(NonRecursive (Decl (12,"complement") DPrim)),(NonRecursive (Decl (13,"<") DPrim)),(NonRecursive (Decl (14,">") DPrim)),(NonRecursive (Decl (15,"<=") DPrim)),(NonRecursive (Decl (16,">=") DPrim)),(NonRecursive (Decl (17,"==") DPrim)),(NonRecursive (Decl (18,"!=") DPrim)),(NonRecursive (Decl (19,"===") (DExpr (ETAbs (87,"a") (ETAbs (88,"b") (EAbs (89,"f") (EAbs (90,"g") (EAbs (91,"x") (EApp (EApp (ETApp (EVar (17,"==")) (TVar (TVBound 31 KType))) (EApp (EVar (89,"f")) (EVar (91,"x")))) (EApp (EVar (90,"g")) (EVar (91,"x")))))))))))),(NonRecursive (Decl (20,"!==") (DExpr (ETAbs (92,"a") (ETAbs (93,"b") (EAbs (94,"f") (EAbs (95,"g") (EAbs (96,"x") (EApp (EApp (ETApp (EVar (18,"!=")) (TVar (TVBound 41 KType))) (EApp (EVar (94,"f")) (EVar (96,"x")))) (EApp (EVar (95,"g")) (EVar (96,"x")))))))))))),(NonRecursive (Decl (21,"min") (DExpr (ETAbs (97,"a") (EAbs (98,"x") (EAbs (99,"y") (EIf (EApp (EApp (ETApp (EVar (13,"<")) (TVar (TVBound 50 KType))) (EVar (98,"x"))) (EVar (99,"y"))) (EVar (98,"x")) (EVar (99,"y"))))))))),(NonRecursive (Decl (22,"max") (DExpr (ETAbs (100,"a") (EAbs (101,"x") (EAbs (102,"y") (EIf (EApp (EApp (ETApp (EVar (14,">")) (TVar (TVBound 56 KType))) (EVar (101,"x"))) (EVar (102,"y"))) (EVar (101,"x")) (EVar (102,"y"))))))))),(NonRecursive (Decl (23,"/\\") (DExpr (EAbs (103,"x") (EAbs (104,"y") (EIf (EVar (103,"x")) (EVar (104,"y")) (EVar (10,"False")))))))),(NonRecursive (Decl (24,"\\/") (DExpr (EAbs (105,"x") (EAbs (106,"y") (EIf (EVar (105,"x")) (EVar (9,"True")) (EVar (106,"y")))))))),(NonRecursive (Decl (25,"==>") (DExpr (EAbs (107,"a") (EAbs (108,"b") (EIf (EVar (107,"a")) (EVar (108,"b")) (EVar (9,"True")))))))),(NonRecursive (Decl (26,"&&") DPrim)),(NonRecursive (Decl (27,"||") DPrim)),(NonRecursive (Decl (28,"^") DPrim)),(NonRecursive (Decl (29,"zero") DPrim)),(NonRecursive (Decl (30,"<<") DPrim)),(NonRecursive (Decl (31,">>") DPrim)),(NonRecursive (Decl (32,"<<<") DPrim)),(NonRecursive (Decl (33,">>>") DPrim)),(NonRecursive (Decl (34,"#") DPrim)),(NonRecursive (Decl (35,"splitAt") DPrim)),(NonRecursive (Decl (36,"join") DPrim)),(NonRecursive (Decl (37,"split") DPrim)),(NonRecursive (Decl (38,"reverse") DPrim)),(NonRecursive (Decl (39,"transpose") DPrim)),(NonRecursive (Decl (40,"@") DPrim)),(NonRecursive (Decl (41,"@@") DPrim)),(NonRecursive (Decl (42,"!") DPrim)),(NonRecursive (Decl (43,"!!") DPrim)),(NonRecursive (Decl (44,"update") DPrim)),(NonRecursive (Decl (45,"updateEnd") DPrim)),(NonRecursive (Decl (46,"updates") (DExpr (ETAbs (162,"a") (ETAbs (163,"b") (ETAbs (164,"c") (ETAbs (165,"d") (EAbs (166,"xs0") (EAbs (167,"idxs") (EAbs (168,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 124 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (169,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (169,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 124 KNum))) (TCon (TC TCSeq) [TVar (TVBound 121 KNum),TVar (TVBound 122 KType)])) (EList [(EVar (166,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (44,"update")) (TVar (TVBound 121 KNum))) (TVar (TVBound 122 KType))) (TVar (TVBound 123 KNum))) (EVar (170,"xs"))) (EVar (171,"i"))) (EVar (172,"b"))) [[(From (170,"xs") (EVar (169,"xss")))],[(From (171,"i") (EVar (167,"idxs")))],[(From (172,"b") (EVar (168,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (47,"updatesEnd") (DExpr (ETAbs (173,"a") (ETAbs (174,"b") (ETAbs (175,"c") (ETAbs (176,"d") (EAbs (177,"xs0") (EAbs (178,"idxs") (EAbs (179,"vals") (EWhere (EApp (EApp (ETApp (ETApp (ETApp (EVar (42,"!")) (TCon (TF TCAdd) [TCon (TC (TCNum 1)) [],TVar (TVBound 159 KNum)])) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (TCon (TC (TCNum 0)) [])) (EVar (180,"xss"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) []))) [(Recursive [(Decl (180,"xss") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (34,"#")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 159 KNum))) (TCon (TC TCSeq) [TVar (TVBound 156 KNum),TVar (TVBound 157 KType)])) (EList [(EVar (177,"xs0"))])) (EComp (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (45,"updateEnd")) (TVar (TVBound 156 KNum))) (TVar (TVBound 157 KType))) (TVar (TVBound 158 KNum))) (EVar (181,"xs"))) (EVar (182,"i"))) (EVar (183,"b"))) [[(From (181,"xs") (EVar (180,"xss")))],[(From (182,"i") (EVar (178,"idxs")))],[(From (183,"b") (EVar (179,"vals")))]]))))])]))))))))))),(NonRecursive (Decl (48,"fromThen") DPrim)),(NonRecursive (Decl (49,"fromTo") DPrim)),(NonRecursive (Decl (50,"fromThenTo") DPrim)),(NonRecursive (Decl (51,"infFrom") DPrim)),(NonRecursive (Decl (52,"infFromThen") DPrim)),(NonRecursive (Decl (53,"error") DPrim)),(NonRecursive (Decl (54,"pmult") DPrim)),(NonRecursive (Decl (55,"pdiv") DPrim)),(NonRecursive (Decl (56,"pmod") DPrim)),(NonRecursive (Decl (57,"random") DPrim)),(NonRecursive (Decl (61,"take") (DExpr (ETAbs (209,"front") (ETAbs (210,"back") (ETAbs (211,"elem") (EAbs (212,"__p1") (EWhere (EVar (214,"x")) [(NonRecursive (Decl (213,"__p2") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (TVar (TVBound 214 KNum))) (TVar (TVBound 215 KNum))) (TVar (TVBound 216 KType))) (EVar (212,"__p1")))))),(NonRecursive (Decl (214,"x") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 0))))),(NonRecursive (Decl (215,"__p0") (DExpr (ESel (EVar (213,"__p2")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (62,"drop") (DExpr (ETAbs (216,"front") (ETAbs (217,"back") (ETAbs (218,"elem") (EAbs (219,"__p4") (EWhere (EVar (222,"y")) [(NonRecursive (Decl (220,"__p5") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (35,"splitAt")) (TVar (TVBound 231 KNum))) (TVar (TVBound 232 KNum))) (TVar (TVBound 233 KType))) (EVar (219,"__p4")))))),(NonRecursive (Decl (221,"__p3") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 0))))),(NonRecursive (Decl (222,"y") (DExpr (ESel (EVar (220,"__p5")) (TupleSel 1)))))])))))))),(NonRecursive (Decl (63,"tail") (DExpr (ETAbs (223,"a") (ETAbs (224,"b") (EAbs (225,"xs") (EApp (ETApp (ETApp (ETApp (EVar (62,"drop")) (TCon (TC (TCNum 1)) [])) (TVar (TVBound 249 KNum))) (TVar (TVBound 250 KType))) (EVar (225,"xs"))))))))),(NonRecursive (Decl (64,"width") (DExpr (ETAbs (226,"bits") (ETAbs (227,"len") (ETAbs (228,"elem") (EAbs (229,"__p6") (ETApp (ETApp (EVar (0,"demote")) (TVar (TVBound 256 KNum))) (TVar (TVBound 255 KNum)))))))))),(NonRecursive (Decl (65,"undefined") (DExpr (ETAbs (230,"a") (EApp (ETApp (ETApp (EVar (53,"error")) (TVar (TVBound 260 KType))) (TCon (TC (TCNum 9)) [])) (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 117)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 102)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 105)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 110)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 101)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 100)) [])) (TCon (TC (TCNum 8)) []))])))))),(NonRecursive (Decl (66,"groupBy") (DExpr (ETAbs (231,"each") (ETAbs (232,"parts") (ETAbs (233,"elem") (ETApp (ETApp (ETApp (EVar (37,"split")) (TVar (TVBound 266 KNum))) (TVar (TVBound 265 KNum))) (TVar (TVBound 267 KType))))))))),(NonRecursive (Decl (68,"trace") DPrim)),(NonRecursive (Decl (69,"traceVal") (DExpr (ETAbs (238,"n") (ETAbs (239,"a") (EAbs (240,"msg") (EAbs (241,"x") (EApp (EApp (EApp (ETApp (ETApp (ETApp (EVar (68,"trace")) (TVar (TVBound 273 KNum))) (TVar (TVBound 274 KType))) (TVar (TVBound 274 KType))) (EVar (240,"msg"))) (EVar (241,"x"))) (EVar (241,"x")))))))))),(NonRecursive (Decl (242,"x") (DExpr (EList [(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 3)) [])) (TCon (TC (TCNum 8)) [])),(ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 4)) [])) (TCon (TC (TCNum 8)) []))])))),(NonRecursive (Decl (243,"y") (DExpr (EApp (ETApp (ETApp (ETApp (EVar (37,"split")) (TCon (TC (TCNum 2)) [])) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (EVar (242,"x")))))),(NonRecursive (Decl (244,"a") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 0)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 0)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))))),(NonRecursive (Decl (245,"b") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 1)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 0)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) [])))))),(NonRecursive (Decl (246,"c") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 0)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 1)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 0)) [])) (TCon (TC (TCNum 0)) [])))))),(NonRecursive (Decl (247,"d") (DExpr (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []])) (TCon (TC (TCNum 1)) [])) (EApp (EApp (ETApp (ETApp (ETApp (EVar (40,"@")) (TCon (TC (TCNum 2)) [])) (TCon (TC TCSeq) [TCon (TC (TCNum 2)) [],TCon (TC TCSeq) [TCon (TC (TCNum 8)) [],TCon (TC TCBit) []]])) (TCon (TC (TCNum 1)) [])) (EVar (243,"y"))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) [])))) (ETApp (ETApp (EVar (0,"demote")) (TCon (TC (TCNum 1)) [])) (TCon (TC (TCNum 1)) []))))))].

Definition ge := bind_decl_groups whole_prog gempty.

Definition a := EVar (244,"a").
Definition b := EVar (245,"b").
Definition c := EVar (246,"c").
Definition d := EVar (247,"d").

Definition v (z : Z) := @repr 8 z.


Require Import ZArith.
Require Import interface_tyc2.

Require Import Logic.SeparationLogic.Sound.Sound_Flat.
Require Import Logic.SeparationLogic.ShallowEmbedded.PredicateSeparationLogic.

Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.

Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfJudgement.

Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfIteratedConnectives.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfClassicalAxioms.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.

Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.

Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfCancel.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.ProofTheory.IterSepcon.
Require Import Logic.SeparationLogic.ProofTheory.Corable.
Require Import Logic.SeparationLogic.ProofTheory.Deduction.

Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.PropositionalLogic.ShallowEmbedded.PredicatePropositionalLogic.

Require Import Logic.SeparationLogic.Model.OSAExamples.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.

Definition var : Type := nat.

Definition store : Type := var -> Z.

Definition addr : Type := Z.

Definition heap : Type := Heap addr Z.

Definition state : Type := store * heap.

(* Definition join_heap : heap -> heap -> heap -> Prop :=
  fun h1 h2 h3 =>
    forall p : Z,
      (exists v, h1 p = Some v /\ h2 p = None /\ h3 p = Some v) \/
      (exists v, h1 p = None /\ h2 p = Some v /\ h3 p = Some v) \/
      (h1 p = None /\ h2 p = None /\ h3 p = None).

Definition join : state -> state -> state -> Prop :=
  fun st1 st2 st3 => fst st1 = fst st2 /\ fst st2 = fst st3 /\ join_heap (snd st1) (snd st2) (snd st3).

Definition SepCon (e1 e2 : state -> Prop) : state -> Prop :=
  fun st => exists st1 st2, join st1 st2 st /\ e1 st1 /\ e2 st2. *)

(* Definition jjoin (x y : nat -> option Z) : nat -> option Z :=
  fun p => match x p, y p with
    | Some n1, Some n2 => None
    | Some n1, None => Some n1
    | None, Some n2 => Some n2
    | None, None => None
  end. *)

Instance stateR : KripkeModel.KI.Relation (state) := fun x y => x = y.

Instance store_join : Join store := equiv_Join.

Instance heap_join : Join heap := Heap_Join addr Z.

Instance stateJoin : Join state := prod_Join store heap.

Instance stateJ : SeparationAlgebra.Join (state) := stateJoin.

Instance storeSA : SeparationAlgebra store := equiv_SA.

Instance heapSA : SeparationAlgebra heap := Heap_SA addr Z.

Instance stateSA : SeparationAlgebra state := prod_SA store heap.

Module NaiveLang <: LanguageSig.
  Definition expr := state -> Prop.
  Section NaiveLang.
    Definition context := expr -> Prop.
    Definition provable (e : expr) : Prop := forall st, e st.
    Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
    Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
    Definition sepcon := WeakSemantics.sepcon.
    Definition falsep : expr := fun st => False.
    Definition emp : expr := fun st => forall p, (snd st) p = None.
  End NaiveLang.
End NaiveLang.

Module NaiveRule.
Include DerivedNames (NaiveLang).

Instance L : Language := (Build_Language expr) .
Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
Instance falsepL : (FalseLanguage L) := (Build_FalseLanguage L falsep) .

Lemma falsep_sepcon_impp : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
Proof.
  unfold provable, impp, sepcon, falsep. intros.
  destruct H as [st1 [st2 ?]]. tauto.
Qed.

Lemma sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
Proof.
  intros x y.
  exact (@sound_sepcon_comm L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y).
Qed.

Lemma sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
Proof.
  intros x y z.
  exact (@sound_sepcon_assoc1 L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y z).
Qed.

Lemma sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
Proof.
  unfold provable, impp, sepcon.
  intros.
  destruct H1 as [st1 [st2 ?]].
  exists st1, st2.
  split; try tauto.
  specialize (H st1). specialize (H0 st2).
  tauto.
Qed.

Lemma andp_intros : (forall x y : expr, provable (impp x (impp y (andp x y)))) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma andp_elim1 : (forall x y : expr, provable (impp (andp x y) x)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma andp_elim2 : (forall x y : expr, provable (impp (andp x y) y)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma modus_ponens : (forall x y : expr, provable (impp x y) -> provable x -> provable y) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma axiom1 : (forall x y : expr, provable (impp x (impp y x))) .
Proof.
  unfold provable, impp. auto.
Qed.

Lemma axiom2 : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z)))) .
Proof.
  unfold provable, impp. auto.
Qed.

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
(*Module Solver := IPSolver NaiveLang.*)
Import T.


Require Import ExtLib.Data.Stream.
Require Import ExtLib.Structures.MonadState.
Require Import QArith.Qcanon.
Require Import QArith_base.
Require Import Coq.Lists.List.
Require Import ExtLib.Data.Vector.
Require Import ExtLib.Structures.Functor.

Require Import BinNums.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Data.Monads.IdentityMonad.
Require Import ExtLib.Data.Monads.StateMonad.

Require Import Markov.Random.

(** Following the semantics of Huang and Morrisett:
 **  [An application of computable distributions to the semantics of
 **   probabilistic programming languages]
 **)
Definition PD (T : Type) : Type := state Bits T.
Global Instance Monad_PD : Monad PD := Monad_state _.

(*
(**
 ** A sampler for biased coin flips
 ** NOTE: This sampler is not correct for rationals that are not [x/2^n]
 **)
Local Fixpoint get_precision (n : positive) : positive :=
  match n with
  | q~1 => Psucc (get_precision q)
  | q~0 => Psucc (get_precision q)
  | 1 => 1
  end%positive.

Local Fixpoint Q_to_precision' (n : positive) (b : Bits) (acc : N)
      {T} (k : N -> Bits -> T) : T :=
  match n with
  | xH => match b with
          | Bit Int32.D1 b' => k (2 * acc + 1)%N b'
          | Bit Int32.D0 b' => k (2 * acc)%N b'
          end
  | xO n => Q_to_precision' n b acc (fun acc b => Q_to_precision' n b acc k)
  | xI n => match b with
            | Bit c b' =>
              let acc' := (if c then 2 * acc + 1 else 2 * acc)%N in
              Q_to_precision' n b' acc' (fun acc b => Q_to_precision' n b acc k)
            end
  end.

Local Definition Q_to_precision (prec : positive) (b : Bits) : Q * Bits :=
  Q_to_precision' prec b 0%N
                  (fun n b => ({| Qnum := Z_of_N n
                                ; Qden := pow_pos Pmult 2%positive prec |} , b)).

Definition flip (q : Q) : PD bool :=
  {| runState := fun b =>
                   match Qcompare q 0 with
                   | Lt => (true, b)
                   | _ => match Qcompare 1 q with
                          | Lt => (false, b)
                          | _ =>
                            let prec := get_precision q.(Qden) in
                            let (q', b') := Q_to_precision prec b in
                            (match Qcompare q' q with
                             | Lt | Eq => true
                             | Gt => false
                             end, b')
                          end
                   end |}.
*)

(**
 ** A fair coin flip
 **)
Definition fair_coin : PD bool :=
  {| runState := fun b =>
                   match b with
                   | Bit x b =>
                     (match x with
                      | Int32.D0 => false
                      | Int32.D1 => true
                      end, b)
                   end |}.

(*
(**
 ** Random from Range
 **)
Fixpoint from_range (low count : nat) : PD nat :=
  match count with
  | 0 => ret low
  | S n =>
    bind (flip {| Qnum := 1%Z ; Qden := Pos.of_succ_nat n |})
         (fun x => if x then ret low
                   else from_range (S low) n)
  end%nat.
*)

(*
Definition digits (n : nat) : PD (vector Int32.digits n) :=
{| runState := fun b => takeBits n b (fun a b => (b, a)) |}.
*)

Section sample.
  Context {T : Type} (c : PD T).
  Local Instance MonadState_state : MonadState Bits PD := MonadState_state _.

  Let comp : PD T :=
    bind (mkState take_int32) (fun z1 =>
    bind (mkState take_int32) (fun z2 =>
    bind (mkState take_int32) (fun z3 =>
    bind (mkState take_int32) (fun z4 =>
    bind (MonadState.put (lfsr113_gen z1 z2 z3 z4))
         (fun _ => c))))).

  CoFixpoint sample (s : Bits)
  : stream T :=
    scons (evalState comp s)
          (sample (@takeBits 17 s _ (fun x _ => x))).
End sample.

(** TODO(gmalecha): To ExtLib **)
Section stream_take.
  Context {T : Type}.

  Fixpoint take (n : nat) (s : stream T) : list T :=
    match n with
    | Datatypes.O => nil
    | Datatypes.S n => match s with
                       | scons v s => v :: take n s
                       | snil => nil
                       end
    end.
End stream_take.

Require Import ExtLib.Core.RelDec.

Section sample_discrete.
  Context {T : Type} {r : RelDec (@eq T)}.

  Require Import ExtLib.Data.Map.FMapAList.

  Definition increment (k : T) (ls : alist T positive) : alist T positive :=
    match alist_find _ k ls with
    | None => alist_add _ k 1%positive ls
    | Some x => alist_add _ k (Pos.succ x) ls
    end.

  Definition sample_discrete (n : nat) (c : PD T) : alist T Q :=
    fmap (fun x => this (Q2Qc {| Qnum := Zpos x ; Qden := Pos.of_nat n |}))
         (List.fold_left (fun d r => increment r d) (take n (sample c lfsr113))
                         nil).
End sample_discrete.

Require Export ExtLib.Structures.Monad.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.ListUtil.FoldBool.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.ZUtil.Tactics.LinearSubstitute.
Require Import Crypto.Util.ZUtil.Hints.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.
Require Import Crypto.Util.ZUtil.ZSimplify.Simple.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.AddGetCarry.
Require Import Crypto.Util.ZUtil.MulSplit.
Require Import Crypto.Util.ZUtil.Ltz.
Require Import Crypto.Util.ZUtil.TruncatingShiftl.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Divide.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Opp.
Require Import Crypto.Util.ZUtil.Pow.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.ZUtil.Lor.
Require Import Crypto.Util.ZUtil.LandLorShiftBounds.
Require Import Crypto.Util.ZUtil.Shift.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.ZRange.OperationsBounds.
Require Import Crypto.Util.Tactics.NormalizeCommutativeIdentifier.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.SpecializeAllWays.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Tactics.SetEvars.
Require Import Crypto.Util.Tactics.SubstEvars.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ListUtil.Forall.
Require Import Crypto.Util.ListUtil.ForallIn.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.CPSNotations.
Require Import Crypto.Util.HProp.
Require Import Crypto.Util.Decidable.
Require Crypto.Util.PrimitiveProd.
Require Crypto.Util.PrimitiveHList.
Require Import Crypto.Language.PreExtra.
Require Import Crypto.CastLemmas.
Require Import Crypto.Rewriter.Rules.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope bool_scope. Local Open Scope Z_scope.

Local Definition mymap {A B} := Eval cbv in @List.map A B.
Local Definition myapp {A} := Eval cbv in @List.app A.
Local Definition myflatten {A} := Eval cbv in List.fold_right myapp (@nil A).
Local Notation dont_do_again := (pair false) (only parsing).
Local Notation do_again := (pair true) (only parsing).

Local Ltac start_proof :=
  cbv [snd]; hnf; cbv [id
                         PrimitiveHList.hlist ident.eagerly ident.literal Let_In ident.cast2]; ident.fancy.cbv_fancy;
  repeat apply PrimitiveProd.Primitive.pair; try exact tt.

Local Hint Resolve
      eq_repeat_nat_rect
      eq_app_list_rect
      eq_combine_list_rect
      eq_firstn_nat_rect
      eq_skipn_nat_rect
      eq_update_nth_nat_rect
  : core.

Lemma nbe_rewrite_rules_proofs
  : PrimitiveHList.hlist (@snd bool Prop) nbe_rewrite_rulesT.
Proof using Type. start_proof; auto. Qed.

Definition nbe_rewrite_rules_with_proofs
  := Eval cbv [PrimitiveHList.combine_hlist nbe_rewrite_rulesT] in
      PrimitiveHList.combine_hlist _ nbe_rewrite_rules_proofs.

Local Ltac interp_good_t_step_related :=
  first [ lazymatch goal with
          | [ |- ?x = ?x ] => reflexivity
          | [ |- True ] => exact I
          | [ H : ?x = true, H' : ?x = false |- _ ] => exfalso; clear -H H'; congruence
          | [ |- ?G ] => has_evar G; reflexivity
          (*| [ |- context[_ == _] ] => reflexivity*)
          (*| [ |- context[(fst ?x, snd ?x)] ] => progress eta_expand
                | [ |- context[match ?x with pair a b => _ end] ] => progress eta_expand*)
          end
        | progress cbn [fst snd] in *
        | match goal with
          | [ H : zrange * zrange |- _ ] => destruct H
          end
        | progress intros
        | progress subst
        | assumption
        | progress inversion_option
        | progress destruct_head'_and
        | progress destruct_head'_unit
        | progress split_andb
        | match goal with
          | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
          | [ H : forall v : unit, _ |- _ ] => specialize (H tt)
          | [ H : negb ?b = true |- _ ] => rewrite (@Bool.negb_true_iff b) in H
          | [ |- context[Z.mul_split ?a ?b ?c] ]
            => rewrite (surjective_pairing (Z.mul_split a b c)), Z.mul_split_div, Z.mul_split_mod
          | [ |- context[Z.zselect] ] => rewrite Z.zselect_correct
          | [ |- context[Z.truncating_shiftl] ] => rewrite Z.truncating_shiftl_correct
          | [ |- context[Z.sub_get_borrow_full ?a ?b ?c] ]
            => rewrite (surjective_pairing (Z.sub_get_borrow_full a b c)), Z.sub_get_borrow_full_div, Z.sub_get_borrow_full_mod
          | [ |- context[Z.sub_with_get_borrow_full ?a ?b ?c ?d] ]
            => rewrite (surjective_pairing (Z.sub_with_get_borrow_full a b c d)), Z.sub_with_get_borrow_full_div, Z.sub_with_get_borrow_full_mod
          | [ |- context[Z.add_get_carry_full ?a ?b ?c] ]
            => rewrite (surjective_pairing (Z.add_get_carry_full a b c)), Z.add_get_carry_full_div, Z.add_get_carry_full_mod
          | [ |- context[Z.add_with_get_carry_full ?a ?b ?c ?d] ]
            => rewrite (surjective_pairing (Z.add_with_get_carry_full a b c d)), Z.add_with_get_carry_full_div, Z.add_with_get_carry_full_mod
          | [ |- context[Z.mul_high ?a ?b ?c] ]
            => rewrite Z.mul_high_div
          | [ |- pair _ _ = pair _ _ ] => apply f_equal2
          | [ |- ?a mod ?b = ?a' mod ?b ] => apply f_equal2; lia
          | [ |- ?a / ?b = ?a' / ?b ] => apply f_equal2; lia
          | [ |- Z.opp _ = Z.opp _ ] => apply f_equal
          end
        | break_innermost_match_step
        | break_innermost_match_hyps_step
        | progress destruct_head'_or ].

Lemma arith_rewrite_rules_proofs (max_const_val : Z)
  : PrimitiveHList.hlist (@snd bool Prop) (arith_rewrite_rulesT max_const_val).
Proof using Type.
  start_proof; auto; intros; try lia.
  all: autorewrite with zsimplify_const; try reflexivity.
  all: repeat first [ reflexivity
                    | match goal with
                      | [ |- context[Z.shiftl] ] => rewrite Z.shiftl_mul_pow2 by auto with zarith
                      | [ |- context[Z.shiftr] ] => rewrite Z.shiftr_div_pow2 by auto with zarith
                      | [ H : ?x = 2^?n |- context[Z.land _ (?x - 1)] ]
                        => rewrite !Z.sub_1_r, H, <- Z.ones_equiv, Z.land_ones by auto with zarith
                      end
                    | Z.div_mod_to_quot_rem; nia
                    | interp_good_t_step_related ].
Qed.

Lemma unfold_value_barrier_rewrite_rules_proofs
  : PrimitiveHList.hlist (@snd bool Prop) unfold_value_barrier_rewrite_rulesT.
Proof using Type. now start_proof. Qed.

Local Lemma unfold_is_bounded_by_bool v r
  : is_bounded_by_bool v r = true -> lower r <= v <= upper r.
Proof using Type.
  cbv [is_bounded_by_bool]; intro; split_andb; Z.ltb_to_lt; split; assumption.
Qed.

Local Lemma unfold_is_tighter_than_bool r1 r2
  : is_tighter_than_bool r1 r2 = true -> lower r2 <= lower r1 /\ upper r1 <= upper r2.
Proof using Type.
  cbv [is_tighter_than_bool]; intro; split_andb; Z.ltb_to_lt; split; assumption.
Qed.

Local Ltac saturate_add_sub_bounds_step :=
  match goal with
  | [ H : (ZRange.normalize ?r <=? r[0~>?s-1])%zrange = true |- context[?v mod ?s] ]
    => unique assert (is_bounded_by_bool v (ZRange.normalize r) = true -> 0 <= v <= s - 1)
      by (let H' := fresh in
          intros H';
          eapply ZRange.is_bounded_by_of_is_tighter_than in H; [ apply unfold_is_bounded_by_bool in H; exact H | exact H' ])
  | [ H : is_bounded_by_bool (?x + ?y) (ZRange.normalize (ZRange.add ?rx ?ry)) = true -> ?T |- _ ]
    => unique assert (is_bounded_by_bool x rx = true -> is_bounded_by_bool y ry = true -> T)
      by (let Hx := fresh in
          let Hy := fresh in
          intros Hx Hy; apply H; clear -Hx Hy;
          rewrite !ZRange.normalize_add in *; now apply ZRange.is_bounded_by_bool_add)
  | [ H : is_bounded_by_bool (?x + ?y) (ZRange.add ?rx ?ry) = true -> ?T |- _ ]
    => unique assert (is_bounded_by_bool x rx = true -> is_bounded_by_bool y ry = true -> T)
      by (let Hx := fresh in
          let Hy := fresh in
          intros Hx Hy; apply H; clear -Hx Hy;
          now apply ZRange.is_bounded_by_bool_add)
  | [ H : is_bounded_by_bool (?x - ?y) (ZRange.normalize (ZRange.sub ?rx ?ry)) = true -> ?T |- _ ]
    => unique assert (is_bounded_by_bool x rx = true -> is_bounded_by_bool y ry = true -> T)
      by (let Hx := fresh in
          let Hy := fresh in
          intros Hx Hy; apply H; clear -Hx Hy;
          rewrite !ZRange.normalize_sub in *; now apply ZRange.is_bounded_by_bool_sub)
  | [ H : is_bounded_by_bool (?x - ?y) (ZRange.sub ?rx ?ry) = true -> ?T |- _ ]
    => unique assert (is_bounded_by_bool x rx = true -> is_bounded_by_bool y ry = true -> T)
      by (let Hx := fresh in
          let Hy := fresh in
          intros Hx Hy; apply H; clear -Hx Hy;
          now apply ZRange.is_bounded_by_bool_sub)
  | [ H : is_bounded_by_bool ?x ?r = true, H' : is_bounded_by_bool ?x ?r = true -> _ |- _ ]
    => unique pose proof (H' H)
  end.

Local Ltac interp_good_t_step_arith :=
  first [ lazymatch goal with
          | [ |- ?x = ?x ] => reflexivity
          | [ |- True ] => exact I
          | [ H : ?x = true, H' : ?x = false |- _ ] => exfalso; clear -H H'; congruence
          | [ H : true = false |- _ ]=> exfalso; clear -H; congruence
          | [ H : false = true |- _ ]=> exfalso; clear -H; congruence
          end
        | progress cbv [option_beq] in *
        | match goal with
          | [ H : context[ZRange.normalize (ZRange.normalize _)] |- _ ]
            => rewrite ZRange.normalize_idempotent in H
          | [ |- context[ZRange.normalize (ZRange.normalize _)] ]
            => rewrite ZRange.normalize_idempotent
          | [ |- context[ident.cast (ZRange.normalize ?r)] ]
            => rewrite ident.cast_normalize
          | [ H : context[ident.cast (ZRange.normalize ?r)] |- _ ]
            => rewrite ident.cast_normalize in H
          | [ H : ?T, H' : ?T |- _ ] => clear H'
          | [ H : context[is_bounded_by_bool _ (ZRange.normalize (-_))] |- _ ]
            => rewrite ZRange.is_bounded_by_bool_move_opp_normalize in H
          | [ |- context[is_bounded_by_bool _ (ZRange.normalize (-_))] ]
            => rewrite ZRange.is_bounded_by_bool_move_opp_normalize
          | [ H : is_bounded_by_bool ?v (ZRange.normalize ?r) = true |- context[ident.cast ?r ?v] ]
            => rewrite (@ident.cast_in_normalized_bounds r v) by exact H
          | [ H : is_bounded_by_bool ?v (ZRange.normalize ?r) = true |- context[ident.cast (-?r) (-?v)] ]
            => rewrite (@ident.cast_in_normalized_bounds (-r) (-v));
               [ | clear -H ]
          | [ |- context[ident.cast ?r (-ident.cast (-?r) ?v)] ]
            => rewrite (ident.cast_in_normalized_bounds r (-ident.cast (-r) v))
              by (rewrite <- ZRange.is_bounded_by_bool_move_opp_normalize; apply ident.cast_always_bounded)
          | [ |- context[ident.cast ?r (ident.cast ?r _)] ]
            => rewrite (@ident.cast_idempotent r)
          | [ H : is_bounded_by_bool _ ?r = true |- _]
            => is_var r; unique pose proof (ZRange.is_bounded_by_normalize _ _ H)
          | [ H : lower ?x = upper ?x |- _ ] => is_var x; destruct x; cbn [upper lower] in *
          | [ H : is_bounded_by_bool ?x (ZRange.normalize r[?y~>?y]) = true |- _ ]
            => apply ZRange.is_bounded_by_bool_normalize_constant_iff in H
          | [ H : is_bounded_by_bool ?x r[?y~>?y] = true |- _ ]
            => apply ZRange.is_bounded_by_bool_constant_iff in H
          | [ Hx : is_bounded_by_bool ?x _ = true, Hy : is_bounded_by_bool ?y _ = true
              |- Z.ltz ?x ?y = _ ]
            => cbv [Z.ltz];
               apply unfold_is_bounded_by_bool in Hx;
               apply unfold_is_bounded_by_bool in Hy
          | [ |- context[ident.cast r[0~>0] ?v] ]
            => rewrite (ident.platform_specific_cast_0_is_mod 0 v) by reflexivity
          | [ H : ?x = Z.ones _ |- context [Z.land _ ?x] ] => rewrite H
          | [ H : ?x = Z.ones _ |- context [Z.land ?x _] ] => rewrite H
          | [ |- context [Z.land (Z.ones ?n) ?x] ] =>
            lazymatch x with
            | Z.ones _ => fail
            | _ => rewrite (Z.land_comm (Z.ones n) x)
            end
          | [ |- context [Z.land ?x (Z.ones (Z.succ (Z.log2 _)))] ] =>
            rewrite (Z.land_ones_low x)
              by (repeat match goal with
                         | H : is_bounded_by_bool _ _ = true |- _ =>
                           apply unfold_is_bounded_by_bool in H;
                           cbn [upper lower] in H
                         end;
                  try apply Z.lt_succ_r;
                  eauto using Z.log2_le_mono with lia)
          end
        | progress intros
        | progress subst
        | assumption
        | progress destruct_head'_and
        | progress Z.ltb_to_lt
        | progress split_andb
        | match goal with
          | [ |- ?a mod ?b = ?a' mod ?b ] => apply f_equal2; lia
          | [ |- ?a / ?b = ?a' / ?b ] => apply f_equal2; lia
          | [ |- Z.opp _ = Z.opp _ ] => apply f_equal
          end
        | break_innermost_match_step
        | break_innermost_match_hyps_step
        | progress destruct_head'_or
        | match goal with
          | [ |- context[-ident.cast (-?r) (-?v)] ] => rewrite (ident.cast_opp' r v)
          | [ |- context[ident.cast ?r ?v] ]
            => is_var v;
               pose proof (@ident.cast_always_bounded r v);
               generalize dependent (ident.cast r v); clear v; intro v; intros
          | [ |- context[ident.cast ?r ?v] ]
            => is_var v;
               pose proof (@ident.cast_cases r v);
               generalize dependent (ident.cast r v); intros
          | [ H : is_bounded_by_bool ?v ?r = true, H' : is_tighter_than_bool ?r ?r' = true |- _ ]
            => unique assert (is_bounded_by_bool v r' = true) by (eauto 2 using ZRange.is_bounded_by_of_is_tighter_than)
          | [ H : is_bounded_by_bool (-?v) ?r = true, H' : (-?r <=? ?r')%zrange = true |- _ ]
            => unique assert (is_bounded_by_bool v r' = true)
              by (apply (@ZRange.is_bounded_by_of_is_tighter_than _ _ H');
                  rewrite <- ZRange.is_bounded_by_bool_opp, ZRange.opp_involutive; exact H)
          | [ H : is_bounded_by_bool ?v (-?r) = true |- _ ]
            => is_var v;
               unique assert (is_bounded_by_bool (-v) r = true)
                 by now rewrite <- ZRange.is_bounded_by_bool_move_opp_normalize, ZRange.normalize_opp
          | [ H : is_bounded_by_bool ?x r[0~>?v-1] = true |- _ ]
            => progress (try unique assert (0 <= x); try unique assert (x <= v - 1));
               [ clear -H; cbv [is_bounded_by_bool] in H; cbn [lower upper] in H; Bool.split_andb; Z.ltb_to_lt; lia..
               | ]
          end
        | match goal with
          | [ |- context[Z.shiftl] ] => rewrite Z.shiftl_mul_pow2 by auto with zarith
          | [ |- context[Z.shiftr] ] => rewrite Z.shiftr_div_pow2 by auto with zarith
          | [ |- context[Z.shiftl _ (-_)] ] => rewrite Z.shiftl_opp_r
          | [ |- context[Z.land _ (Z.ones _)] ] => rewrite Z.land_ones by auto using Z.log2_nonneg
          | [ |- context[- - _] ] => rewrite Z.opp_involutive
          | [ H : ?x = 2^Z.log2 ?x |- context[2^Z.log2 ?x] ] => rewrite <- H
          | [ H : ?x = 2^?n |- context[Z.land _ (?x - 1)] ]
            => rewrite !Z.sub_1_r, H, <- Z.ones_equiv, Z.land_ones by auto with zarith
          | [ |- _ = _ :> BinInt.Z ] => progress normalize_commutative_identifier Z.land Z.land_comm
          | [ H : ?x = ?y, H' : ?x <> ?y |- _ ] => exfalso; apply H', H
          | [ H : ?x = 2^Z.log2_up ?x - 1 |- context[2^Z.log2_up ?x - 1] ] => rewrite <- H
          | [ H : ?x = 2^Z.log2 ?x, H' : context[2^Z.log2 ?x] |- _ = _ :> BinInt.Z ]
            => rewrite <- H in H'
          | [ |- _ = _ :> BinInt.Z ] => progress autorewrite with zsimplify_const
          | [ H : 0 <= ?x, H' : ?x <= ?r - 1 |- context[?x mod ?r] ]
            => rewrite (Z.mod_small x r) by (clear -H H'; lia)
          | [ H : 0 <= ?x, H' : ?x <= ?y - 1 |- context[?x / ?y] ]
            => rewrite (Z.div_small x y) by (clear -H H'; lia)
          | [ H : ?x = 2^Z.log2 ?x |- _ ]
            => unique assert (0 <= x) by (rewrite H; auto with zarith)
          | [ |- _ mod ?x = _ mod ?x ]
            => progress (push_Zmod; pull_Zmod)
          | [ |- ?f (_ mod ?x) = ?f (_ mod ?x) ]
            => progress (push_Zmod; pull_Zmod)
          | [ |- _ mod ?x = _ mod ?x ]
            => apply f_equal2; (lia + nia)
          | _ => rewrite !Z.shiftl_mul_pow2 in * by auto using Z.log2_nonneg
          | _ => rewrite !Z.land_ones in * by auto using Z.log2_nonneg
          | H : ?x mod ?b * ?y <= _
            |- context [ (?x * ?y) mod ?b ] =>
            rewrite (PullPush.Z.mul_mod_l x y b);
            rewrite (Z.mod_small (x mod b * y) b) by lia
          | [ |- context[_ - ?x + ?x] ] => rewrite !Z.sub_add
          | [ |- context[_ mod (2^_) * 2^_] ] => rewrite <- !Z.mul_mod_distr_r_full
          | [ |- context[Z.land _ (Z.ones _)] ] => rewrite !Z.land_ones by lia
          | [ |- context[2^?a * 2^?b] ] => rewrite <- !Z.pow_add_r by lia
          | [ |- context[-?x + ?y] ] => rewrite !Z.add_opp_l
          | [ |- context[?n + - ?m] ] => rewrite !Z.add_opp_r
          | [ |- context[?n - - ?m] ] => rewrite !Z.sub_opp_r
          | [ |- context[Zpos ?p * ?x / Zpos ?p] ]
            => rewrite (@Z.div_mul' x (Zpos p)) in * by (clear; lia)
          | [ H : context[Zpos ?p * ?x / Zpos ?p] |- _ ]
            => rewrite (@Z.div_mul' x (Zpos p)) in * by (clear; lia)
          | [ |- ?f (?a mod ?r) = ?f (?b mod ?r) ] => apply f_equal; apply f_equal2; lia
          | [ |- context[-?a - ?b + ?c] ] => replace (-a - b + c) with (c - a - b) by (clear; lia)
          | [ |- context[?x - ?y + ?z] ]
            => lazymatch goal with
               | [ |- context[z - y + x] ]
                 => progress replace (z - y + x) with (x - y + z) by (clear; lia)
               end
          | [ |- context[?x - ?y - ?z] ]
            => lazymatch goal with
               | [ |- context[x - z - y] ]
                 => progress replace (x - z - y) with (x - y - z) by (clear; lia)
               end
          | [ |- context[?x + ?y] ]
            => lazymatch goal with
               | [ |- context[y + x] ]
                 => progress replace (y + x) with (x + y) by (clear; lia)
               end
          | [ |- context[?x + ?y + ?z] ]
            => lazymatch goal with
               | [ |- context[x + z + y] ]
                 => progress replace (x + z + y) with (x + y + z) by (clear; lia)
               | [ |- context[z + x + y] ]
                 => progress replace (z + x + y) with (x + y + z) by (clear; lia)
               | [ |- context[z + y + x] ]
                 => progress replace (z + y + x) with (x + y + z) by (clear; lia)
               | [ |- context[y + x + z] ]
                 => progress replace (y + x + z) with (x + y + z) by (clear; lia)
               | [ |- context[y + z + x] ]
                 => progress replace (y + z + x) with (x + y + z) by (clear; lia)
               end
          | [ |- - ident.cast (-?r) (- (?x / ?y)) = ident.cast ?r (?x' / ?y) ]
            => tryif constr_eq x x' then fail else replace x with x' by lia
          | [ |- _ = _ :> BinInt.Z ] => progress autorewrite with zsimplify_fast
          end
        | saturate_add_sub_bounds_step ].

Local Ltac remove_casts :=
  repeat match goal with
         | [ |- context[ident.cast r[?x~>?x] ?x] ]
           => rewrite (ident.cast_in_bounds r[x~>x] x) by apply ZRange.is_bounded_by_bool_constant
         | [ |- context[ident.cast ?r (ident.cast ?r _)] ]
           => rewrite ident.cast_idempotent
         | [ H : context[ident.cast ?r (ident.cast ?r _)] |- _ ]
           => rewrite ident.cast_idempotent in H
         | [ |- context[ident.cast ?r ?v] ]
           => is_var v;
              pose proof (@ident.cast_always_bounded r v);
              generalize dependent (ident.cast r v);
              clear v; intro v; intros
         | [ H : context[ident.cast ?r ?v] |- _ ]
           => is_var v;
              pose proof (@ident.cast_always_bounded r v);
              generalize dependent (ident.cast r v);
              clear v; intro v; intros
         | [ H : context[ZRange.constant ?v] |- _ ] => unique pose proof (ZRange.is_bounded_by_bool_normalize_constant v)
         | [ H : is_tighter_than_bool (?ZRf ?r1 ?r2) (ZRange.normalize ?rs) = true,
                 H1 : is_bounded_by_bool ?v1 ?r1 = true,
                      H2 : is_bounded_by_bool ?v2 ?r2 = true
             |- _ ]
           => let cst := multimatch goal with
                         | [ |- context[ident.cast rs (?Zf v1 v2)] ] => constr:(ident.cast rs (Zf v1 v2))
                         | [ H : context[ident.cast rs (?Zf v1 v2)] |- _ ] => constr:(ident.cast rs (Zf v1 v2))
                         end in
              lazymatch cst with
              | ident.cast rs (?Zf v1 v2)
                => let lem := lazymatch constr:((ZRf, Zf)%core) with
                              | (ZRange.shiftl, Z.shiftl)%core => constr:(@ZRange.is_bounded_by_bool_shiftl v1 r1 v2 r2 H1 H2)
                              | (ZRange.shiftr, Z.shiftr)%core => constr:(@ZRange.is_bounded_by_bool_shiftr v1 r1 v2 r2 H1 H2)
                              | (ZRange.land, Z.land)%core => constr:(@ZRange.is_bounded_by_bool_land v1 r1 v2 r2 H1 H2)
                              end in
                   try unique pose proof (@ZRange.is_bounded_by_of_is_tighter_than _ _ H _ lem);
                   clear H;
                   rewrite (@ident.cast_in_normalized_bounds rs (Zf v1 v2)) in * by assumption
              end
         | [ H : is_tighter_than_bool (?ZRf ?r1) (ZRange.normalize ?rs) = true,
                 H1 : is_bounded_by_bool ?v1 ?r1 = true
             |- _ ]
           => let cst := multimatch goal with
                         | [ |- context[ident.cast rs (?Zf v1)] ] => constr:(ident.cast rs (Zf v1))
                         | [ H : context[ident.cast rs (?Zf v1)] |- _ ] => constr:(ident.cast rs (Zf v1))
                         end in
              lazymatch cst with
              | ident.cast rs (?Zf v1)
                => let lem := lazymatch constr:((ZRf, Zf)%core) with
                              | (ZRange.cc_m ?s, Z.cc_m ?s)%core => constr:(@ZRange.is_bounded_by_bool_cc_m s v1 r1 H1)
                              end in
                   try unique pose proof (@ZRange.is_bounded_by_of_is_tighter_than _ _ H _ lem);
                   clear H;
                   rewrite (@ident.cast_in_normalized_bounds rs (Zf v1)) in * by assumption
              end
         | [ H : is_bounded_by_bool ?v (ZRange.normalize ?r) = true |- context[ident.cast ?r ?v] ]
           => rewrite (@ident.cast_in_normalized_bounds r v) in * by assumption
         | [ H : is_bounded_by_bool ?v (ZRange.normalize ?r) = true, H' : context[ident.cast ?r ?v] |- _ ]
           => rewrite (@ident.cast_in_normalized_bounds r v) in * by assumption
         | [ H : is_bounded_by_bool ?v ?r = true,
                 H' : is_tighter_than_bool ?r r[0~>?x-1]%zrange = true,
                      H'' : Z.eqb ?x ?m = true
             |- context[?v mod ?m] ]
           => unique assert (is_bounded_by_bool v r[0~>x-1] = true)
             by (eapply ZRange.is_bounded_by_of_is_tighter_than; eassumption)
         | _ => progress Z.ltb_to_lt
         | _ => progress subst
         end.

Local Ltac unfold_cast_lemmas :=
  repeat match goal with
         | [ H : context[ZRange.normalize (ZRange.constant _)] |- _ ]
           => rewrite ZRange.normalize_constant in H
         | [ H : is_bounded_by_bool _ (ZRange.normalize ?r) = true |- _ ]
           => is_var r; generalize dependent (ZRange.normalize r); clear r; intro r; intros
         | [ H : is_bounded_by_bool _ (ZRange.normalize r[0 ~> 2 ^ _ - 1]) = true |- _ ]
           => rewrite ZRange.normalize_id_pow2 in H by lia
         | [ H : is_bounded_by_bool ?x (ZRange.constant ?x) = true |- _ ]
           => clear H
         | [ H : is_bounded_by_bool ?x ?r = true |- _ ]
           => is_var r; apply unfold_is_bounded_by_bool in H
         | [ H : is_bounded_by_bool ?x r[_~>_] = true |- _ ]
           => apply unfold_is_bounded_by_bool in H
         | [ H : is_tighter_than_bool r[_~>_] r[_~>_] = true |- _ ]
           => apply unfold_is_tighter_than_bool in H
         | _ => progress cbn [lower upper] in *
         | [ H : context[lower ?r] |- _ ]
           => is_var r; let l := fresh "l" in let u := fresh "u" in destruct r as [l u]
         | [ H : context[upper ?r] |- _ ]
           => is_var r; let l := fresh "l" in let u := fresh "u" in destruct r as [l u]
         | _ => progress Z.ltb_to_lt
         end.

Local Ltac clear_useless_hyps :=
  repeat match goal with
         | [ H : True |- _ ] => clear H
         | [ H : unit |- _ ] => clear H
         | [ H : nat |- _ ] => clear H
         | [ H : Z |- _ ] => clear H
         | [ H : zrange |- _ ] => clear H
         | [ H : ?x = ?x |- _ ] => clear H
         | [ H : ?x <= ?y <= ?z |- _ ]
           => is_var x; is_var z; clear x z H
         | [ H : ?x <= ?x' /\ ?y' <= ?y, H' : ?x' <= ?z <= ?y' |- _ ]
           => is_var x'; is_var y';
              let H'' := fresh in
              assert (H'' : x <= z <= y) by (clear -H H'; lia);
              clear x' y' H H'
         end.

Local Ltac systematically_handle_casts :=
  remove_casts; unfold_cast_lemmas; clear_useless_hyps.

Local Ltac fin_with_nia :=
  lazymatch goal with
  | [ |- ident.cast ?r _ = ident.cast ?r _ ] => apply f_equal; Z.div_mod_to_quot_rem; nia
  | _ => reflexivity || (Z.div_mod_to_quot_rem; (lia + nia))
  end.

Local Ltac do_clear_nia x y r H H' :=
  let rec find_H x :=
      lazymatch goal with
      | [ H : _ <= x < _ |- _ ] => H
      | [ H : _ <= x <= _ |- _ ] => H
      | _ => lazymatch x with
             | ?x0 + ?x1
               => let H0 := find_H x0 in
                  let H1 := find_H x1 in
                  let m0 := lazymatch type of H0 with 0 <= _ <= ?m => m end in
                  let m1 := lazymatch type of H1 with 0 <= _ <= ?m => m end in
                  let H := fresh in
                  let __ := lazymatch goal with
                            | _ => assert (H : 0 <= x <= m0 + m1) by (clear -H0 H1; lia)
                            end in
                  H
             | ?x0 - ?x1
               => let H0 := find_H x0 in
                  let H1 := find_H x1 in
                  let m0 := lazymatch type of H0 with 0 <= _ <= ?m => m end in
                  let m1 := lazymatch type of H1 with 0 <= _ <= ?m => m end in
                  let H := fresh in
                  let __ := lazymatch goal with
                            | _ => assert (H : -m1 <= x <= m0) by (clear -H0 H1; lia)
                            end in
                  H
             end
      end in
  idtac;
  let Hx := find_H x in
  let Hy := find_H y in
  lazymatch goal with
  | [ Hm : 0 < 2^_ <= 2^_, Hr : 0 <= r < _ |- _ ]
    => clear -Hx Hy Hm Hr H' H; nia
  end.

Lemma arith_with_casts_rewrite_rules_proofs (adc_no_carry_to_add : bool)
  : PrimitiveHList.hlist (@snd bool Prop) (arith_with_casts_rewrite_rulesT adc_no_carry_to_add).
Proof using Type.
  start_proof; auto; intros; try lia.
  all: repeat interp_good_t_step_related.
  all: repeat interp_good_t_step_arith.
  all: remove_casts; try fin_with_nia.
Qed.

Lemma strip_literal_casts_rewrite_rules_proofs
  : PrimitiveHList.hlist (@snd bool Prop) strip_literal_casts_rewrite_rulesT.
Proof using Type.
  start_proof; auto; intros; remove_casts; reflexivity.
Qed.

Lemma add_assoc_left_rewrite_rules_proofs
  : PrimitiveHList.hlist (@snd bool Prop) add_assoc_left_rewrite_rulesT.
Proof using Type. start_proof; intros; lia. Qed.

Lemma flatten_thunked_rects_rewrite_rules_proofs
  : PrimitiveHList.hlist (@snd bool Prop) flatten_thunked_rects_rewrite_rulesT.
Proof using Type. start_proof; intros; reflexivity. Qed.

Section fancy.
  Context (invert_low invert_high : Z (*log2wordmax*) -> Z -> option Z)
          (value_range flag_range : zrange).

  Lemma fancy_rewrite_rules_proofs
    : PrimitiveHList.hlist (@snd bool Prop) fancy_rewrite_rulesT.
  Proof using Type. start_proof. Qed.

  Local Ltac fancy_local_t :=
    repeat match goal with
           | [ H : forall s v v', ?invert_low s v = Some v' -> v = _,
                 H' : ?invert_low _ _ = Some _ |- _ ] => apply H in H'
           | [ H : forall s v v', ?invert_low s v = Some v' -> v = _ |- _ ]
             => clear invert_low H
           | [ H : None <> None |- _ ] => exfalso; exact (H eq_refl)
           end.
  Local Ltac more_fancy_arith_t := repeat autorewrite with zsimplify in *.

  Lemma fancy_with_casts_rewrite_rules_proofs
        (Hlow : forall s v v', invert_low s v = Some v' -> v = Z.land v' (2^(s/2)-1))
        (Hhigh : forall s v v', invert_high s v = Some v' -> v = Z.shiftr v' (s/2))
    : PrimitiveHList.hlist (@snd bool Prop) (@fancy_with_casts_rewrite_rulesT invert_low invert_high value_range flag_range).
  Proof using Type.
    start_proof; auto; intros; try lia.
    Time all: repeat interp_good_t_step_related.
    Time all: fancy_local_t.
    Time all: try solve [ systematically_handle_casts; repeat interp_good_t_step_arith ].
  Qed.
End fancy.

Local Ltac cast_to_arith r v :=
  match goal with
  | [ |- context[ident.cast r v] ]
    => let H := fresh in
       eassert (H : _);
       [ | rewrite (ident.cast_in_bounds r v) by exact H ]
  end;
  repeat
    first [ match goal with
            | [ |- context[andb _ _ = true] ] => rewrite Bool.andb_true_iff
            | [ |- and _ _ ] => split
            end
          | progress unfold is_bounded_by_bool in *
          | progress cbn [lower upper] in *
          | progress Bool.split_andb
          | progress Z.ltb_to_lt ].

Lemma to_double_bounds xl xh bitwidth :
  0 <= xl <= 2 ^ bitwidth - 1 ->
  0 <= xh <= 2 ^ bitwidth - 1 ->
  xl + xh * 2 ^ bitwidth <= 2 ^ bitwidth * 2 ^ bitwidth - 1.
Proof. nia. Qed.

Local Ltac pose_mod_bounds :=
  repeat match goal with
         | |- context [?a mod ?b] =>
           unique pose proof (Z.mod_pos_bound a b ltac:(auto with zarith))
         end.

Local Ltac pose_shiftr_bounds :=
  repeat match goal with
         | |- context [?a >> ?b] =>
           unique pose proof
                  (Z.shiftr_nonneg_le
                     a b ltac:(auto with zarith) ltac:(auto with zarith));
           unique pose proof (proj2 (Z.shiftr_nonneg a b) ltac:(auto with zarith))
         end.

Local Ltac bounds_arith_hammer :=
  try match goal with
      | [ H0 : 0 < ?z, H : 0 <= ?x <= ?z - 1, H' : 0 <= ?y <= ?z - 1 |- ?x * ?y / ?z <= ?z - 1 ]
        => clear -H H' H0 (* fast path so we don't time out on 8.9 *)
      end;
  repeat match goal with
         | _ => progress pose_mod_bounds
         | _ => progress pose_shiftr_bounds
         | |- _ / _ <= _ - 1 =>
           apply Le.Z.le_sub_1_iff;
           apply Z.div_lt_upper_bound; solve [auto with zarith nia]
         | _ => apply to_double_bounds; lia
         | _ => solve [Z.zero_bounds]
         | _ => lia
         end.

(* TODO: can this be replaced by just adding Z.shiftr_range to zarith? *)
Local Ltac use_shiftr_range :=
  try split; Z.zero_bounds; apply Z.shiftr_range;
  autorewrite with zsimplify; auto with zarith.

Lemma mul_split_rewrite_rules_proofs (bitwidth : Z) (lgcarrymax : Z)
  : PrimitiveHList.hlist (@snd bool Prop) (mul_split_rewrite_rulesT bitwidth lgcarrymax).
Proof using Type.
  start_proof; auto; intros; try lia.
  (* assert bounds to help out [lia] *)
  all: try (assert (0 < 2 ^ bitwidth) by Z.zero_bounds;
            assert (0 < 2 ^ bitwidth * 2 ^ bitwidth) by Z.zero_bounds;
            assert ((2 ^ bitwidth - 1) * (2 ^ bitwidth - 1) <= 2 ^ bitwidth * 2 ^ bitwidth - 1) as Hle_double
                by (autorewrite with push_Zmul zsimplify; lia)).
  all: try (assert (2 <= 2 ^ lgcarrymax) by auto with zarith).
  all: try (assert (0 <= bitwidth) by (apply Z.nonneg_pow_pos with (a:=2); lia)).
  all: try (assert (bitwidth < 2 ^ bitwidth) by (apply Z.pow_gt_lin_r; lia)).
  all: repeat interp_good_t_step_related.
  all: systematically_handle_casts.
  all: try reflexivity.
  all:unfold Z.combine_at_bitwidth.
  all:rewrite ?Z.shiftl_mul_pow2, ?Z.shiftr_div_pow2, ?Z.pow_twice_r in * by lia.

  (* special case to match on a particular rule that is way easier to prove this
     way; this is hacky and should ideally be removed eventually *)
  all: try match goal with
           | |- ident.cast r[0 ~> 2 ^ ?b * 2 ^ ?b - 1] (_ >> _) = _ =>
             f_equal
           end.

  (* remove whatever bounds [bounds_arith_hammer] solves *)
  all:repeat match goal with
             | [ |- context[ident.cast ?r ?v] ]
               => cast_to_arith r v; [ solve [bounds_arith_hammer] .. | ]
             end.

  (* change the rest of the casts to mods *)
  all:rewrite ?ident.platform_specific_cast_0_is_mod by lia;
    autorewrite with zsimplify_fast; Z.rewrite_mod_small.

  all:
    repeat match goal with
           | |- context [(_ * _) mod _] =>
             (* multiplication case *)
             rewrite Z.mul_div_eq' by lia; lia
           | |- ((_ + _) * ?y) mod _ = _ =>
             (* double * single multiplication case *)
             rewrite Z.mul_add_distr_r, <- Z.mul_assoc, (Z.mul_comm (2^_) y), Z.mul_assoc
           | |- (?x * (_ + _)) mod _ = _ =>
             (* single * double multiplication case *)
             rewrite Z.mul_add_distr_l, Z.mul_assoc
           | |- (_ + _) mod (_ * _) = _ =>
             (* addition cases *)
             rewrite !Z.rem_mul_r by lia;
               push_Zmod; pull_Zmod; autorewrite with zsimplify;
                 solve [repeat (ring_simplify; f_equal; try lia)]
           | |- (?m &' (_ + _)) mod _ = _ =>
             (* and-addition case *)
             rewrite !(Z.land_comm m)
           | |- ((_ + _) &' _) mod _ = _ =>
             (* addition-and case *)
             rewrite Z.land_add_high by (try apply Z.log2_lt_pow2; lia); lia
           | |- (_ + _) >> _ mod _ = _ =>
             (* take only high bits *)
             rewrite ?Z.shiftr_div_pow2 by lia; autorewrite with zsimplify; lia
           | |- (_ + _) / _ = _ =>
             (* take only high bits *)
             autorewrite with zsimplify; lia
           end.

  (* should have only Z.lor cases now *)
  all:rewrite <-?Z.pow_twice_r,<-?Z.land_ones, <-?Z.shiftl_mul_pow2 in * by lia.
  all:match goal with
      | |- context [Z.lor (?a >> ?b) (_ &' Z.ones ?c)] =>
        rewrite <-(Z.mod_small (a >> b) (2 ^ c)) by auto with zarith;
          rewrite <-Z.land_ones, <-Z.land_lor_distr_l by auto with zarith
      end.
  all:rewrite Z.lor_shiftl by use_shiftr_range.
  all:rewrite Z.shiftr_add_shiftl_low by lia.
  all:match goal with
      | H : ?x < ?y |- context [Z.shiftr ?a (?x - ?y)] =>
        replace (Z.shiftr a (x - y)) with (Z.shiftl a (y - x))
          by (rewrite <-Z.shiftl_opp_r; f_equal; lia)
      end.
  all:try reflexivity.

  all:rewrite ?Z.land_ones, Z.mod_eq by auto with zarith.
  all:rewrite ?(Z.mul_comm (2 ^ _)), <-?Z.shiftl_mul_pow2, <-?Z.shiftr_div_pow2 by auto with zarith.
  all:rewrite Z.shiftr_add_shiftl_high by use_shiftr_range.
  all:autorewrite with zsimplify; lia.
Qed.

Lemma multiret_split_rewrite_rules_proofs (bitwidth : Z) (lgcarrymax : Z)
  : PrimitiveHList.hlist (@snd bool Prop) (multiret_split_rewrite_rulesT bitwidth lgcarrymax).
Proof using Type.
  assert (0 <= lgcarrymax <= bitwidth -> 0 < 2^lgcarrymax <= 2^bitwidth) by auto with zarith.
  assert (0 <= bitwidth -> bitwidth < 2^bitwidth)
    by (intros; apply Z.pow_gt_lin_r; auto with zarith).

  start_proof; auto; intros; try lia.
  all: repeat interp_good_t_step_related.
  all: systematically_handle_casts; autorewrite with zsimplify_fast; try reflexivity.
  all: rewrite !ident.platform_specific_cast_0_is_mod, ?Z.sub_add, ?Z.mod_mod by lia; try reflexivity.
  all: progress specialize_by lia.
  all: try match goal with
           | H : ?x = 2 ^ Z.log2 ?x |- _ =>
             rewrite H
           end.
  all:
    try match goal with
        | |- context [(2^?n - 1) mod 2^?bw] =>
          assert (0 < 2^n < 2^bw) by auto with zarith;
            Z.rewrite_mod_small
        end.
  all: rewrite ?Z.land_pow2 by auto with zarith.
  all: push_Zmod; pull_Zmod; try reflexivity.
  all: Z.rewrite_mod_small.
  all: rewrite ?Z.shiftr_div_pow2, ?Z.shiftl_mul_pow2 by lia.
  all: rewrite ?Z.log2_pow2 by lia.
  all: Z.rewrite_mod_small.
  all: rewrite ?Z.shiftr_div_pow2, ?Z.shiftl_mul_pow2 by lia.
  all: rewrite ?Z.mod_pow_same_base_larger,
       ?Z.mod_pow_same_base_smaller by lia.
  all: rewrite ?Z.ltz_mod_pow2_small by lia.
  all: rewrite <-?Z.add_div_ltz_1 by lia.
  all: try reflexivity.
  all: push_Zmod; pull_Zmod; try reflexivity.
  all: rewrite ?Z.mod_pull_div, <-?Z.pow_add_r by auto with zarith.
  all: rewrite <-?Z.sub_sub_div_ltz by lia.
  all: rewrite <-?Z.sub_div_ltz by lia.
  all: try rewrite Z.mul_opp_l, Z.sub_opp_l, Opp.Z.opp_sub.
  all:
    repeat match goal with
           | Hx : 0 <= ?x <= 2^?n - 1,
                  Hy : 0 <= ?y <= 2^?n - 1 |- context [?x + ?y] =>
             unique assert (0 <= x + y < 2^(n+1))
               by (rewrite Z.pow_add_r, Z.pow_1_r; auto with zarith)
           | Hx : 0 <= ?x <= 2^?n - 1,
                  Hy : 0 <= ?y <= 2^?n - 1 |- context [?c + ?x + ?y] =>
             unique assert (0 <= c + x + y < 2^(n+2))
               by (rewrite Z.pow_add_r, Z.pow_2_r; auto with zarith)
           | H : 0 < ?n |- _ =>
             unique assert (2^(bitwidth+1) <= 2^(bitwidth+n))
               by auto with zarith
           | H : 0 <= ?x < 2 ^ ?z |- context [?x mod 2 ^ ?y] =>
             unique assert (2 ^ z <= 2 ^ y) by auto with zarith;
               unique assert (0 <= x <= 2 ^ y) by auto with zarith
           | _ => rewrite Z.ltz_mod_pow2_small by lia
           | _ => rewrite Z.add_div_pow2 by auto with zarith
           | _ => rewrite <-Z.add_add_div_ltz_2 by lia
           | _ => rewrite Z.mod_pull_div, <-?Z.pow_add_r
               by auto with zarith
           | _ => progress Z.rewrite_mod_small
           end.
  all: try solve[
  try lazymatch goal with
       | [ |- ?x mod ?y = _ mod ?y ]
         => apply f_equal2; [ | reflexivity ];
              cbv [Z.ltz]; break_innermost_match; Z.ltb_to_lt
       end; Z.div_mod_to_quot_rem;
   repeat match goal with
              | [ H : ?x + ?y = ?d * ?q + ?r, H' : ?r < ?y |- _ ]
                => is_var q; unique assert (q = 1) by do_clear_nia x y r H H'; subst
              | [ H : ?x + ?y = ?d * ?q + ?r, H' : ?r >= ?y |- _ ]
                => is_var q; unique assert (q = 0) by do_clear_nia x y r H H'; subst
              | [ H : ?x - ?y = ?d * ?q + ?r, H' : ?x < ?r |- _ ]
                => is_var q; unique assert (q = -1) by do_clear_nia x y r H H'; subst
              | [ H : ?x - ?y = ?d * ?q + ?r, H' : ?x >= ?r |- _ ]
                => is_var q; unique assert (q = 0) by do_clear_nia x y r H H'; subst
              | [ H0 : ?x = ?d * ?q0 + ?r0, H : ?x - ?y = ?d * ?q + ?r, H' : ?r0 < ?r |- _ ]
                => (* ugh, this is kind-of complicated; we could just let [nia] handle it, but it runs out of memory on 8.9 *)
                let x' := fresh "x" in
                (remember x as x' eqn:?);
                  symmetry in H0; destruct H0;
                    assert (r0 - y = d * (q - q0) + r) by (clear -H; nia); clear H;
                      let q' := fresh "q" in
                      remember (q - q0) as q' eqn:?; (tryif is_var q then Z.linear_substitute q else idtac)
              | _ => nia
          end].
Qed.

Lemma noselect_rewrite_rules_proofs (bitwidth : Z)
  : PrimitiveHList.hlist (@snd bool Prop) (noselect_rewrite_rulesT bitwidth).
Proof.
  assert (0 <= bitwidth -> 0 < 2^bitwidth) by auto with zarith.
  start_proof; auto; intros; try lia.
  all: repeat interp_good_t_step_related.
  all: systematically_handle_casts; try reflexivity.
  all: specialize_by auto.
  all: rewrite !ident.platform_specific_cast_0_is_mod by lia.
  all: rewrite ?Z.sub_simpl_r by auto.
  all: autorewrite with zsimplify_fast.
  Time
  all: repeat match goal with
              | _ => progress rewrite ?Z.lxor_0_l, ?Z.lxor_0_r
              | _ => progress rewrite ?Z.lor_0_l, ?Z.lor_0_r
              | _ => progress rewrite ?Z.land_0_l, ?Z.land_0_r
              | _ => rewrite Z.lxor_nilpotent
              | _ => rewrite Z.land_pow2 by auto with zarith
              | _ => progress Z.rewrite_mod_small
              | _ => progress (push_Zmod; pull_Zmod)
              | _ => reflexivity
              end.
Qed.


Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.GlobalSettings.
Require Import Crypto.Util.Notations.

Definition compose {A B} {C : B -> Type} (g : forall b : B, C b) (f : A -> B) (x : A)
  := g (f x).
Global Arguments compose {A B C} g f x / .

Infix "'o'" := compose : function_scope.
Infix "∘" := compose : function_scope.

#[global]
Typeclasses Opaque compose.

Global Instance Proper_compose {A B C}
      {RA RB RC}
  : Proper ((RB ==> RC) ==> (RA ==> RB) ==> RA ==> RC) (@compose A B (fun _ => C)).
Proof. cbv in *; eauto. Qed.

Global Instance Proper_compose_app {A B C} (g : B -> C) (f : A -> B)
      {RA RB RC}
      {Hg : Proper (RB ==> RC) g}
      {Hf : Proper (RA ==> RB) f}
  : Proper (RA ==> RC) (g ∘ f).
Proof. cbv in *; eauto. Qed.

Ltac Proper_compose_hint :=
  lazymatch goal with
  | [ |- Proper _ (fun x => ?g (?f x)) ]
    => simple eapply (@Proper_compose_app _ _ _ g f)
  end.

(*Global Hint Extern 2 (Proper _ (fun x => ?g (?f x))) => simple eapply (@Proper_compose_app _ _ _ g f) : typeclass_instances.*)


(** * Functors between an exponential of a product and a product of exponentials *)
Require Import Category.Core Functor.Core FunctorCategory.Core Category.Prod.
Require Import Functor.Prod Functor.Composition.Core NaturalTransformation.Composition.Laws NaturalTransformation.Composition.Core.
Require Import Types.Prod.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope natural_transformation_scope.
Local Open Scope functor_scope.

Local Notation fst_type := Basics.Datatypes.fst.
Local Notation snd_type := Basics.Datatypes.snd.
Local Notation pair_type := Basics.Datatypes.pair.

Section law3.
  Context `{Funext}.
  Variables C1 C2 D : PreCategory.

  (** ** [(y × z)ⁿ → yⁿ × zⁿ] *)
  Definition functor
  : Functor (D -> C1 * C2) ((D -> C1) * (D -> C2))
    := Build_Functor
         (D -> C1 * C2) ((D -> C1) * (D -> C2))
         (fun H => (fst o H, snd o H)%core)
         (fun s d m => (fst oL m, snd oL m)%core)
         (fun _ _ _ _ _ => path_prod' (composition_of_whisker_l _ _ _)
                                      (composition_of_whisker_l _ _ _))
         (fun _ => path_prod' (whisker_l_right_identity _ _)
                              (whisker_l_right_identity _ _)).

  (** ** [yⁿ × zⁿ → (y × z)ⁿ] *)
  (** If we had [Require Functor.Functor.], we could just say [Functor.Prod.functor] here. *)
  Definition inverse
  : Functor ((D -> C1) * (D -> C2)) (D -> C1 * C2)
    := Functor.Prod.Functorial.functor _ _ _.
End law3.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                          notacc_white_nogrey.v                           *)
(****************************************************************************)

Section notacc_white_nogrey.

Require Export parameters_card.
Require Export lemma_step.
Require Export notfree_notacc.

Notation Step := (step (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Stream := (stream state) (only parsing).
Notation Stream_formula := (stream_formula state) (only parsing).
Notation Trace := (trace (fun (a : label) (s t : state) => transition s t a))
  (only parsing).

Definition notacc_white_nogrey (s : state) (n : node) : Prop :=
  ~ accessible node (hp s) rt n /\ mk s n = white /\ card_color grey (mk s) 0.

Definition notacc_white_nogrey_or_free (s : state)
  (n : node) : Prop :=
  ~ accessible node (hp s) rt n /\ mk s n = white /\ card_color grey (mk s) 0 \/
  mk s n = free.

Lemma add_idem_or_free :
 forall (s t : state) (n : node),
 nogrey_accn_imp_blackn s ->
 notacc_white_nogrey s n -> add_edge s t -> notacc_white_nogrey_or_free t n.

intros s t n inv H addedge; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_grey; left.
split; eauto.
split; eauto.
constructor; inversion H_grey; eauto.
Qed.

Hint Resolve add_idem_or_free.

Lemma remove_idem_or_free :
 forall (s t : state) (n : node),
 nogrey_accn_imp_blackn s ->
 notacc_white_nogrey s n ->
 remove_edge s t -> notacc_white_nogrey_or_free t n.

intros s t n inv H removeedge; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_grey; left.
split; eauto.
split; eauto.
constructor; inversion H_grey; eauto.
Qed.

Hint Resolve remove_idem_or_free.

Lemma alloc_idem_or_free :
 forall (s t : state) (n : node),
 nogrey_accn_imp_blackn s ->
 notacc_white_nogrey s n -> alloc s t -> notacc_white_nogrey_or_free t n.

intros s t n inv H addedge; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_grey; left.
split.
apply (alloc_notacces_t s t n);
 [ split; [ rewrite mksn; discriminate | assumption ] | assumption ].
split; eauto.
constructor; inversion H_grey; eauto.
Qed.

Hint Resolve alloc_idem_or_free.

Lemma gccall_idem_or_free :
 forall (s t : state) (n : node),
 notacc_white_nogrey s n -> gc_call s t -> notacc_white_nogrey_or_free t n.

intros s t n H gccall; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_card; elim gccall; clear gccall.
intros ctls ctlt heap H_col H_init; absurd (mk s n = white); auto.
elim (H_col n); intro mksn2; rewrite mksn2; discriminate.
intros ctls ctlt heap H_grey; elim H_grey; clear H_grey.
intros g mksg mktg mark1 mark2; inversion H_card; absurd (mk s g = grey);
 auto.
intros ctls ctlt heap H_col m mksm upd_col; elim upd_col; clear upd_col.
intros mark mktm; elim (eq_dec_node n m).
intro neqm; right; rewrite neqm; assumption.
intro ndifm; left; split;
 [ rewrite <- heap; assumption
 | split; [ rewrite <- (mark n ndifm); assumption | constructor; intro n' ] ].
elim (eq_dec_node n' m).
intro n'eqm; intro mktn'; absurd (mk t n' = grey); auto.
rewrite n'eqm; rewrite mktm; discriminate.
intro n'difm; rewrite <- (mark n' n'difm); auto.
Qed.

Hint Resolve gccall_idem_or_free.

Lemma mark_idem_or_free :
 forall (s t : state) (n : node),
 notacc_white_nogrey s n -> mark_node s t -> notacc_white_nogrey_or_free t n.

intros s t n H marknode; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_card; elim marknode; clear marknode.
intros ctls ctlt heap H_grey; elim H_grey; clear H_grey.
intros g mksg mktg mark1 mark2; inversion H_card; absurd (mk s g = grey);
 auto.
Qed.

Hint Resolve mark_idem_or_free.

Lemma gcstop_idem_or_free :
 forall (s t : state) (n : node),
 notacc_white_nogrey s n -> gc_stop s t -> notacc_white_nogrey_or_free t n.

intros s t n H gcstop; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_grey; left.
split; eauto.
split; eauto.
constructor; inversion H_grey; eauto.
Qed.

Hint Resolve gcstop_idem_or_free.

Lemma gcfree_idem_or_free :
 forall (s t : state) (n : node),
 notacc_white_nogrey s n -> gc_free s t -> notacc_white_nogrey_or_free t n.

intros s t n H gcfree; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_card; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm upd_col; elim upd_col; clear upd_col.
intros mark mktm; elim (eq_dec_node n m).
intro neqm; right; rewrite neqm; assumption.
intro ndifm; left; split;
 [ rewrite heap; assumption
 | split; [ rewrite <- (mark n ndifm); assumption | constructor; intro n' ] ].
elim (eq_dec_node n' m).
intro n'eqm; intro mktn'; absurd (mk t n' = grey); auto.
rewrite n'eqm; rewrite mktm; discriminate.
intro n'difm; rewrite <- (mark n' n'difm); auto.
Qed.

Hint Resolve gcfree_idem_or_free.

Lemma gcfree1_idem_or_free :
 forall (s t : state) (n : node),
 sweep_no_greys s ->
 notacc_white_nogrey s n -> gc_free1 s t -> notacc_white_nogrey_or_free t n.

unfold sweep_no_greys in |- *; intros s t n H_sweep H gcfree; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_card; elim gcfree; clear gcfree.
intros ctls ctlt heap m mksm upd_col; elim upd_col; clear upd_col.
intros mark mktm; elim (eq_dec_node n m).
intro neqm; right; rewrite neqm; assumption.
intro ndifm; left; split;
 [ rewrite <- heap; assumption
 | split; [ rewrite <- (mark n ndifm); assumption | constructor; intro n' ] ].
elim (eq_dec_node n' m).
intro n'eqm; intro mktn'; absurd (mk t n' = grey); auto.
rewrite n'eqm; rewrite mktm; discriminate.
intro n'difm; rewrite <- (mark n' n'difm).
apply H_sweep; assumption.
Qed.

Hint Resolve gcfree1_idem_or_free.

Lemma gcend_idem_or_free :
 forall (s t : state) (n : node),
 notacc_white_nogrey s n -> gc_end s t -> notacc_white_nogrey_or_free t n.

intros s t n H gcend; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H_grey; left.
split; eauto.
split; eauto.
constructor; inversion H_grey; eauto.
Qed.

Hint Resolve gcend_idem_or_free.

Lemma step_idem_or_free :
 forall (s t : state) (n : node),
 nogrey_accn_imp_blackn s ->
 sweep_no_greys s ->
 notacc_white_nogrey s n ->
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 notacc_white_nogrey_or_free t n.

intros s t n H_inv H_sweep H_n step; elim step; intro a; case a; intro trans;
 inversion_clear trans; eauto.
Qed.

Hint Resolve step_idem_or_free.

Definition notacc_white_nogrey_formula (n : node) :
  stream_formula state :=
  state2stream_formula
    (fun s : state =>
     ~ accessible node (hp s) rt n /\
     mk s n = white /\ card_color grey (mk s) 0).

Lemma until_idem_or_free :
 forall (n : node) (str : stream state),
 trace (fun (a : label) (s t : state) => transition s t a) str ->
 Eventually
   (state2stream_formula (fun s : state => card_color white (mk s) 0)) str ->
 always (state2stream_formula (fun s : state => sweep_no_greys s)) str ->
 always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
   str ->
 notacc_white_nogrey_formula n str ->
 until (fun str => notacc_white_nogrey_formula n str)
   (state2stream_formula (fun s : state => mk s n = free)) str.

intros n str H_trace H_ev H_always_sweep H_always_inv H_n.
generalize H_trace H_always_sweep H_always_inv H_n.
elim H_ev; clear H_n H_ev H_trace H_always_sweep H_always_inv str.
unfold notacc_white_nogrey_formula in |- *;
 unfold state2stream_formula in |- *; simpl in |- *.
intros str H_card H_trace H_always_sweep H_always_inv H_n.
elim H_n; clear H_n.
intros notacc_n_hd H; elim H; clear H.
intros mkhdn H_grey; inversion H_card; absurd (mk (head_str str) n = white);
 auto.
unfold notacc_white_nogrey_formula in |- *;
 unfold state2stream_formula in |- *; simpl in |- *.
intros s str H_ev H_ind H_trace H_always_sweep H_always_inv H_n;
 elim (eq_dec_color (mk s n) free); intro mksn.
constructor 1; auto.
constructor 2; auto.
inversion H_trace; inversion H_always_inv; inversion H_always_sweep.
simpl in H1; inversion H1.
apply H_ind; try assumption.
rewrite <- H11; assumption.
cut (notacc_white_nogrey_or_free (head_str str) n).
unfold notacc_white_nogrey_or_free in |- *;
 unfold state2stream_formula in |- *; simpl in |- *;
 intro h; elim h; clear h.
intro; apply H_ind; auto.
intro H_n_free; constructor 1; auto.
apply step_idem_or_free with (s := s); auto.
Qed.

Hint Resolve until_idem_or_free.

Lemma white_notacc_nogrey_until_eventually_free :
 forall (n : node) (str : stream state),
 trace (fun (a : label) (s t : state) => transition s t a) str ->
 Eventually
   (state2stream_formula (fun s : state => card_color white (mk s) 0)) str ->
 always (state2stream_formula (fun s : state => sweep_no_greys s)) str ->
 always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
   str ->
 notacc_white_nogrey_formula n str ->
 Eventually (state2stream_formula (fun s : state => mk s n = free)) str.

intros n str H_trace H_always_ev H_always_sweep H_always_inv H_n.
cut
 (until (fun str => notacc_white_nogrey_formula n str)
    (state2stream_formula (fun s : state => mk s n = free)) str);
 eauto.
intro H_until; elim H_until;
 clear H_n H_always_inv H_always_sweep H_trace H_always_ev H_until.
intros str' H_n; constructor 1; assumption.
intros s str' H_until H_ev.
constructor 2; assumption.
Qed.

Hint Resolve white_notacc_nogrey_until_eventually_free.

End notacc_white_nogrey.

Hint Resolve white_notacc_nogrey_until_eventually_free.