(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* RndNat -- a computation that returns a random nat uniformly distributed in a specified range. *)

Set Implicit Arguments.

Require Import FCF.Crypto.
Require Import Permutation.
Require Import FCF.NotationV1.

Definition RndNat_unchecked(n : nat) :=
  v <-$ {0,1} ^ (lognat n);
  let n := (bvToNat v) in
    ret n.

Definition ltNatBool := fun x1 x2 => if (lt_dec x1 x2) then true else false.

(* RndNat uses Repeat to get a number strictly less than n *)
Definition RndNat(n : nat) :=
    (Repeat (RndNat_unchecked n) (fun x => (ltNatBool x n))).

Notation "[ 0 '..' n )" := (RndNat n)
  (right associativity, at level 77) : comp_scope.

Lemma well_formed_RndNat : forall n,
  n > O ->
  well_formed_comp (RndNat n).

  intuition.
  unfold RndNat.
  eapply (well_formed_Repeat).
  unfold eq_dec.
  intuition idtac.
  eapply eq_nat_dec.
  unfold RndNat_unchecked.
  eapply well_formed_Bind.
  eapply well_formed_Rnd.
  intuition.
  eapply well_formed_Ret.
  eapply filter_In.
  intuition.
  2:{
    unfold ltNatBool.
    assert ((if (lt_dec O n) then true else false) = true).
    destruct (lt_dec O n).
    trivial.
    lia.
    eapply H0.
  }
  simpl.
  eapply Fold.in_getUnique.
  eapply Fold.in_flatten.
  econstructor.
  split.

  eapply in_map_iff.
  econstructor.
  split.
  eauto.

  eapply in_getAllBvectors.

  specialize (bvNat_zero (lognat n)); intuition.
  simpl in *.
  left.
  eapply H0.

Qed.

Lemma RndNat_support_lt : forall n x,
  In x (getSupport (RndNat n)) ->
  x < n.

  intuition.
  unfold RndNat in *.
  simpl in *.
  eapply filter_In in H.
  intuition.
  unfold ltNatBool in *.
  destruct (lt_dec x n); congruence.
Qed.

#[export] Hint Resolve well_formed_RndNat : wftac.

Lemma RndNat_unchecked_lt_support : forall n v,
  v < n ->
  In v (getSupport (RndNat_unchecked n)).

  intuition.
  unfold RndNat_unchecked.

  eapply getSupport_In_Seq.
  eapply in_getAllBvectors.
  simpl.
  left.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  lia.

Qed.

Local Open Scope rat_scope.

Lemma RndNat_uniform : forall v1 v2 n,
  v1 < n ->
  v2 < n ->
  evalDist (RndNat n) v1 == evalDist (RndNat n) v2.

  intuition.

  eapply evalDist_Repeat_eq; intuition.
  unfold RndNat_unchecked.
  remember (lognat n) as length.
  eapply (evalDist_iso
    (BVxor length (BVxor length (natToBv length v1) (natToBv length v2)))
    (BVxor length (BVxor length (natToBv length v1) (natToBv length v2)))); intuition.

(*
  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
*)

  remember (BVxor length (natToBv length v1) (natToBv length v2)) as z.
  rewrite <- BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  trivial.

  rewrite <- BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  trivial.

  simpl.
  eapply in_getAllBvectors.

  eapply uniformity.

  simpl.
  destruct (EqDec_dec nat_EqDec (bvToNat x) v2); subst.
  destruct (EqDec_dec nat_EqDec
    (bvToNat
      (BVxor (lognat n)
        (BVxor (lognat n) (natToBv (lognat n) v1)
          (natToBv (lognat n) (bvToNat x))) x)) v1).
  intuition.
  exfalso.
  eapply n0.

  rewrite natToBv_bvToNat_inverse.

  rewrite BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_r.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  lia.

  destruct (EqDec_dec nat_EqDec
    (bvToNat
      (BVxor (lognat n)
        (BVxor (lognat n) (natToBv (lognat n) v1)
          (natToBv (lognat n) v2)) x)) v1).
  exfalso.
  eapply n0.
  rewrite BVxor_assoc in e.
  assert ((BVxor (lognat n) (natToBv (lognat n) v2) x) = (Bvect_false (lognat n))).
  eapply BVxor_id_r_inv.
  eapply bvToNat_natToBv_eq.
  eauto.
  apply BVxor_id_inv in H2.
  rewrite <- H2.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  lia.

  intuition.

  unfold ltNatBool.
  destruct (lt_dec v1 n); destruct (lt_dec v2 n); congruence.

  eapply filter_In; intuition.
  eapply RndNat_unchecked_lt_support.
  trivial.
  unfold ltNatBool.
  destruct (lt_dec v1 n); congruence.
Qed.

Lemma in_getSupport_RndNat : forall x k,
  x < k ->
  In x (getSupport (RndNat k)).

  intuition.
  simpl.
  eapply filter_In.
  split.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eapply in_getAllBvectors.
  simpl.
  left.
  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  trivial.
  unfold ltNatBool.
  destruct (lt_dec x k); intuition.
Qed.

Lemma RndNat_support_length :
  forall n,
    length (getSupport (RndNat n)) = n.

  intuition.
  rewrite (@Permutation_length _ _ (forNats n)).
  eapply forNats_length.
  eapply NoDup_Permutation.
  eapply getSupport_NoDup.
  eapply forNats_NoDup.
  intuition.

  eapply forNats_In.
  eapply RndNat_support_lt; intuition.

  eapply in_getSupport_RndNat.
  eapply forNats_In; intuition.

Qed.

Theorem RndNat_prob :
  forall n i (nzn : nz n),
    i < n ->
    evalDist (RndNat n) i == 1 / n.

  intuition.

  eapply (@ratMult_same_r_inv _ (n / 1)).
  rewrite ratMult_eq_rat1.
  eapply eqRat_trans.
  2:{
    eapply evalDist_lossless.
    eapply well_formed_RndNat.
    destruct nzn.
    apply agz.
  }

  symmetry.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  eapply (@RndNat_uniform _ i).
  eapply RndNat_support_lt; intuition.
  trivial.
  rewrite sumList_body_const.

  rewrite RndNat_support_length.
  intuition.
  intuition.
  eapply rat_num_nz.
  destruct nzn.
  eapply agz.
  eauto.
Qed.

Theorem RndNat_seq :
  forall (n : posnat)(A : Set)(c : nat -> Comp A) a,
    evalDist (x <-$ RndNat n; c x) a ==
    (1 / n) * sumList (allNatsLt n) (fun z => evalDist (c z) a).

  intuition.
  rewrite evalDist_seq_step.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intros.
  eapply ratMult_eqRat_compat.
  eapply RndNat_prob.
  eapply RndNat_support_lt.
  trivial.
  eapply eqRat_refl.
  rewrite sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.
  eapply sumList_permutation.
  eapply NoDup_Permutation.
  eapply getSupport_NoDup.
  eapply allNatsLt_NoDup.
  intuition.
  eapply allNatsLt_lt_if.
  eapply RndNat_support_lt.
  trivial.
  eapply in_getSupport_RndNat.
  eapply allNatsLt_lt.
  trivial.

Qed.

Lemma rndNat_sumList :
  forall (A : Set)(f : nat -> Comp A) n (nzn : nz n) x,
    evalDist (i <-$ RndNat n; f i) x ==
    sumList (forNats n) (fun i => (1 / n) * (evalDist (f i) x)).

  intuition.
  unfold evalDist.
  fold evalDist.
  rewrite sumList_permutation.
  2:{
    eapply (@NoDup_Permutation _ _ (forNats n)).
    eapply getSupport_NoDup.
    eapply forNats_NoDup.
    intuition.

    eapply forNats_In.
    eapply RndNat_support_lt.
    trivial.
    eapply in_getSupport_RndNat.
    eapply forNats_In.
    trivial.
  }

  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat; intuition.

  eapply RndNat_prob.
  eapply forNats_In.
  trivial.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* RndNat -- a computation that returns a random nat uniformly distributed in a specified range. *)

Set Implicit Arguments.

Require Import fcf.Crypto.
Require Import Permutation.
Require Import fcf.NotationV1.

Definition RndNat_unchecked(n : nat) :=
  v <-$ {0,1} ^ (lognat n);
  let n := (bvToNat v) in
    ret n.

Definition ltNatBool := fun x1 x2 => if (lt_dec x1 x2) then true else false.

(* RndNat uses Repeat to get a number strictly less than n *)
Definition RndNat(n : nat) :=
    (Repeat (RndNat_unchecked n) (fun x => (ltNatBool x n))).

Notation "[ 0 '..' n )" := (RndNat n)
  (right associativity, at level 77) : comp_scope.

Lemma well_formed_RndNat : forall n,
  n > O ->
  well_formed_comp (RndNat n).

  intuition.
  unfold RndNat.
  eapply (well_formed_Repeat).
  unfold eq_dec.
  intuition.
  eapply eq_nat_dec.
  unfold RndNat_unchecked.
  eapply well_formed_Bind.
  eapply well_formed_Rnd.
  intuition.
  eapply well_formed_Ret.
  eapply filter_In.
  intuition.
  Focus 2.
  unfold ltNatBool.
  assert ((if (lt_dec O n) then true else false) = true).
  destruct (lt_dec O n).
  trivial.
  omega.
  eapply H0.
  simpl.
  eapply Fold.in_getUnique.
  eapply Fold.in_flatten.
  econstructor.
  split.

  eapply in_map_iff.
  econstructor.
  split.
  eauto.

  eapply in_getAllBvectors.

  specialize (bvNat_zero (lognat n)); intuition.
  simpl in *.
  left.
  eapply H0.

Qed.

Lemma RndNat_support_lt : forall n x,
  In x (getSupport (RndNat n)) ->
  x < n.

  intuition.
  unfold RndNat in *.
  simpl in *.
  eapply filter_In in H.
  intuition.
  unfold ltNatBool in *.
  destruct (lt_dec x n); congruence.
Qed.

Hint Resolve well_formed_RndNat : wftac.

Lemma RndNat_unchecked_lt_support : forall n v,
  v < n ->
  In v (getSupport (RndNat_unchecked n)).

  intuition.
  unfold RndNat_unchecked.

  eapply getSupport_In_Seq.
  eapply in_getAllBvectors.
  simpl.
  left.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  omega.

Qed.

Local Open Scope rat_scope.

Lemma RndNat_uniform : forall v1 v2 n,
  v1 < n ->
  v2 < n ->
  evalDist (RndNat n) v1 == evalDist (RndNat n) v2.

  intuition.

  eapply evalDist_Repeat_eq; intuition.
  unfold RndNat_unchecked.
  remember (lognat n) as length.
  eapply (evalDist_iso
    (BVxor length (BVxor length (natToBv length v1) (natToBv length v2)))
    (BVxor length (BVxor length (natToBv length v1) (natToBv length v2)))); intuition.

(*
  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
*)

  remember (BVxor length (natToBv length v1) (natToBv length v2)) as z.
  rewrite <- BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  trivial.

  rewrite <- BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  trivial.

  simpl.
  eapply in_getAllBvectors.

  eapply uniformity.

  simpl.
  destruct (EqDec_dec nat_EqDec (bvToNat x) v2); subst.
  destruct (EqDec_dec nat_EqDec
    (bvToNat
      (BVxor (lognat n)
        (BVxor (lognat n) (natToBv (lognat n) v1)
          (natToBv (lognat n) (bvToNat x))) x)) v1).
  intuition.
  exfalso.
  eapply n0.

  rewrite natToBv_bvToNat_inverse.

  rewrite BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_r.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  omega.

  destruct (EqDec_dec nat_EqDec
    (bvToNat
      (BVxor (lognat n)
        (BVxor (lognat n) (natToBv (lognat n) v1)
          (natToBv (lognat n) v2)) x)) v1).
  exfalso.
  eapply n0.
  rewrite BVxor_assoc in e.
  assert ((BVxor (lognat n) (natToBv (lognat n) v2) x) = (Bvect_false (lognat n))).
  eapply BVxor_id_r_inv.
  eapply bvToNat_natToBv_eq.
  eauto.
  apply BVxor_id_inv in H2.
  rewrite <- H2.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  omega.

  intuition.

  unfold ltNatBool.
  destruct (lt_dec v1 n); destruct (lt_dec v2 n); congruence.

  eapply filter_In; intuition.
  eapply RndNat_unchecked_lt_support.
  trivial.
  unfold ltNatBool.
  destruct (lt_dec v1 n); congruence.
Qed.

Lemma in_getSupport_RndNat : forall x k,
  x < k ->
  In x (getSupport (RndNat k)).

  intuition.
  simpl.
  eapply filter_In.
  split.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eapply in_getAllBvectors.
  simpl.
  left.
  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  trivial.
  unfold ltNatBool.
  destruct (lt_dec x k); intuition.
Qed.

Theorem RndNat_prob :
  forall n i (nzn : nz n),
    i < n ->
    evalDist (RndNat n) i == 1 / n.

  intuition.

  eapply (@ratMult_same_r_inv _ (n / 1)).
  rewrite ratMult_eq_rat1.
  eapply eqRat_trans.
  Focus 2.
  eapply evalDist_lossless.
  eapply well_formed_RndNat.
  destruct nzn.
  apply agz.

  symmetry.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  eapply (@RndNat_uniform _ i).
  eapply RndNat_support_lt; intuition.
  trivial.
  rewrite sumList_body_const.

  Lemma RndNat_support_length :
    forall n,
      length (getSupport (RndNat n)) = n.

    intuition.
    rewrite (@Permutation_length _ _ (forNats n)).
    eapply forNats_length.
    eapply NoDup_Permutation.
    eapply getSupport_NoDup.
    eapply forNats_NoDup.
    intuition.

    eapply forNats_In.
    eapply RndNat_support_lt; intuition.

    eapply in_getSupport_RndNat.
    eapply forNats_In; intuition.

  Qed.

  rewrite RndNat_support_length.
  intuition.
  intuition.
  eapply rat_num_nz.
  destruct nzn.
  eapply agz.
  eauto.
Qed.

Theorem RndNat_seq :
  forall (n : posnat)(A : Set)(c : nat -> Comp A) a,
    evalDist (x <-$ RndNat n; c x) a ==
    (1 / n) * sumList (allNatsLt n) (fun z => evalDist (c z) a).

  intuition.
  rewrite evalDist_seq_step.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intros.
  eapply ratMult_eqRat_compat.
  eapply RndNat_prob.
  eapply RndNat_support_lt.
  trivial.
  eapply eqRat_refl.
  rewrite sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.
  eapply sumList_permutation.
  eapply NoDup_Permutation.
  eapply getSupport_NoDup.
  eapply allNatsLt_NoDup.
  intuition.
  eapply allNatsLt_lt_if.
  eapply RndNat_support_lt.
  trivial.
  eapply in_getSupport_RndNat.
  eapply allNatsLt_lt.
  trivial.

Qed.

Lemma rndNat_sumList :
  forall (A : Set)(f : nat -> Comp A) n (nzn : nz n) x,
    evalDist (i <-$ RndNat n; f i) x ==
    sumList (forNats n) (fun i => (1 / n) * (evalDist (f i) x)).

  intuition.
  unfold evalDist.
  fold evalDist.
  rewrite sumList_permutation.
  Focus 2.
  eapply (@NoDup_Permutation _ _ (forNats n)).
  eapply getSupport_NoDup.
  eapply forNats_NoDup.
  intuition.

  eapply forNats_In.
  eapply RndNat_support_lt.
  trivial.
  eapply in_getSupport_RndNat.
  eapply forNats_In.
  trivial.

  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat; intuition.

  eapply RndNat_prob.
  eapply forNats_In.
  trivial.
Qed.


(** This file containts two main results:

    1) All 3 characterizations of Two are h-propositions.
    2) This together with the already established logical equivalences
       gives us the final result:

            Dependent elimination + computation for Two
               <~>
            Simple elimination + computation + uniqueness + coherence for Two
               <~>
            H-initiality of Two
**)

Require Import HoTT.
Require Import two_alg.
Require Import two.
Require Import dep_impl_simp.
Require Import simp_impl_dep.

Local Open Scope path_scope.
Local Open Scope fibration_scope.
Local Open Scope equiv_scope.

Section AssumeFunext.
Context `{Funext}.

Theorem twoDepRules_is_hprop (Two : Type) (zero : Two) (one : Two) :
  IsHProp (hasTwoDepElimCompRules Two zero one).
Proof.
apply hprop_allpath.
intros P Q.
apply H; intro E;
apply H; intro e_0;
apply H; intro e_1.
set (X := (Two; (zero, one)) : TwoAlg).
set (Z := (E; (e_0, e_1)) : TwoAlgFib X).
apply (twoAlgFibCell_to_AlgFibMapPath X Z).
apply twoDepElimComp_imp_twoDepUniqCoh.
assumption.
Defined.

Theorem twoSimpRules_is_hprop (Two : Type) (zero : Two) (one : Two) :
  IsHProp (hasTwoSimpElimCompRules Two zero one *
           hasTwoSimpUniqCohRules Two zero one).
Proof.
apply hprop_allpath.
intros P Q.
apply path_prod.

apply H; intro C;
apply H; intro c_0;
apply H; intro c_1.
set (X := (Two; (zero, one)) : TwoAlg).
set (Y := (C; (c_0, c_1)) : TwoAlg).
apply (two2Cell_to_HomPath X Y).
apply (snd P).

apply H; intro C;
apply H; intro c_0;
apply H; intro c_1;
apply H; intro g;
apply H; intro p_0;
apply H; intro p_1.
apply H; intro h;
apply H; intro q_0;
apply H; intro q_1.
set (X := (Two; (zero, one)) : TwoAlg).
set (Z := (fun x => g x = h x; (p_0 @ q_0^, p_1 @ q_1^)) : TwoAlgFib X).
apply (twoAlgFibCell_to_AlgFibMapPath X Z).
apply twoDepElimComp_imp_twoDepUniqCoh.
apply twoSimpRules_imp_twoDepRules.
assumption.
Defined.


Require Import Coq.Arith.EqNat.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.
Require Import Coq.Strings.String.
Require Import GDTC.
Require Import CaseStudy.Names.
Require Import CaseStudy.PNames.
Require Import CaseStudy.Arith.

Section NatCase.

  Open Scope string_scope.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Context {PFun_D : PFunctor D}.
  Context {SPF_D : SPF D}.

  Definition DType := DType D.
  Context {Sub_AType_D  : AType :<: D}.

  Inductive NatCase (A E : Set) : Set :=
  | NVar : A -> NatCase A E
  | Case : E -> E -> (A -> E) -> NatCase A E.

  Global Instance NatCase_Iso (A : Set) :
    Iso (NatCase A) (K A :+: Id :*: Id :*: Fn A) :=
    {| fromIso := fun E e => match e with
                               | NVar a       => inl a
                               | Case e1 e2 f => inr (e1,(e2,f))
                             end;
       toIso   := fun E e => match e with
                               | inl a           => NVar _ _ a
                               | inr (e1,(e2,f)) => Case _ _ e1 e2 f
                             end
    |}.
  Proof.
    intros; destruct a; reflexivity.
    intros; destruct a as [n|[x [y f]]]; reflexivity.
  Defined.

  Global Instance NatCase_Container (A : Set) : Container (NatCase A) :=
    ContainerIso (NatCase_Iso A).

  Variable F : Set -> Set -> Set.
  Context {Fun_F : forall A, Functor (F A)}.
  Context {PFun_F : forall A, PFunctor (F A)}.
  Context {SPF_F : forall A, SPF (F A)}.
  Let Exp A := Fix (F A).
  Context {Sub_NatCase_F : forall A, NatCase A :<: F A}.
  Context {WF_Sub_NatCase_F : forall A, WF_Functor _ _ (Sub_NatCase_F A)}.

  Definition nvar {A : Set} n : Exp A := inject (NatCase A) (F A) (NVar _ _ n).
  Definition case {A : Set} n z s : Exp A := inject (NatCase A) (F A) (Case _ _ n z s).

  Definition ind_alg_NatCase {A : Set}
    (P : Fix (F A) -> Prop)
    (Hnvar : forall x, P (nvar x))
    (Hcase : forall e1 e2 f, P e1 -> P e2 -> (forall a, P (f a)) -> P (case e1 e2 f))
  : PAlgebra (inject (NatCase A) (F A)) P :=
    fun xs =>
      match xs return All P xs -> P (inject (NatCase A) (F A) xs) with
        | NVar a       => fun _ => Hnvar a
        | Case e1 e2 f => fun Axs : forall p : _ + _, _ =>
                            Hcase e1 e2 f
                                  (Axs (inl tt))
                                  (Axs (inr (inl tt)))
                                  (fun a => Axs (inr (inr a)))
      end.

  (* ============================================== *)
  (* TYPING                                         *)
  (* ============================================== *)

  Context {Eq_DType : Eq DType}.

  Definition NatCase_typeof (R : Set) (rec : R -> typeofR D)
    (e : NatCase (typeofR D) R) : typeofR D :=
     match e with
       | NVar n => n
       | Case n z s =>
         match (rec n) with
           | Some Tn =>
             match isTNat _ Tn with
               | true => match rec z, rec (s (Some (tnat _))) with
                           | Some TZ, Some TS =>
                             match eq_DType D TZ TS with
                               | true => Some TZ
                               | false => None
                             end
                           | _, _ => None
                         end
               | false => None
             end
           | _ => None
         end
     end.

  Global Instance MAlgebra_typeof_NatCase T:
    FAlgebra TypeofName T (typeofR D) (NatCase (typeofR D)) :=
    {| f_algebra := NatCase_typeof T|}.

  (* ============================================== *)
  (* EVALUATION                                     *)
  (* ============================================== *)

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.
  Context {PFun_V : PFunctor V}.
  Context {SPF_V : SPF V}.
  Definition Value := Value V.
  Context {Sub_NatValue_V : NatValue :<: V}.
  Context {WF_SubNatValue_V : WF_Functor NatValue V Sub_NatValue_V}.
  Context {Sub_StuckValue_V : StuckValue :<: V}.
  Context {Sub_BotValue_V : BotValue :<: V}.
  Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V}.

  Definition NatCase_eval R : Mixin R (NatCase nat) (evalR V) :=
    fun rec e =>
      match e with
        | NVar n =>
          fun env => match (lookup env n) with
                       | Some v => v
                       | _ => stuck _ 146
                     end
        | Case n z s =>
          fun env =>
            let reced := rec n env in
            match isVI V reced with
              | Some 0 => rec z env
              | Some (S n') => rec (s (Datatypes.length env)) (insert _ (vi _ n') env)
              | _ => if isBot _ reced then bot _ else stuck _ 145
            end
      end.

  Global Instance MAlgebra_eval_NatCase T :
    FAlgebra EvalName T (evalR V) (NatCase _) :=
    {| f_algebra := NatCase_eval T|}.

  (* ============================================== *)
  (* PRETTY PRINTING                                *)
  (* ============================================== *)

  Require Import Ascii.
  Require Import String.

  Definition NatCase_ExpPrint (R : Set) (rec : R -> ExpPrintR)
    (e : NatCase nat R) : ExpPrintR :=
    match e with
      | NVar n => fun n => "n" ++ (String (ascii_of_nat n) EmptyString)
      | Case n z s => fun i => append "(case (" ((rec n i) ++ ") of
  | 0 => " ++ (rec z i) ++ "
  | S n" ++ (String (ascii_of_nat i) EmptyString) ++ " => " ++
  rec (s i) (S i)) ++ ")"
    end.

  Global Instance MAlgebra_Print_NatCase T :
     FAlgebra ExpPrintName T ExpPrintR (NatCase nat) :=
     {| f_algebra := NatCase_ExpPrint T|}.

  (* ============================================== *)
  (* TYPE SOUNDNESS                                 *)
  (* ============================================== *)

  Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}.
  Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (NatCase _)
    (F _) (Sub_NatCase_F _) (MAlgebra_eval_NatCase _) (eval_F)}.

  (* Continuity of Evaluation. *)

  Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}.
  Context {iFun_SV : iFunctor SV}.
  Context {iSPF_SV : iSPF SV}.
  Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}.
  Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}.
  Context {SV_invertVI_SV :
    iPAlgebra SV_invertVI_Name (SV_invertVI_P V) SV}.
  Context {SV_invertVI'_SV :
    iPAlgebra SV_invertVI'_Name (SV_invertVI'_P V) SV}.
  Context {Dis_VI_Bot : Distinct_Sub_Functor NatValue BotValue V}.
  Context {SV_invertBot_SV :
    iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}.

  Global Instance NatCase_eval_continuous_Exp  :
    FPAlgebra (eval_continuous_Exp_P V (F nat) SV) (inject (NatCase nat) (F nat)).
  Proof.
    constructor; unfold PAlgebra; intros.
    apply ind_alg_NatCase; auto; intros.
    (* NVar case. *)
    unfold eval_continuous_Exp_P; intros.
    unfold nvar, inject; simpl_beval.
    caseEq (@lookup Value gamma x); unfold Value, Arith.Value in *|-*;
      rewrite H3.
    destruct (P2_Env_lookup _ _ _ _ _ H1 _ _ H3) as [v' [lookup_v' Sub_v_v']].
    unfold Value; rewrite lookup_v'; eauto.
    unfold Value; rewrite (P2_Env_Nlookup _ _ _ _ _ H1 _ H3).
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto.
    (* Case case. *)
    rename H0 into IHn, H1 into IHz, H2 into IHf.
    unfold eval_continuous_Exp_P; intros.
    generalize (H0 e1 _ _ _ H1 H2); simpl; intros SubV_e1.
    generalize (H0 e2 _ _ _ H1 H2); simpl; intros SubV_e2.
    unfold case, inject; simpl_beval.
    unfold isVI at 2.
    rewrite <- (P2_Env_length _ _ _ _ _ H1).
    caseEq (project NatValue V (beval V (F _) n e1 gamma')).
    destruct n0.
    apply inject_project in H3; rename H3 into Eval_e1'.
    destruct (SV_invertVI' _ _ SubV_e1 _ Eval_e1') as [Eval_e1 | Eval_e1];
      simpl in Eval_e1; rewrite Eval_e1.
    rewrite isVI_vi.
    destruct n0; auto.
    apply H0; auto.
    apply P2_Env_insert; auto.
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; reflexivity.
    rewrite isVI_bot; auto.
    rewrite isBot_bot.
    apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; reflexivity; auto.
    unfold isVI at 1.
    caseEq (project NatValue V (beval V (F nat) m e1 gamma)).
    destruct n0.
    apply inject_project in H4; rename H4 into Eval_e1.
    generalize (SV_invertVI _ _ SubV_e1 _ Eval_e1); simpl; intros Eval_e1'.
    rewrite Eval_e1' in H3.
    unfold vi in H3; rewrite project_inject in H3; discriminate.
    unfold isBot at 2.
    caseEq (project BotValue V (beval V (F nat) n e1 gamma')).
    destruct b.
    apply inject_project in H5; rename H5 into Eval_e1'.
    generalize (SV_invertBot _ SV _ SubV_e1 Eval_e1'); simpl; intro Eval_e1.
    rewrite Eval_e1, isBot_bot.
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; reflexivity.
    unfold isBot.
    caseEq (project BotValue V (beval V (F nat) m e1 gamma)).
    destruct b.
    apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; reflexivity; auto.
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; reflexivity.
  Defined.

  Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop.
  Context {ifun_WFV : iFunctor WFV}.
  Context {ispf_WFV : iSPF WFV}.

  Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop.
  Context {ifun_EQV_E : forall A B, iFunctor (EQV_E A B)}.
  Context {ispf_EQV_E : forall A B, iSPF (EQV_E A B)}.

  Definition E_eqv A B := iFix (EQV_E A B).
  Definition E_eqvC {A B : Set} gamma gamma' e e' :=
    E_eqv _ _ (mk_eqv_i _ A B gamma gamma' e e').

  (* Projection doesn't affect Equivalence Relation.*)

  Inductive NatCase_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop :=
  | NVar_eqv : forall (gamma : Env _) gamma' n a b,
    lookup gamma n = Some a -> lookup gamma' n = Some b ->
    NatCase_eqv A B E (mk_eqv_i _ _ _ gamma gamma' (nvar a) (nvar b))
  | Case_eqv : forall (gamma : Env _) gamma' n n' z z' s s',
    E (mk_eqv_i _ _ _ gamma gamma' n n') ->
    E (mk_eqv_i _ _ _ gamma gamma' z z') ->
    (forall (n : A) (n' : B),
      E (mk_eqv_i _ _ _ (insert _ n gamma) (insert _ n' gamma') (s n) (s' n'))) ->
    NatCase_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' (case n z s) (case n' z' s')).

  Inductive NatCase_eqv_S (A B : Set) : eqv_i F A B -> Set :=
  | SNVar_eqv : forall (gamma : Env _) gamma' n a b,
    lookup gamma n = Some a -> lookup gamma' n = Some b ->
    NatCase_eqv_S A B (mk_eqv_i _ _ _ gamma gamma' (nvar a) (nvar b))
  | SCase_eqv : forall (gamma : Env _) gamma' n n' z z' s s',
    NatCase_eqv_S A B (mk_eqv_i _ _ _ gamma gamma' (case n z s) (case n' z' s')).

  Definition NatCase_eqv_P (A B : Set) (i : eqv_i F A B) (s : NatCase_eqv_S A B i) : Set :=
    match s with
      | SNVar_eqv _ _ _ _ _ _ _ => Empty_set
      | SCase_eqv _ _ _ _ _ _ _ _ => (unit + unit + A * B)%type
    end.

  Definition NatCase_eqv_R (A B : Set) (i : eqv_i F A B)
    (s : NatCase_eqv_S A B i)
    (p : NatCase_eqv_P A B i s) : eqv_i F A B.
  Proof.
    destruct s; simpl in p.
    destruct p.
    destruct p as [[p|p]|[a b]].
    apply (mk_eqv_i _ _ _ gamma gamma' n n').
    apply (mk_eqv_i _ _ _ gamma gamma' z z').
    apply (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (s a) (s' b)).
  Defined.

  Definition NatCase_eqv_to (A B : Set) (C : eqv_i F A B -> Prop) (i : eqv_i F A B) :
    IExt _ _ (NatCase_eqv_R A B) C i -> NatCase_eqv A B C i.
  Proof.
    intros x; destruct x; destruct s; simpl in pf.
    constructor 1 with (n := n); auto.
    constructor 2.
    apply (pf (inl (inl tt))).
    apply (pf (inl (inr tt))).
    intros a b.
    apply (pf (inr (a,b))).
  Defined.

  Definition NatCase_eqv_from (A B : Set) (C : eqv_i F A B -> Prop) (i : eqv_i F A B) :
    NatCase_eqv A B C i -> IExt _ _ (NatCase_eqv_R A B) C i.
  Proof.
    intros x; destruct x.
    constructor 1 with (s := SNVar_eqv _ _ gamma gamma' n a b H H0); simpl.
    intro p; destruct p.
    constructor 1 with (s := SCase_eqv _ _ gamma gamma' n n' z z' s s'); simpl.
    intro p; destruct p as [[p|p]|[a b]]; auto.
  Defined.

  Global Instance NatCase_eqv_Container (A B : Set) : IContainer (NatCase_eqv A B) :=
    {| IS    := NatCase_eqv_S A B;
       IP    := NatCase_eqv_P A B;
       IR    := NatCase_eqv_R A B;
       ifrom := NatCase_eqv_from A B;
       ito   := NatCase_eqv_to A B
    |}.
  Proof.
    intros; destruct a; reflexivity.
    intros; destruct a; destruct s; simpl; f_equal.
    extensionality p; destruct p.
    extensionality p; destruct p as [[[]|[]]|[a b]]; reflexivity.
  Defined.

  Definition ind_alg_NatCase_eqv
    (A B : Set)
    (P : eqv_i F A B -> Prop)
    (H : forall gamma gamma' n a b lookup_a lookup_b,
      P (mk_eqv_i _ _ _ gamma gamma' (nvar a) (nvar b)))
    (H0 : forall gamma gamma' n n' z z' s s'
      (IHn : P (mk_eqv_i _ _ _ gamma gamma' n n'))
      (IHz : P (mk_eqv_i _ _ _ gamma gamma' z z'))
      (IHs : forall n n',
        P (mk_eqv_i _ _ _ (insert _ n gamma) (insert _ n' gamma') (s n) (s' n'))),
    P (mk_eqv_i _ _ _ gamma gamma' (case n z s) (case n' z' s')))
    i (e : NatCase_eqv A B P i) : P i :=
    match e in NatCase_eqv _ _ _ i return P i with
      | NVar_eqv gamma gamma' n a b lookup_a lookup_b =>
        H gamma gamma' n a b lookup_a lookup_b
      | Case_eqv gamma gamma' n n' z z' s s'
        eqv_n_n' eqv_z_z' eqv_s_s' =>
        H0 gamma gamma' n n' z z' s s' eqv_n_n'
        eqv_z_z' eqv_s_s'
    end.

  Variable Sub_NatCase_eqv_EQV_E : forall A B,
    Sub_iFunctor (NatCase_eqv A B) (EQV_E A B).

  Lemma isTNat_tnat :
    forall (T : DType),
      isTNat _ T = true -> T = tnat _.
  Proof.
    unfold isTNat; intros T.
    caseEq (project AType D T).
    apply inject_project in H.
    destruct a; exact H.
    discriminate.
  Defined.

  Context {WF_invertVI_WFV : iPAlgebra WF_invertVI_Name (WF_invertVI_P D V WFV) WFV}.

  Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (F (typeofR D))}.
  Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _
    (Sub_NatCase_F _) (MAlgebra_typeof_NatCase _) (Typeof_F _)}.
  Context {eval_F' : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}.
  Context {WF_eval_F' : @WF_FAlgebra EvalName _ _ (NatCase _)
    (F _) (Sub_NatCase_F _) (MAlgebra_eval_NatCase _) (eval_F')}.
  Variable Sub_WFV_VI_WFV : Sub_iFunctor (WFValue_VI D V) WFV.
  Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV.

  Global Instance NatCase_eval_Soundness
    (eval_rec : Exp _ -> evalR V)
    (typeof_rec : Exp _ -> typeofR D) :
    iPAlgebra eqv_eval_SoundnessName
    (eqv_eval_alg_Soundness'_P D V F EQV_E WFV typeof_rec eval_rec
      (f_algebra TypeofName (FAlgebra := Typeof_F _ ))
      (f_algebra EvalName (FAlgebra := eval_F'))) (NatCase_eqv _ _).
  Proof.
    econstructor; unfold iAlgebra; intros.
    eapply ind_alg_NatCase_eqv; unfold eqv_eval_alg_Soundness'_P,
       eval_alg_Soundness_P; simpl; intros; try assumption.
    (* NVar Case *)
    split; intros.
    apply inject_i; econstructor; eauto.
    unfold nvar, inject; simpl.
    rewrite out_in_inverse.
    rewrite (wf_mixin (WF_Mixin := WF_eval_F')); simpl.
    destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]];
      simpl in *|-*.
    rewrite (WF_gamma' _ _ lookup_b) in *|-*.
    destruct (P2_Env_lookup' _ _ _ _ _ WF_gamma'' _ _ lookup_a) as [v [lookup_v WF_v]];
      unfold Value; rewrite lookup_v.
    destruct a; eauto.
    rename H0 into typeof_d.
    unfold nvar, inject in typeof_d;
      rewrite out_in_inverse in typeof_d;
        rewrite (wf_mixin (WF_Mixin := WF_typeof_F _)) in typeof_d;
          simpl in typeof_d; injection typeof_d; intros; subst; auto.
    destruct WF_v.
    (* Ncase Case *)
    destruct IHn as [n_eqv IHn]; destruct IHz as [z_eqv IHz];
      generalize (fun n n' => (proj1 (IHs n n'))) as s_eqv;
        generalize (fun n n' => (proj2 (IHs n n'))) as IHs'; intros;
          clear IHs; rename IHs' into IHs.
    split; intros.
    apply inject_i; constructor; auto.
    generalize H0; clear H0.
    unfold case, inject; repeat rewrite out_in_inverse.
    rewrite (wf_mixin (WF_Mixin := WF_eval_F'));
      rewrite (wf_mixin (WF_Mixin := WF_typeof_F _)); simpl.
    caseEq (typeof_rec n);
      rename H0 into typeof_n; try discriminate.
    rename H1 into H0.
    assert (WF_a : WFValueC D V WFV (eval_rec n' gamma'') d)
      by (apply (IHa _ _ WF_gamma'' (n, n')); intros; auto; apply IHn; auto).
    caseEq (isTNat D d); rename H1 into d_eq;
      rewrite d_eq in H0; try discriminate; apply isTNat_tnat in d_eq; subst.
    eapply WF_invertVI in WF_a; eauto with typeclass_instances.
    destruct WF_a as [beval_a' | beval_a']; auto; simpl;
      inversion beval_a'; subst.
    rename H2 into eval_n'.
    caseEq (typeof_rec z);
      rename H1 into typeof_z; rewrite typeof_z in H0; try discriminate.
    caseEq (typeof_rec (s (Some (tnat D))));
      rename H1 into typeof_s; rewrite typeof_s in H0; try discriminate.
    caseEq (eq_DType _ d d0); rewrite H1 in H0; try discriminate;
      rename H1 into eq_d0; injection H0; intros; subst.
    apply eq_DType_eq in eq_d0; subst.
    rewrite isVI_vi; destruct n0.
      (* zero case *)
      apply (IHa _ _ WF_gamma'' (z, z')); intros; auto.
      (* successor case *)
      assert (WF_eqv_environment_P D V WFV
           (insert _ (Some (tnat _)) gamma,
            insert _ (Datatypes.length gamma') gamma')
           (insert _ (vi V n0) gamma'')).
      destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]].
      unfold WF_eqv_environment_P; simpl; repeat split.
      simpl in WF_gamma2; rewrite <- WF_gamma2.
      revert WF_gamma; clear; simpl; induction gamma';
        destruct m; simpl; intros; try discriminate.
      injection H; intros; subst.
      clear; induction gamma; simpl; eauto; eexists.
      injection H; intros; subst.
      generalize b (WF_gamma 0 _ (eq_refl _)); clear; induction gamma; simpl; intros b H;
        destruct H as [T lookup_T]; try discriminate.
      destruct b; eauto.
      eapply IHgamma'.
      intros n0 b0 H0; eapply (WF_gamma (S n0) _ H0).
      eassumption.
      assert (exists m', Datatypes.length gamma' = m') as m'_eq
        by (eexists _; reflexivity); destruct m'_eq as [m' m'_eq].
      rewrite m'_eq; generalize m' gamma' WF_gamma2; clear; induction gamma;
        destruct gamma'; intros; simpl; try discriminate;
          try injection H7; intros; eauto.
      simpl in *|-*.
      intro; caseEq (beq_nat m (Datatypes.length gamma')).
      assert (exists m', m' = Datatypes.length gamma') as ex_m' by
        (eexists _; reflexivity); destruct ex_m' as [m' m'_eq];
          rewrite <- m'_eq in H2 at 1.
      rewrite (beq_nat_true _ _ H1), <- m'_eq.
      rewrite (beq_nat_true _ _ H1) in H2.
      generalize m' b H2; clear.
      induction gamma'; simpl; intros;
           try discriminate; auto.
      congruence.
      auto.
      apply WF_gamma'.
      assert (exists m', m' = Datatypes.length gamma') as ex_m' by
        (eexists _; reflexivity); destruct ex_m' as [m' m'_eq];
          rewrite <- m'_eq in H2 at 1.
      generalize m' m (beq_nat_false _ _ H1) H2; clear;
        induction gamma'; simpl; destruct m; intros;
          try discriminate; eauto.
      contradict H; reflexivity.
      apply P2_Env_insert;
        [assumption | apply (inject_i (subGF := Sub_WFV_VI_WFV));
          econstructor; unfold vi; auto].
      assert (WFValueC D V WFV (eval_rec (s' (Datatypes.length gamma''))
        (insert (Arith.Value V) (vi V n0) gamma'')) d0) as WF_s'.
      apply (IHa _ _ H1 (s (Some (tnat D)), s' (Datatypes.length gamma''))).
      intros; simpl.
      destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]].
      apply IHs with (n := Some (tnat D)); auto.
      simpl in *|-*; rewrite (P2_Env_length _ _ _ _ _ WF_gamma'').
      rewrite <- WF_gamma2 in H1; apply H1.
      exact typeof_s.
      auto.
    rewrite H2.
    rewrite isVI_bot; auto.
    rewrite isBot_bot.
    apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto.
  Defined.

End NatCase.


(****************************************************

                    ,MMM8&&&.
                _..MMMMM88&&&&..._
            .::'''MMMMM88&&&&&&'''::.
           ::     MMMMM88&&&&&&     ::
           '::....MMMMM88&&&&&&....::'
              `''''MMMMM88&&&&''''`
                    'MMM8&&&'

                     SATurne
                ----------------
             A tiny verified solver

****************************************************)

(***************************************************
            Module -- Clausal form
****************************************************)

From Coq Require Import Arith List ListSet.
Import ListNotations.

Module Model.

Definition t := list nat.

Fixpoint satisfy (m : t) (n : nat) :=
  match m with
  | [] => false
  | x::xs =>
    if x =? n then true
    else satisfy xs n
  end.

Lemma In_satisfy :
  forall m n, In n m <-> satisfy m n = true.
Proof.
  intros.
  induction m.
  - split; inversion 1.
  - split; inversion 1; subst; simpl.
    + now rewrite Nat.eqb_refl.
    + destruct (a =? n); auto.
      now apply IHm.
    + destruct (a =? n) eqn:E.
      * apply Nat.eqb_eq in E; subst.
        now left.
      * firstorder.
Qed.

Definition sub_model (m1 m2 : t) : bool :=
  List.forallb (satisfy m2) m1.

Lemma sub_model_refl :
  forall m, sub_model m m = true.
Proof.
  induction m; simpl; auto.
  unfold sub_model in *.
  rewrite forallb_forall in IHm.
  rewrite Nat.eqb_refl; simpl.
  apply forallb_forall; intros.
  destruct (a =? x); auto.
Qed.

Definition eqb (m1 m2 : t) : bool :=
  sub_model m1 m2 && sub_model m2 m1.

Lemma eq_eqb :
  forall m1 m2, m1 = m2 -> eqb m1 m2 = true.
Proof.
  intros m _ <-.
  unfold eqb.
  now rewrite sub_model_refl.
Qed.

End Model.

Module Literal.

(** Type literal *)
Inductive t : Type :=
  | Pos : nat -> t
  | Neg : nat -> t.

Definition eqb (l1 l2 : t) :=
  match l1, l2 with
  | Pos u, Pos v
  | Neg u, Neg v => u =? v
  | _, _ => false
  end.

Definition neg (l : t) :=
  match l with
  | Neg n => Pos n
  | Pos n => Neg n
  end.

Lemma eqb_eq :
  forall (l l' : t), eqb l l' = true <-> l = l'.
Proof.
  induction l as [ n | n ], l' as [ n' | n' ]; simpl;
  try easy.
  + rewrite (Nat.eqb_eq); split; now inversion 1.
  + rewrite (Nat.eqb_eq); split; now inversion 1.
Qed.

Lemma eqb_false :
  forall (l l' : t), eqb l l' = false -> l <> l'.
Proof.
  intros l l' Heq <-.
  destruct l; simpl in Heq; now rewrite Nat.eqb_refl in Heq.
Qed.

Lemma eq_dec :
  forall (l l' : t), { l = l' } + { l <> l' }.
Proof.
  decide equality; apply Nat.eq_dec.
Qed.

Lemma eqb_refl :
  forall l, eqb l l = true.
Proof.
  intros.
  now rewrite eqb_eq.
Qed.

Definition eval (m : Model.t) (l : t) : bool :=
  match l with
  | Pos n => Model.satisfy m n
  | Neg n => negb (Model.satisfy m n)
  end.

End Literal.

Module Clause.

Definition t : Type := list Literal.t.

Fixpoint mem (c : t) (l : Literal.t) : bool :=
  match c with
  | [] => false
  | l'::ls =>
    if Literal.eqb l l' then true
    else mem ls l
  end.

Lemma In_mem :
  forall l c, In l c <-> mem c l = true.
Proof.
  intros l c.
  induction c.
  - split; inversion 1.
  - split; intros.
    + induction H; subst; simpl.
      * now rewrite Literal.eqb_refl.
      * destruct Literal.eqb; auto.
        now rewrite <- IHc.
    + simpl in H.
      destruct Literal.eqb eqn:E; auto.
      * rewrite (proj1 (Literal.eqb_eq _ _) E).
        now left.
      * right.
        apply ((proj2 IHc) H).
Qed.

Definition sub_clause (c1 c2 : t) : bool :=
  List.forallb (mem c1) c2.

Lemma sub_clause_refl :
  forall c, sub_clause c c = true.
Proof.
  induction c as [ | l c IHc]; auto.
  apply forallb_forall; intros.
  inversion H; subst; simpl.
  - now rewrite Literal.eqb_refl.
  - destruct Literal.eqb; auto.
    now apply In_mem.
Qed.

Definition eqb (c1 c2 : t) : bool :=
  sub_clause c1 c2 && sub_clause c2 c1.

Lemma eq_eqb :
  forall c1 c2, c1 = c2 -> eqb c1 c2 = true.
Proof.
  intros c _ <-.
  unfold eqb.
  now rewrite sub_clause_refl.
Qed.

Lemma eqb_false :
  forall c1 c2, eqb c1 c2 = false -> c1 <> c2.
Proof.
  intros c1 c2 Heq <-.
  now rewrite (eq_eqb c1 c1 (eq_refl)) in Heq.
Qed.

Fixpoint eval (m : Model.t) (c : t) :=
  match c with
  | [] => false
  | x::xs =>
    if Literal.eval m x then true
    else eval m xs
  end.

Lemma eval_true_exists :
  forall c m, eval m c = true -> exists x, In x c /\ Literal.eval m x = true.
Proof.
  intros c m H.
  induction c; try easy.
  simpl in H.
  destruct (Literal.eval m a) eqn:E;
  firstorder.
Qed.

Lemma exists_eval_true :
  forall c m, (exists x, In x c /\ Literal.eval m x = true) -> eval m c = true.
Proof.
  intros c m [x [Hx Heval]].
  induction c; auto.
  destruct Hx; subst; simpl.
  + now rewrite Heval.
  + destruct (Literal.eval m a); auto.
Qed.

Lemma eval_app :
  forall c1 c2 m, eval m (c1 ++ c2) = (eval m c1 || eval m c2)%bool.
Proof.
  intros.
  induction c1; simpl; auto.
  now destruct (Literal.eval m a) eqn:E.
Qed.

Lemma eqb_equiv :
  forall c1 c2, eqb c1 c2 = true -> forall m, eval m c1 = true <-> eval m c2 = true.
Proof.
  intros c1 c2 [H1 H2]%Bool.andb_true_iff m.
  unfold sub_clause in *; split; intros.
  all:
    apply eval_true_exists in H as [l [Hin Heval]];
    apply exists_eval_true; exists l;
    rewrite forallb_forall in H1, H2;
    firstorder using In_mem.
Qed.

Lemma eqb_equiv' :
  forall c1 c2, eqb c1 c2 = true -> forall m, eval m c1 = false <-> eval m c2 = false.
Proof.
  intros c1 c2 H m; split; intros.
  + assert (~(eval m c1 = true)) by now destruct (eval m c1).
    destruct (eval m c2) eqn:E; auto.
    firstorder using eqb_equiv.
  + assert (~(eval m c2 = true)) by now destruct (eval m c2).
    destruct (eval m c1) eqn:E; auto.
    firstorder using eqb_equiv.
Qed.

Lemma eqb_eval_eq :
  forall c1 c2, eqb c1 c2 = true -> forall m, eval m c1 = eval m c2.
Proof.
  intros.
  destruct (eval m c1) eqn:E.
  + now rewrite (eqb_equiv c1 c2 H m) in E.
  + now rewrite (eqb_equiv' c1 c2 H m) in E.
Qed.

End Clause.

Module ClauseSet.

Definition t := list Clause.t.

Fixpoint mem (cs : t) (c : Clause.t) : bool :=
  match cs with
  | [] => false
  | c'::cs' =>
    if Clause.eqb c c' then true
    else mem cs' c
  end.

Lemma In_mem :
  forall cs c, In c cs -> mem cs c = true.
Proof.
  intros cs c Hccs.
  induction cs; simpl; auto.
  destruct Clause.eqb eqn:E; auto.
  apply Clause.eqb_false in E.
  destruct Hccs; auto.
Qed.

Fixpoint eval (m : Model.t) (cs : t) : bool :=
  match cs with
  | [] => true
  | c::cs => (Clause.eval m c && eval m cs)%bool
  end.

Lemma eval_app :
  forall c1 c2 m, eval m (c1 ++ c2) = (eval m c1 && eval m c2)%bool.
Proof.
  intros.
  induction c1; simpl; auto.
  destruct (Clause.eval m a) eqn:E; auto.
Qed.

Lemma eval_true_forall :
  forall cs m, eval m cs = true -> forall c, mem cs c = true -> Clause.eval m c = true.
Proof.
  intros cs m H c Hc.
  induction cs; try easy.
  simpl in H.
  destruct (Clause.eval m a) eqn:E; simpl in H; try easy.
  simpl in Hc.
  destruct (Clause.eqb c a) eqn:E'.
  + eapply Clause.eqb_equiv.
    apply E'.
    apply E.
  + firstorder.
Qed.

Definition sat (cs : ClauseSet.t) :=
  exists m, ClauseSet.eval m cs = true.

Definition unsat (cs : ClauseSet.t) :=
  ~sat cs.

End ClauseSet.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype finfun bigop finset.

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

(** * Maximum Subset Satisfying some Property *)

(** OUTLINE:
- Module maxsubset.
- Section max_subset_satisfying_P.
*)

Module maxsubset.

Variable A : finType.

Definition maxset P (E : {set A}) := (P E) &&
  [forall F : {set A}, (P F && (E \subset F)) == (E == F)].

Lemma maxset_eq P1 P2 E : P1 =1 P2 -> maxset P1 E = maxset P2 E.
Proof.
move=> P1P2.
rewrite /maxset.
rewrite P1P2.
congr (_ && _).
apply/forallP/forallP => /= H x.
by rewrite -P1P2 H.
by rewrite P1P2 H.
Qed.

Lemma maxsetP (P : {set A} -> bool) E :
  reflect ((P E) /\ (forall F, P F -> E \subset F -> E = F)) (maxset P E).
Proof.
case H : (maxset P E); [apply ReflectT | apply ReflectF].
  case/andP : H => -> /forallP H.
  split => // F H1 H2.
  move: (H F).
  by rewrite H1 H2 /= eq_sym eqb_id => /eqP.
case => H1 H2.
move/negP : H; apply.
rewrite /maxset H1 /=.
apply/forallP => F.
case H : (_ && _).
  case/andP : H.
  move/H2 => H3; move/H3 => ->.
  by rewrite eqxx.
rewrite eq_sym.
rewrite eqbF_neg.
apply/eqP => ?; subst F.
rewrite H1 /= in H.
move/negP : H; by apply.
Qed.

Lemma maxsetp E P : maxset P E -> P E.
Proof. by case/maxsetP. Qed.

Lemma maxsetinf P E F : maxset P E -> P F -> E \subset F -> E = F.
Proof.
case/maxsetP => H1 H2 PF.
by apply H2.
Qed.

Lemma ex_maxset (P : pred {set A}): (exists E, P E) -> {E | maxset P E}.
Proof.
move=> exQ.
pose pS n := [pred F | P F & #|F| == n].
pose p n := ~~ pred0b (pS n).
have {exQ} : exists n, p n.
  case: exQ => E QE.
  exists #| E  |.
  rewrite /p.
  apply/existsP.
  exists E.
  by rewrite eqxx andbT.
case/(@ex_maxnP _ #|A|).
  move=> o pi.
  case/existsP : pi => B /andP [] QB /eqP <-.
  by apply max_card.
move=> i.
move/pred0P.
case: (pickP (pS i)) => // F.
move=> pSF H Hi.
exists F.
apply/(@maxsetP P).
split.
  rewrite /pS inE in pSF.
  by case/andP : pSF.
move=> G QG FG.
apply/eqP.
rewrite eqEcard FG /=.
move: (Hi #|G|).
rewrite /pS inE in pSF.
case/andP : pSF => H1 H2.
rewrite (eqP H2).
apply.
apply/existsP.
exists G.
by rewrite QG eqxx.
Qed.

Lemma maxset_exists (P : pred {set A}) C : P C -> {F | maxset P F & C \subset F}.
Proof.
move=> PC.
have{PC}: exists A, P A && (C \subset A).
  by exists C; rewrite PC /=.
case/ex_maxset => B.
move/maxsetP => [].
case/andP => BP CB maxB.
exists B => //.
apply/maxsetP.
split=> // D PD BD.
rewrite (maxB D) // PD.
by rewrite (subset_trans CB).
Qed.

End maxsubset.

Section max_subset_satisfying_P.

Variable A : finType.
Variable P : pred {set A}.

Definition Psets (E : {set A}) : {set {set A}} :=
  [set s : {set A} | s \subset E & P s].

Definition maxset E := \bigcup_(s in Psets E) s.

Lemma maxset_is_subset E : maxset E \subset E.
Proof. apply/bigcupsP => /= s; rewrite inE; by case/andP. Qed.

Definition covered_by (E K : {set A}):=
  [forall s, (s \in Psets E) ==> (s \subset K)].

Lemma covered_by_maxset E : covered_by E (maxset E).
Proof.
apply/forallP => s.
apply/implyP => Hs.
rewrite /maxset.
exact: subset_trans (bigcup_sup _ Hs).
Qed.

Hypothesis P0 : P set0.

Lemma card_Psets (E : {set A}) : #| Psets E | != 0.
Proof.
rewrite cards_eq0.
apply/set0Pn => /=.
exists set0; by rewrite inE P0 andbT sub0set.
Qed.

Hypothesis PU : forall s1 s2, P s1 -> P s2 -> P (s1 :|: s2).

Lemma PsetsU s1 s2 E : s1 \in Psets E -> s2 \in Psets E ->
  s1 :|: s2 \in Psets E.
Proof.
rewrite /Psets.
rewrite inE; case/andP => s1E Ps1.
rewrite inE; case/andP => s2E Ps2.
rewrite inE.
apply/andP; split.
  by apply/subUsetP.
by rewrite PU.
Qed.

Lemma maxset_in_Psets E : maxset E \in Psets E.
Proof.
rewrite /Psets inE maxset_is_subset /= /maxset.
suff Hgen : forall F : {set {set A}} , (forall s', s' \in F -> P s') -> P (\bigcup_(s in F) s).
  apply Hgen => s'.
  rewrite inE.
  by case/andP.
move=> F /= HF.
move Hk : (#| F |) => k.
elim: k => [ | k IH ] in F Hk HF *.
  rewrite big_pred0.
    by rewrite P0.
  move=> s /=.
  apply/negbTE.
  move/eqP : Hk.
  rewrite cards_eq0 => /negPn.
  apply: contra => sF.
  apply/set0Pn; by exists s.
have : #|F| != O by rewrite Hk.
rewrite cards_eq0.
case/set0Pn => f0 Hf0.
rewrite -(@setD1K _ f0 F) // bigcup_setU PU //.
  rewrite (big_pred1 f0).
    by apply HF.
  move=> /= s; by rewrite inE.
apply IH.
  rewrite (cardsD1 f0) in Hk.
  rewrite Hf0 in Hk.
  rewrite add1n in Hk.
  by case: Hk.
move=> s' Hs'.
apply HF.
rewrite inE in Hs'.
by case/andP : Hs'.
Qed.

Lemma maxset_is_Ppred E : P (maxset E).
Proof.
have : maxset E \in Psets E by apply maxset_in_Psets.
rewrite inE.
by case/andP.
Qed.

Definition is_unique E (P : {set A} -> Prop)  : Prop :=
  forall E', P E' -> E' = E.

Lemma maxset_is_unique E : is_unique (maxset E)
  (fun E' => E' \subset E /\ covered_by E E' /\ P E').
Proof.
rewrite /is_unique => E'.
case=> EsubE'.
case=> EE' HE'.
apply/setP => /= n0.
case/boolP : (n0 \in maxset E) => Hn0.
  move/forallP : EE'.
  move=> /(_ (maxset E)).
  move /implyP.
  move/(_ (maxset_in_Psets E)).
  move /subsetP.
  by apply.
apply: contraTF Hn0.
rewrite negbK => n0E'.
apply/bigcupP => /=.
exists E' => //.
by rewrite inE HE' andbT.
Qed.

End max_subset_satisfying_P.


Require Import AutoSep Omega.

Lemma S_le_lt : forall a b c, (a + S b <= c -> a < c)%nat.
  intros; omega.
Qed.
Lemma lt_goodSize'' : forall a b, (a < b)%nat -> goodSize b -> natToW a < natToW b.
  intros; apply lt_goodSize; auto; eapply goodSize_weaken; eauto.
Qed.
Lemma max_le_1 : forall b d1 d2 n, (b + S (max d1 d2) <= n -> b + d1 <= n)%nat.
  intros.
  eapply (Le.le_trans _ _ _ _ H).
  Grab Existential Variables.
  eapply Plus.plus_le_compat_l.
  eapply le_S.
  eapply Max.le_max_l.
Qed.
Lemma max_le_2 : forall b d1 d2 n, (b + S (max d1 d2) <= n -> S b + d2 <= n)%nat.
  intros.
  simpl.
  eapply (Le.le_trans _ _ _ _ H).
  Grab Existential Variables.
  eapply Lt.lt_le_S.
  eapply Plus.plus_lt_compat_l.
  eapply Lt.le_lt_n_Sm.
  eapply Max.le_max_r.
Qed.
Lemma selN_updN : forall ls n v, (n < length ls)%nat -> selN (updN ls n v) n = v.
  induction ls; induction n; simpl; intuition.
Qed.
Lemma sel_upd : forall n ls v, (n < length ls)%nat -> goodSize (length ls) -> Array.sel (Array.upd ls (natToW n) v) (natToW n) = v.
  intros; rewrite sel_selN; try (eapply goodSize_weaken; eauto).
  rewrite upd_updN; try (eapply goodSize_weaken; eauto).
  apply selN_updN; auto.
Qed.
Lemma sel_firstn' : forall ls1 ls2 n, (n < length ls1 -> length ls1 = length ls2 -> firstn (S n) ls1 = firstn (S n) ls2 -> selN ls1 n = selN ls2 n)%nat.
  induction ls1; induction ls2; induction n; simpl; intuition.
  apply IHls1; simpl in *; intuition.
Qed.
Lemma sel_firstn : forall ls1 ls2 n, (n < length ls1 -> length ls1 = length ls2 -> firstn (S n) ls1 = firstn (S n) ls2 -> goodSize (length ls1) -> Array.sel ls1 (natToW n) = Array.sel ls2 (natToW n))%nat.
  intros; repeat rewrite sel_selN; try (eapply goodSize_weaken; eauto).
  eapply sel_firstn'; eauto.
Qed.
Lemma sel_upd_firstn : forall n ls1 ls2 v, (n < length ls1)%nat -> length ls1 = length ls2 -> goodSize (length ls1) -> firstn (S n) ls1 = firstn (S n) (Array.upd ls2 (natToW n) v) -> Array.sel ls1 (natToW n) = v.
  intros.
  erewrite sel_firstn.
  Focus 4.
  eauto.
  apply sel_upd.
  congruence.
  congruence.
  omega.
  rewrite upd_length.
  omega.
  auto.
Qed.
Lemma firstn_S : forall A n (ls1 ls2 : list A), (n < length ls1)%nat -> length ls1 = length ls2 -> firstn (S n) ls1 = firstn (S n) ls2 -> firstn n ls1 = firstn n ls2.
  intros.
  rewrite <- removelast_firstn; try congruence.
  rewrite H1.
  apply removelast_firstn; congruence.
Qed.
Lemma upd_firstn : forall ls n v, firstn n (updN ls n v) = firstn n ls.
  induction ls; induction n; simpl; intuition.
Qed.
Hint Immediate upd_firstn.
Lemma firstn_S_upd : forall n ls1 ls2 v, (n < length ls2)%nat -> length ls1 = length ls2 -> goodSize (length ls1) -> firstn (S n) ls1 = firstn (S n) (Array.upd ls2 (natToW n) v) -> firstn n ls1 = firstn n ls2.
  clear.
  intros.
  apply firstn_S in H2; try rewrite upd_length; try congruence.
  rewrite H2.
  rewrite upd_updN; try (eapply goodSize_weaken; eauto).
  auto.
Qed.

Lemma evalInstrs_cons_fwd : forall i is stn st st_new,
  evalInstrs stn st (i :: is) = Some st_new -> exists st',
    evalInstr stn st i = Some st' /\ evalInstrs stn st' is = Some st_new.
  Transparent evalInstrs.
  simpl; intros.
  destruct (evalInstr stn st i); try discriminate.
  eauto.
  Opaque evalInstrs.
Qed.

Require Import Wrap.
Import DefineStructured.

Lemma evalInstrs_cons_fwd_None : forall (stn : settings) i (is1 : list instr) (st : state),
  evalInstrs stn st (i :: is1) = None ->
  evalInstr stn st i = None \/
  (exists st' : state,
    evalInstr stn st i = Some st' /\ evalInstrs stn st' is1 = None).
  intros; rewrite evalInstr_evalInstrs in *.
  apply evalInstrs_app_fwd_None. auto.
Qed.

Section Lemmas.

  Lemma sum_S: forall a b, a + S b = S a + b.
    intros; omega.
  Qed.

  Hint Rewrite sum_S : arith.
  Hint Resolve S_le_lt.
  Hint Resolve sel_upd_firstn.
  Hint Resolve firstn_S_upd.
  Hint Resolve Max.le_max_l Max.le_max_r.

  Lemma le_plus_lt : forall a b c, (a + c <= b -> 0 < c -> a < b)%nat.
    intros; omega.
  Qed.

  Lemma lt_max_l : forall l n m, (l < n -> l < max n m)%nat.
    intros; assert (n <= max n m)%nat by eauto; omega.
  Qed.

  Lemma lt_max_r : forall l n m, (l < m -> l < max n m)%nat.
    intros; assert (m <= max n m)%nat by eauto; omega.
  Qed.

  Hint Resolve le_plus_lt lt_max_l lt_max_r.

  Lemma plus_le : forall a b c d, (a + b <= c -> d <= b -> a + d <= c)%nat.
    intros; omega.
  Qed.

  Hint Resolve plus_le.

  Lemma plus_lt : forall a b c d, (a + b <= c -> d < b -> a + d < c)%nat.
    intros; omega.
  Qed.

  Hint Resolve lt_le_S plus_lt.

  Lemma lt_gt_flip : forall a b, (a < b -> b > a)%nat.
    intros; omega.
  Qed.

  Lemma le_ge_flip : forall a b, (a <= b -> b >= a)%nat.
    intros; omega.
  Qed.

  Lemma plus_max_l: forall a b c, (a + max b (S c) >= a + b)%nat.
    intros; apply le_ge_flip; eauto.
  Qed.

  Lemma S_plus_max_r: forall a b c, (a + max b (S c) >= S a + c)%nat.
    intros; apply le_ge_flip; simpl; eauto.
  Qed.

  Lemma S_max_simpl: forall n a b, (n + max a (S b) > n)%nat.
      induction n; induction a; induction b; simpl; intuition.
  Qed.

  Lemma plus_max_tran_r: forall a b c n, (n < c -> b + max a (S c) > n + S b)%nat.
    intros; replace (n + S b) with (b + S n) by omega; apply lt_gt_flip; simpl; eauto.
  Qed.

End Lemmas.


Require Import CertiGraph.graph.SpaceAdjMatGraph3.
Require Export CertiGraph.priq.is_empty_lemmas.
Require Import CertiGraph.dijkstra.dijkstra_env.
Require Import CertiGraph.dijkstra.MathDijkGraph.
Require Import CertiGraph.dijkstra.dijkstra_math_proof.
Require Import CertiGraph.dijkstra.dijkstra_spec3.
Require Import CertiGraph.dijkstra.dijkstra_constants.

Local Open Scope Z_scope.

Section DijkstraProof.

  (* The invariants have been dragged out of the
   proof for readability and reuse
   *)

  Context {Z_EqDec : EquivDec.EqDec Z eq}.

  Definition dijk_setup_loop_inv g sh src dist prev v_pq arr :=
    EX i : Z,
    PROP ()
    LOCAL (temp _dist (pointer_val_val dist);
          temp _prev (pointer_val_val prev);
          temp _src (Vint (Int.repr src));
          temp _pq (pointer_val_val v_pq);
          temp _graph (pointer_val_val arr))
    SEP (data_at Tsh
                 (tarray tint size)
                 ((list_repeat (Z.to_nat i)
                               (Vint (Int.repr inf)))
                    ++ (list_repeat (Z.to_nat (size-i))
                                    Vundef)) (pointer_val_val v_pq);
        data_at Tsh
                (tarray tint size)
                ((list_repeat (Z.to_nat i)
                              (Vint (Int.repr inf)))
                   ++ (list_repeat (Z.to_nat (size-i))
                                   Vundef)) (pointer_val_val prev);
        data_at Tsh
                (tarray tint size)
                ((list_repeat (Z.to_nat i) (Vint (Int.repr inf)))
                   ++ (list_repeat (Z.to_nat (size-i))
                                   Vundef)) (pointer_val_val dist);
        @SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val arr);
        free_tok (pointer_val_val v_pq) (sizeof tint * size)).

  Definition dijk_forloop_inv (g: @DijkGG size inf) sh src
             dist_ptr prev_ptr priq_ptr graph_ptr :=
    EX prev : list V,
    EX priq : list Z,
    EX dist : list Z,
    EX popped : list V,
    PROP (
        (* The overall correctness condition *)
        dijkstra_correct g src popped prev dist;

      (* Some special facts about src *)
      Znth src dist = 0;
      Znth src prev = src;
      popped <> [] -> In src popped;
      popped = [] -> src = find priq (fold_right Z.min (hd 0 priq) priq) 0;

      (* A fact about the relationship b/w
         the priq and popped arrays *)
      forall v,
        vvalid g v ->
        In v popped <-> Znth v priq = Z.add inf 1;

      (* A fact about the relationship b/w
         dist and priq arrays *)
      forall dst, vvalid g dst ->
                  ~ In dst popped ->
                  Znth dst priq = Znth dst dist;

      (* Information about the ranges of the three arrays *)
      @inrange_prev size inf prev;
      @inrange_dist inf dist;
      @inrange_priq inf priq)

         LOCAL (temp _dist (pointer_val_val dist_ptr);
               temp _prev (pointer_val_val prev_ptr);
               temp _src (Vint (Int.repr src));
               temp _pq (pointer_val_val priq_ptr);
               temp _graph (pointer_val_val graph_ptr))
         SEP (data_at Tsh
                      (tarray tint size)
                      (map Vint (map Int.repr prev))
                      (pointer_val_val prev_ptr);
             data_at Tsh
                     (tarray tint size)
                     (map Vint (map Int.repr priq))
                       (pointer_val_val priq_ptr);
             data_at Tsh
                     (tarray tint size)
                     (map Vint (map Int.repr dist))
                     (pointer_val_val dist_ptr);
             @SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
             free_tok (pointer_val_val priq_ptr) (sizeof tint * size)).

  Definition dijk_forloop_break_inv (g: @DijkGG size inf) sh
                                    src dist_ptr prev_ptr priq_ptr graph_ptr :=
    EX prev: list V,
    EX priq: list Z,
    EX dist: list Z,
    EX popped: list V,
    PROP (
        (* This fact comes from breaking while *)
        Forall (fun x => x >= inf) priq;
      (* And the correctness condition is established *)
      dijkstra_correct g src popped prev dist)
         LOCAL (temp _pq (pointer_val_val priq_ptr))
         SEP (data_at Tsh
                      (tarray tint size)
                      (map Vint (map Int.repr prev))
                      (pointer_val_val prev_ptr);
             (data_at Tsh
                      (tarray tint size)
                      (map Vint (map Int.repr priq))
                        (pointer_val_val priq_ptr));
             data_at Tsh
                     (tarray tint size)
                     (map Vint (map Int.repr dist))
                     (pointer_val_val dist_ptr);
             @SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
             free_tok (pointer_val_val priq_ptr) (sizeof tint * size)).

  Definition dijk_inner_forloop_inv (g: @DijkGG size inf) sh
             src (priq dist prev : list Z)
             dist_ptr prev_ptr priq_ptr graph_ptr :=
    EX i : Z,
    EX prev' : list V,
    EX priq' : list Z,
    EX dist' : list Z,
    EX popped' : list V,
    let u :=
        find priq (fold_right Z.min (hd 0 priq) priq) 0 in
    PROP (
        (* inv_popped is not affected *)
        forall dst,
          vvalid g dst ->
          inv_popped g src popped' prev' dist' dst;

      (* inv_unpopped is restored for those vertices
         that the for loop has scanned and repaired *)
      forall dst,
        0 <= dst < i ->
        inv_unpopped g src popped' prev' dist' dst;

      (* a weaker version of inv_popped is
         true for those vertices that the
         for loop has not yet scanned *)
      forall dst,
        i <= dst < size ->
        inv_unpopped_weak g src popped' prev' dist' dst u;

      (* similarly for inv_unseen,
         the invariant has been
         restored until i:
         u has been taken into account *)
      forall dst,
        0 <= dst < i ->
        inv_unseen g src popped' prev' dist' dst;

      (* and a weaker version of inv_unseen is
         true for those vertices that the
         for loop has not yet scanned *)
      forall dst,
        i <= dst < size ->
        inv_unseen_weak g src popped' prev' dist' dst u;

      (* further, some useful facts about src... *)
      Znth src dist' = 0;
      Znth src prev' = src;
      popped' <> [] -> In src popped';
      popped' = [] -> src = find priq' (fold_right Z.min
                                                   (hd 0 priq') priq') 0;

      (* a useful fact about u *)
      In u popped';

      (* A fact about the relationship b/w
         priq and popped arrays *)
      forall v,
        vvalid g v ->
        In v popped' <-> Znth v priq' = Z.add inf 1;

      (* A fact about the relationship b/w
         dist and priq arrays *)
      forall dst,
        vvalid g dst ->
        ~ In dst popped' ->
        Znth dst priq' = Znth dst dist';

      (* the lengths of the threee arrays *)
      Zlength priq' = size;
      Zlength dist' = size;
      Zlength prev' = size;

      (* and ranges of the three arrays *)
      @inrange_prev size inf prev';
      @inrange_priq inf priq';
      @inrange_dist inf dist')

         LOCAL (temp _u (Vint (Int.repr u));
               temp _dist (pointer_val_val dist_ptr);
               temp _prev (pointer_val_val prev_ptr);
               temp _src (Vint (Int.repr src));
               temp _pq (pointer_val_val priq_ptr);
               temp _graph (pointer_val_val graph_ptr))

         SEP (data_at Tsh
                      (tarray tint size)
                      (map Vint (map Int.repr prev'))
                      (pointer_val_val prev_ptr);
             data_at Tsh
                     (tarray tint size)
                     (map Vint (map Int.repr priq'))
                     (pointer_val_val priq_ptr);
             data_at Tsh
                     (tarray tint size)
                     (map Vint (map Int.repr dist'))
                     (pointer_val_val dist_ptr);
             @SpaceAdjMatGraph size CompSpecs sh id
                               g (pointer_val_val graph_ptr);
             free_tok (pointer_val_val priq_ptr) (sizeof tint * size)).

  Lemma body_getCell: semax_body Vprog Gprog f_getCell getCell_spec.
  Proof.
    start_function.
    rewrite (SpaceAdjMatGraph_unfold _ id _ _ addresses u); trivial.
    assert (Zlength (map Int.repr (Znth u (@graph_to_mat size g id))) = size). {
      unfold graph_to_mat, vert_to_list.
      rewrite Znth_map; repeat rewrite Zlength_map.
      all: rewrite nat_inc_list_Zlength; lia.
    }
    assert (0 <= i < Zlength (map Int.repr (Znth u (@graph_to_mat size g id)))) by lia.
    assert (0 <= i < Zlength (Znth u (@graph_to_mat size g id))). {
      rewrite Zlength_map in H1. lia.
    }
    Intros.
    freeze FR := (iter_sepcon _ _) (iter_sepcon _ _).
    unfold list_rep.
    assert_PROP (force_val
                   (sem_add_ptr_int
                      tint
                      Signed
                      (force_val
                         (sem_add_ptr_int
                            (tarray tint size)
                            Signed
                            (pointer_val_val graph_ptr)
                            (Vint (Int.repr u))))
                      (Vint (Int.repr i))) =
                 field_address
                   (tarray tint size)
                   [ArraySubsc i]
                   (@list_address
                      size
                      CompSpecs
                      (pointer_val_val graph_ptr)
                      u)). {
      entailer!.
      unfold list_address. simpl.
      rewrite field_address_offset.
      1: { rewrite offset_offset_val; simpl; f_equal.
           rewrite Z.add_0_l. f_equal. lia. }
      destruct H5 as [? [? [? [? ?]]]].
      unfold field_compatible; split3; [| | split3]; simpl; auto.
    }
    forward. forward. thaw FR.
    rewrite (SpaceAdjMatGraph_unfold _ id _ _ addresses u); trivial.
    entailer!.
  Qed.

  (* DIJKSTRA PROOF BEGINS *)

  Lemma body_dijkstra: semax_body Vprog Gprog f_dijkstra dijkstra_spec.
  Proof.
    start_function.
    pose proof (size_further_restricted g).
    pose proof (inf_bounds g).
    rename H1 into Hsz.
    rename H2 into Hinf.
    forward_call (tt).
    1: split; [split|]; ulia.
    Intro priq_ptr.
    forward_for_simple_bound
      size
      (dijk_setup_loop_inv g sh src dist_ptr prev_ptr priq_ptr graph_ptr).
    - rewrite list_repeat_0, app_nil_l, Z.sub_0_r, data_at__tarray.
      entailer!.
    - forward. forward.
      forward_call ((pointer_val_val priq_ptr), i, inf,
                    (list_repeat (Z.to_nat i)
                                 (Vint (Int.repr inf)) ++
                                 list_repeat (Z.to_nat
                                                (size - i)) Vundef)).
      1: split; [|red]; ulia.
      repeat rewrite upd_Znth_list_repeat; try lia.
      entailer!.
    - (* At this point we are done with the
       first for loop. The arrays are all set to inf. *)
      replace (size - size) with 0 by lia;
        rewrite list_repeat_0, <- (app_nil_end).
      forward. forward.
      do 2 rewrite <- map_list_repeat.
      forward_call ((pointer_val_val priq_ptr), src, 0,
                    (list_repeat (Z.to_nat size) inf)).
      1: split; [|red]; ulia.
      do 2 rewrite map_list_repeat.
      assert (H_src_valid: vvalid g src). {
        rewrite (vvalid_meaning g); trivial.
      }

      (* Special values for src have been inserted *)

      (* We will now enter the main while loop.
       We state the invariant just below, in PROP.

       VST will first ask us to first show the
       invariant at the start of the loop
       *)

      forward_loop
      (dijk_forloop_inv g sh src dist_ptr prev_ptr priq_ptr graph_ptr)
      break: (dijk_forloop_break_inv g sh src dist_ptr prev_ptr priq_ptr graph_ptr).
      + unfold dijk_forloop_inv.
        Exists (upd_Znth src (@list_repeat V (Z.to_nat size) inf) src).
        Exists (upd_Znth src (@list_repeat V (Z.to_nat size) inf) 0).
        Exists (upd_Znth src (@list_repeat V (Z.to_nat size) inf) 0).
        Exists (@nil V).
        repeat rewrite <- upd_Znth_map; entailer!;
          clear H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11.
        split3; [| |split3; [| |split]].
        * apply (dijkstra_correct_nothing_popped g src); trivial.
        * rewrite upd_Znth_same; trivial.
        * rewrite upd_Znth_same; trivial.
        * intros; rewrite find_src; ulia.
        * intros. split; [inversion 1 | intros; exfalso].
          destruct (Z.eq_dec src v).
          -- subst src. rewrite upd_Znth_same in H2; ulia.
          -- apply (vvalid_meaning g) in H1.
             rewrite upd_Znth_diff in H2
               by (try rewrite Zlength_list_repeat; ulia).
             rewrite Znth_list_repeat_inrange in H2; trivial.
             rewrite Z.add_1_r in H2.
             apply (Z.neq_succ_diag_l inf). lia.

        * split3; red; apply Forall_upd_Znth;
            try apply Forall_list_repeat; ulia.

      + (* Now the body of the while loop begins. *)
        unfold dijk_forloop_inv.
        Intros prev priq dist popped.
        rename H4 into H_popped_src_1.
        rename H5 into H_popped_src_2.
        rename H6 into H_popped_priq_link.
        rename H7 into H4.
        rename H8 into H5.
        rename H9 into H6.
        rename H10 into H7.
        assert_PROP (Zlength priq = size).
        { entailer!. now repeat rewrite Zlength_map in *. }
        assert_PROP (Zlength prev = size).
        { entailer!. now repeat rewrite Zlength_map in *. }
        assert_PROP (Zlength dist = size).
        { entailer!. now repeat rewrite Zlength_map in *. }

        forward_call ((pointer_val_val priq_ptr), priq).
        1: split3; [| |split3]; ulia.
        forward_if. (* checking if it's time to break *)
        * (* No, don't break. *)
          rename H11 into Htemp.
          assert (@isEmpty inf priq = Vzero). {
            destruct (@isEmptyTwoCases inf priq);
              rewrite H11 in Htemp; simpl in Htemp;
                now inversion Htemp.
          }
          clear Htemp.
          forward_call ((pointer_val_val priq_ptr), priq).
          1: split3; [| |split3; [| |split]]; ulia.

          Intros u.
          rename H12 into Hequ.
          (* u is the minimally chosen item from the
           "seen but not popped" category of vertices *)

          (* We prove a few useful facts about u: *)
          assert (H_u_valid: vvalid g u). {
            apply (vvalid_meaning g); trivial.
            subst u.
            replace size with (Zlength priq).
            apply find_range.
            apply min_in_list. apply incl_refl.
            destruct priq.
            1: rewrite Zlength_nil in H8; ulia.
            simpl; left; trivial.
          }

          assert (0 <= u < size). {
            apply (vvalid_meaning g) in H_u_valid; trivial.
          }

          assert (~ (In u popped)). {
            intro.
            rewrite H_popped_priq_link in H13; trivial.
            rewrite <- isEmpty_in' in H11.
            destruct H11 as [? [? ?]].
            subst u.
            rewrite Znth_find in H13.
            1: pose proof (fold_min _ _ H11); lia.
            rewrite <- Znth_0_hd by ulia.
            apply min_in_list;
              [ apply incl_refl | apply Znth_In; ulia].
          }

          rewrite Znth_0_hd; [|ulia].
          do 2 rewrite upd_Znth_map.

          assert (Htemp: 0 <= u < Zlength dist) by lia.
          pose proof (Znth_dist_cases _ _ Htemp H6).
          clear Htemp.

          (* This is the priq array with which
           we will enter the for loop.
           The dist and prev arrays are the same.
           Naturally, going in with this new priq
           and the old dist and prev means that
           dijkstra_correct is currently broken.
           The for loop will repair this and restore
           dijkstra_correct.
           *)
          forward_for_simple_bound
            size
            (dijk_inner_forloop_inv
               g sh src priq dist prev
               dist_ptr prev_ptr priq_ptr graph_ptr).
          -- (* We start the for loop as planned --
              with the old dist and prev arrays,
              and with a priq array where u has been popped *)
            (* We must prove the for loop's invariants for i = 0 *)
            Exists prev.
            Exists (upd_Znth u priq (inf+1)).
            Exists dist.
            Exists (u :: popped).
            repeat rewrite <- upd_Znth_map.
            entailer!.
            remember (find priq
                           (fold_right Z.min (hd 0 priq)
                                       priq) 0) as u.
            clear H15 H16 H17 H18 H19 H20 H21 H22
                  H23 H24 H25 H26 H27 H28.

            split3; [| | split3; [| |split3; [| |split3; [| |split]]]]; trivial.
            ++ intros.
               (* if popped = [], then
                prove inv_popped for [u].
                if popped <> [], then we're set
                *)
               destruct popped eqn:?.
               2: {
                 apply (inv_popped_add_u _ _ _ _ _ _ priq); try ulia.
                 apply H_popped_src_1; inversion 1.
               }
               replace u with src in *.
               2: apply H_popped_src_2; trivial.
               intro.
               simpl in H16; destruct H16; [|lia].
               subst dst; clear H15.
               destruct H14; [left | right].
               ** exfalso. rewrite H14 in H2. ulia.
               ** exists (src, []). split3.
                  --- split3; [| |split3]; trivial.
                      +++ split; trivial.
                      +++ rewrite path_cost.path_cost_zero; ulia.
                      +++ apply Forall_forall.
                          inversion 1.
                  --- unfold path_in_popped.
                      intros.
                      inversion H15.
                      +++ simpl in H16.
                          subst step. simpl; left; trivial.
                      +++ destruct H16 as [? [? _]].
                          inversion H16.
                  --- red. intros. rewrite path_cost.path_cost_zero; try ulia.
                      apply path_cost_pos; trivial.
            ++ intros.
               apply (vvalid_meaning g) in H15.
               apply inv_unpopped_weak_add_unpopped; trivial.

            ++ intros.
               apply (vvalid_meaning g) in H15.
               apply (inv_unseen_weak_add_unpopped g prev _ _ src); trivial.

            ++ intros. clear H15.
               destruct popped eqn:?.
               2: right; apply H_popped_src_1; inversion 1.
               simpl. left. symmetry.
               apply H_popped_src_2; trivial.

            ++ intros. inversion H15.

            ++ apply in_eq.

            ++ intros.
               assert (H16 := H15).
               rewrite (vvalid_meaning g v) in H16.
               split; intros; destruct (Z.eq_dec v u).
               ** subst v; rewrite upd_Znth_same; ulia.
               ** simpl in H17; destruct H17; [ulia|].
                  rewrite upd_Znth_diff; try ulia.
                  apply H_popped_priq_link; trivial.
               ** left; lia.
               ** right.
                  rewrite upd_Znth_diff in H17; try ulia.
                  apply <- H_popped_priq_link; trivial.

            ++ intros.
               assert (dst <> u). {
                 intro. subst dst. apply H16, in_eq.
               }
               assert (0 <= dst < Zlength priq). {
                 rewrite (vvalid_meaning g) in H15; lia.
               }
               rewrite upd_Znth_diff by lia.
               apply H4; trivial.
               apply not_in_cons in H16; destruct H16 as [_ ?];
                 ulia.

            ++ rewrite upd_Znth_Zlength; ulia.

            ++ apply Forall_upd_Znth; ulia.

          -- (* We now begin with the for loop's body *)
            rewrite <- Hequ.
            freeze FR := (data_at _ _ _ _) (data_at _ _ _ _) (data_at _ _ _ _).
            Intros.
            rename H16 into H_inv_popped.
            rename H17 into H_inv_unpopped.
            rename H18 into H_inv_unpopped_weak.
            rename H19 into H_inv_unseen.
            rename H20 into H_inv_unseen_weak.
            rename H21 into H16.
            rename H22 into H17.
            rename H23 into H18.
            rename H24 into H19.
            rename H25 into H20.
            rename H26 into H_priq_popped_link.
            rename H27 into H_priq_dist_link.
            rename H31 into H21.
            rename H32 into H22.
            rename H33 into H23.
            rename H28 into H24.
            rename H29 into H25.
            rename H30 into H26.

            Transparent size.
            forward_call (sh, g, graph_ptr, addresses, u, i).
            Global Opaque size.
            remember (Znth i (Znth u (@graph_to_mat size g id))) as cost.

            assert (H_i_valid: vvalid g i). {
              apply (vvalid_meaning g); trivial.
            }

            rewrite <- elabel_Znth_graph_to_mat in Heqcost; trivial.

            forward_if.
            ++ rename H27 into Htemp.
               assert (0 <= cost <= Int.max_signed / size - 1). {
                 pose proof (edge_representable g (u, i)).
                 rewrite Heqcost in *.
                 apply (valid_edge_bounds g).
                 rewrite (evalid_meaning g). split; trivial.
                 rewrite Int.signed_repr in Htemp; trivial.
               }
               clear Htemp.
               assert (H_ui_valid: evalid g (u,i)). {
                 apply evalid_dijk with (cost0 := cost);
                   trivial.
               }

               assert (0 <= Znth u dist' <= inf). {
                 assert (0 <= u < Zlength dist') by lia.
                 apply (sublist.Forall_Znth _ _ _ H28) in H23.
                 assumption.
               }
               assert (0 <= Znth i dist' <= inf). {
                 assert (0 <= i < Zlength dist') by lia.
                 apply (sublist.Forall_Znth _ _ _ H29) in H23.
                 assumption.
               }
               assert (0 <= Znth u dist' + cost <= Int.max_signed). {
                 (* IMPORTANT:
                  the key point where
                  we were forced to lower
                  inf's upper bound
                  *)
                 pose proof (inf_further_restricted g).
                 lia.
               }
               thaw FR.
               forward. forward. forward_if.

               ** rename H31 into H_improvement.
                  (* We know that we are definitely
                   going to make edits in the arrays:
                   we have found a better path to i, via u *)
                  rename H28 into Htemp.
                  assert (H28: 0 <= Znth u dist' < inf) by lia.
                  clear Htemp.

                  assert (H_i_not_popped: ~ In i (popped')). {
                    apply (not_in_popped g src u i cost prev' dist'); trivial.
                  }
                  assert (Htemp : 0 <= i < Zlength dist') by lia.
                  pose proof (Znth_dist_cases i dist' Htemp H23).
                  clear Htemp.
                  rename H31 into icases.
                  rewrite <- H_priq_dist_link in icases; trivial.

                  forward. forward. forward.
                  forward; rewrite upd_Znth_same; trivial.
                  1: entailer!.
                  1,3: repeat rewrite Zlength_map; lia.
                  forward_call ((pointer_val_val priq_ptr), i,
                                (Znth u dist' + cost), priq').

(* Now we must show that the for loop's invariant
   holds if we take another step,
   ie when i increments

   We will provide the arrays as they stand now:
   with the i'th cell updated in all three arrays,
   to log a new improved path via u
 *)
                  1: split; [|red]; rep_lia.

                  Exists (upd_Znth i prev' u).
                  Exists (upd_Znth i priq' (Znth u dist' + cost)).
                  Exists (upd_Znth i dist' (Znth u dist' + cost)).
                  Exists popped'.
                  repeat rewrite <- upd_Znth_map.
                  entailer!.

                  clear H31 H32 H33 H34 H35 H36
                        H37 H38 H39 H40 H41 H42.

                  remember (find priq (fold_right Z.min (hd 0 priq)
                                                  priq) 0) as u.

                  remember (Znth u dist' + elabel g (u, i)) as newcost.
                  fold V in *. simpl id in *.
                  rewrite <- Heqnewcost in *.

                  assert (u <> i) by (intro; subst; lia).

                  split3; [| | split3;
                               [| | split3;
                                    [| | split3;
                                         [| |split3;
                                             [| | split3]]]]]; intros.
                  (* 13 goals, where the 13th is
                   3 range-based goals together *)
                  --- apply inv_popped_newcost; ulia.
                  --- apply inv_unpopped_newcost with (priq0 := priq');
                        ulia.
                  --- now apply inv_unpopped_weak_newcost.
                  --- apply inv_unseen_newcost; ulia.
                  --- apply inv_unseen_weak_newcost; ulia.
                  --- rewrite upd_Znth_diff; try lia;
                        intro; subst src; lia.
                  --- rewrite upd_Znth_diff; try lia;
                        intro; subst src; lia.
                  --- assert (H33 := H32).
                      rewrite (vvalid_meaning g) in H33.
                      split; intros; destruct (Z.eq_dec v i).
                      +++ exfalso. subst v.
                          apply H_i_not_popped; trivial.
                      +++ rewrite upd_Znth_diff; try ulia.
                          apply H_priq_popped_link; trivial.
                      +++ exfalso. subst v.
                          rewrite upd_Znth_same in H34; ulia.
                      +++ rewrite upd_Znth_diff in H34; try ulia.
                          apply <- H_priq_popped_link; trivial.
                  --- destruct (Z.eq_dec dst i).
                      1: subst dst; repeat rewrite upd_Znth_same; ulia.
                      repeat rewrite upd_Znth_diff; trivial; try lia.
                      apply H_priq_dist_link; trivial.
                      all: rewrite (vvalid_meaning g) in H32; ulia.
                  --- rewrite upd_Znth_Zlength; ulia.
                  --- rewrite upd_Znth_Zlength; ulia.
                  --- rewrite upd_Znth_Zlength; ulia.
                  --- split3; apply Forall_upd_Znth; ulia.

               ** (* This is the branch where we didn't
                   make a change to the i'th vertex. *)
                 rename H31 into H_non_improvement.
                 forward.
                 (* The old arrays are just fine. *)
                 Exists prev' priq' dist' popped'.
                 entailer!.
                 remember (find priq (fold_right Z.min
                                                 (hd 0 priq) priq) 0) as u.

                 clear H31 H32 H33 H34 H35 H36
                       H37 H38 H39 H40 H41 H42 H43.

                 assert (elabel g (u, i) < inf). {
                   apply Z.le_lt_trans with (m := Int.max_signed / size - 1);
                     trivial.
                   apply H27.
                   apply (inf_further_restricted g).
                 }
                 split3; [| |split].
                 --- intros. apply inv_unpopped_new_dst
                               with (u0 := u) (i0 := i); trivial.
                 --- intros. destruct (Z.eq_dec dst i).
                     +++ subst dst. lia.
                     +++ apply H_inv_unpopped_weak; lia.
                 --- intros. destruct (Z.eq_dec dst i).
                     2: apply H_inv_unseen; lia.

                     unfold inv_unseen; intros.
                     subst dst.

                     assert (i <= i < size) by lia.
                     destruct (Z.eq_dec m u).
                     2: now apply (H_inv_unseen_weak _ H38) with (m:=m).
                     subst m.
                     rename p2m into p2u.
                     rewrite H34 in H_non_improvement.
                     assert (0 <= u < size) by lia.
                     rewrite path_cost_glue_one_step.
                     destruct H37 as [_ [_ [_ [? _]]]].
                     simpl id in *. ulia.
                 --- intros.
                     assert (i <= dst < size) by lia.
                     apply H_inv_unseen_weak; trivial.
            ++  (* i was not a neighbor of u.
                 We must prove the for loop's invariant holds *)
              forward.
              Exists prev' priq' dist' popped'.
              thaw FR.
              entailer!.
              remember (find priq (fold_right Z.min (hd 0 priq) priq) 0) as u.
              clear H28 H29 H30 H31 H32 H33
                    H34 H35 H36 H37 H38 H39 H40.

              rewrite <- inf_eq in H27. rewrite Int.signed_repr in H27.
              2: apply edge_representable.
              split3; [| |split]; intros.
              ** destruct (Z.eq_dec dst i).
                 --- subst dst.
(* Will need to use the second half of the
   for loop's invariant.
   Whatever path worked for i then will
   continue to work for i now:
   i cannot be improved by going via u
 *)
                     unfold inv_unpopped; intros.
                     assert (i <= i < size) by lia.
                     destruct (H_inv_unpopped_weak i H31 H29 H30).
                     1: left; trivial.
                     destruct H32 as [? [[? [? [? [? [? ?]]]]]?]].
                     remember (Znth i prev') as mom.

                     assert (Znth mom dist' < inf). {
                       pose proof (edge_cost_pos g (mom, i)).
                       ulia.
                     }

                     right. split3; [| |split3; [| |split3]]; trivial.

                     intros.
                     destruct (@Znth_dist_cases inf mom' dist')
                       as [e | e]; trivial.
                     1: apply (vvalid_meaning g) in H41; ulia.
                     1: { rewrite e.
                          pose proof (edge_cost_pos g (mom', i)).
                          ulia.
                     }

                     destruct (zlt (Znth mom' dist' +
                                    elabel g (mom', i)) inf).
                     2: ulia.

                     destruct (Z.eq_dec mom' u).
                     1: { subst mom'.
                          assert (0 <= Znth u dist'). {
                            apply (sublist.Forall_Znth _ _ u) in H23.
                            simpl in H23. apply H23.
                            lia.
                          }
                          simpl id in *. ulia.
                     }
                     apply H39; trivial.
                 --- apply H_inv_unpopped; lia.
              ** destruct (Z.eq_dec dst i);
                   [| apply H_inv_unpopped_weak]; lia.
              ** destruct (Z.eq_dec dst i).
                 2: apply H_inv_unseen; lia.
                 subst dst.
                 assert (i <= i < size) by lia.
                 unfold inv_unseen; intros.
                 destruct (Z.eq_dec m u).
                 2: now apply (H_inv_unseen_weak _ H29)
                   with (m:=m).

                 subst m.
                 assert (0 <= Znth u dist'). {
                   apply (sublist.Forall_Znth _ _ u) in H23.
                   apply H23.
                   ulia.
                 }
                 rewrite path_cost_glue_one_step.
                 destruct H34 as [? _].
                 pose proof (path_cost_pos _ _ H34).
                 simpl id in *. ulia.
              ** apply H_inv_unseen_weak; lia.
          -- (* From the for loop's invariant,
              prove the while loop's invariant. *)
            Intros prev' priq' dist' popped'.
            Exists prev' priq' dist' popped'.
            entailer!.
            remember (find priq (fold_right Z.min (hd 0 priq) priq) 0)
              as u.
            unfold dijkstra_correct.
            split3; [auto | apply H16 | apply H18];
              try rewrite <- (vvalid_meaning g); trivial.

        * (* After breaking from the while loop,
           prove break's postcondition *)
          assert (@isEmpty inf priq = Vone). {
            destruct (@isEmptyTwoCases inf priq); trivial;
              rewrite H12 in H11; simpl in H11; now inversion H11.
          }
          clear H11.
          forward. Exists prev priq dist popped.
          entailer!.
          pose proof (@isEmptyMeansInf inf priq).
          rewrite H26 in H12.
          rewrite Forall_forall in H12 |- *.
          intros. specialize (H12 _ H27). lia.
      + (* from the break's postcon, prove the overall postcon *)
        unfold dijk_forloop_break_inv.
        Intros prev priq dist popped.
        freeze FR := (data_at _ _ _ (pointer_val_val prev_ptr))
                       (data_at _ _ _ (pointer_val_val dist_ptr))
                       (SpaceAdjMatGraph _ _ _ _).
        forward_call (Tsh, priq_ptr, size, priq).
        entailer!.
        thaw FR.
        forward.
        Exists prev dist popped. entailer!.
        intros. destruct (H2 _ H10) as [? _]; trivial.
  Qed.

End DijkstraProof.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(*
neuron ~ node (threshold)
synapse ~ edge (weights, delays)

=> neuron has a "potential"
=> after a synapse fires, weight is added or subtracted to neuron potential
=> potential >= threshold -> "fire" each outgoing synapse and resets potential
=> "leak" -> potentials settle to base value over time

inputs => fire events (time + weight) to input neurons
outputs => times that output neurons fire

how to program:
1. A) define a graph of synapses connecting neurons
   B) set input + output neurons
2. send input spikes of specified weights at discrete time intervals
3. read outputs

Example AND with leak
(node1, node2, weight, delay)
("A", "A&B", 0.5, 1)
("B", "A&B", 0.5, 1)

Example OR with leak
(node1, node2, weight, delay)
("A", "A|B", 1, 1)
("B", "A|B", 1, 1)
*)
Add LoadPath "lib" as Lib.
Require Import Arith List String Logic ZArith.
Import ListNotations.
Open Scope Z_scope.
Open Scope string_scope.

Module Neuromorphic.
(*
Some assumptions we will make:
    1) All synapses have delay = 1
    2) Potential starts at 0
*)

(* the only constructor for neuron takes a name and threshold *)
Inductive Neuron : Type :=
neuron : string -> Z -> Neuron.
Definition neuron_name (n : Neuron) : string :=
    match n with
    | neuron x _ => x
    end.
Definition neuron_thresh (n : Neuron) : Z :=
    match n with
    | neuron _ x => x
    end.

(* two neurons are equivalent if their names are the same, i.e. thresholds are ignored *)
Definition neuron_eq (n1 n2 : Neuron) : bool :=
    let v1 := neuron_name n1 in
    let v2 := neuron_name n2 in
    if string_dec v1 v2 then true else false.
Example neuron_eq_correct1: neuron_eq (neuron "abc" 5) (neuron "abc" 5) = true.
Proof. auto. Qed.
Example neuron_eq_correct2: neuron_eq (neuron "abc" 5) (neuron "abc" (-1)) = true.
Proof. auto. Qed.
Example neuron_eq_correct3: neuron_eq (neuron "abc" 5) (neuron "def" 5) = false.
Proof. auto. Qed.

(*
potentials is a list of (Neuron, potential)
this allows us to look up a Neuron and get it's current potential
potentials ~ registers in that they are storing a value for us that we can query

we can set potential to n           (set)
we can set potential to 0           (reset)
we can set potential to curr + n    (add)
*)
Definition potentials := list (Neuron * Z).
Definition set_potential (p: potentials) (x: Neuron) (n: Z) : potentials :=
    cons (x, n) p.
Definition reset_potential (p: potentials) (x: Neuron) : potentials :=
    cons (x, 0) p.
Fixpoint plookup (p: potentials) (x: Neuron) : Z :=
    match p with
    | nil => 0 (* we state that potential starts at 0 *)
    | cons (x', n) p' => if neuron_eq x x' then n else plookup p' x
    end.
Definition add_potential (p: potentials) (x: Neuron) (n: Z) : potentials :=
    set_potential p x ((plookup p x) + n).

(*
graph is a list of synapses (neuron1, neuron2, weight)
each pair represents a directed edge from neuron1 --> neuron2
__this list should never change during the execution of a program__

slookup returns a list of synapses that fire as a result of the firing of neuron n
each synapse is represented in the list by the destination neuron and weight
*)
Definition graph := list (Neuron * Neuron * Z).
Definition set_synapse (g: graph) (n1: Neuron) (n2: Neuron) (w: Z) : graph :=
    cons (n1, n2, w) g.
Definition out_synapses := list (Neuron * Z).
Fixpoint slookup (g: graph) (n: Neuron) : out_synapses :=
    match g with
    | nil => nil
    | cons (n1, n2, w) g' =>
        let recurse := slookup g' n in
        if neuron_eq n n1 then cons (n2, w) recurse else recurse
    end.

(*
direct encoding of binary values
true is represented by potential >= threshold
false is represented by potential < threshold
*)
Definition encode (p: potentials) (x: Neuron) (b: bool) : potentials :=
    if b then set_potential p x (neuron_thresh x) else reset_potential p x.
Definition decode (p: potentials) (x: Neuron) : bool :=
    plookup p x >=? (neuron_thresh x).

Definition encode_test := neuron "*" 3.
Example encode_correct: forall b, plookup (encode [] encode_test b) encode_test = if b then 3 else 0.
Proof. destruct b; auto. Qed.

(*
Define our state as a combination of the current potentials of all neurons and
the synapses defining our graph
*)
Inductive state : Type :=
    pair : potentials -> graph -> state.
Definition get_potentials (s : state) : potentials :=
    match s with
    | pair x _ => x
    end.
Definition get_graph (s : state) : graph :=
    match s with
    | pair _ x => x
    end.

(* update the potential of a neuron in a given state *)
Definition update_state (st : state) (x : Neuron) (p : Z) : state :=
    pair (set_potential (get_potentials st) x p) (get_graph st).

End Neuromorphic.


(** * POrderSet.v : Library for partial orders with sets. *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality.

From Coq Require Import Relations Classical.

From Babel Require Export POrderFacility SetFacility.

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

(*#########################################################*)
(** ** power set as poset, with subset order*)

Module SubsetOrder.
Section OrderDef.

(** inclusion order (subset) *)
Definition poset_mixin (T : Type): Poset.mixin_of 𝒫(T) :=
    Poset.Mixin {|
      ord_refl := subset_refl;
      ord_trans := subset_trans;
      ord_antisym := subset_asymm;
    |}.

Canonical poset_type (T : Type) := Poset 𝒫(T) (poset_mixin T).

(** Directly construction of complete lattice. *)
Definition clattice_essence (T : Type) : CLattice.essence_of 𝒫(T).
Proof.
    constructor.
    refine (@CLattice.JoinEssence _ big_union _) => A.
    apply lubP; split. by apply bigU_ub. by apply bigU_lub.
    refine (@CLattice.MeetEssence _ big_itsct _) => A.
    apply glbP; split. by apply bigI_lb. by apply bigI_glb.
Defined.

Definition AUX_clattice_type (T : Type) := CLattice 𝒫(T)
            (CLattice.essence_to_mixin (clattice_essence T)).

Definition lattice_mixin (T : Type) : Lattice.mixin_of (Poset.class 𝒫(T)) :=
    Lattice.class [lattice of AUX_clattice_type T].

Canonical lattice_type (T : Type) := Lattice 𝒫(T) (lattice_mixin T).

Definition clattice_mixin (T : Type) : CLattice.mixin_of (Lattice.class 𝒫(T)) :=
    CLattice.class [clattice of AUX_clattice_type T].

Canonical clattice_type (T : Type) := CLattice 𝒫(T) (clattice_mixin T).

Canonical cpo_type (T : Type) : cpo := CPO 𝒫(T) (CPO.class [cpo of [clattice of 𝒫(T)]]).

(*########################################################################*)
(** prove that certain operators are continuous *)

(** monotonicity of mapR *)
Definition mapR_monotonicMixin {X Y: Type} (f : X -> Y) :
    MonotonicFun.mixin_of (f [<]).
Proof.
    rewrite /MonotonicFun.mixin_of => //= A B HAinB. by apply mapR_mor_sub.
Qed.

Canonical mapR_monotonicType {X Y: Type} (f : X -> Y) :=
    MonotonicFun (f [<]) (@mapR_monotonicMixin _ _ f).

(** continuity of mapR *)
Definition mapR_continuousMixin {X Y: Type} (f : X -> Y) :
    ContinuousFun.mixin_of (MonotonicFun.class (f [<])).
Proof.
    rewrite /ContinuousFun.mixin_of /CPO.join_op => //= c.
    equal_f_comp c. rewrite -[LHS]fun_assoc -[RHS]fun_assoc.
    by rewrite mapR_bigU_swapF.
Qed.

Canonical mapR_continuousType {X Y: Type} (f : X -> Y) :=
    ContinuousFun (f[<]) (@mapR_continuousMixin _ _ f).

(** monotonicity of bigU *)

Definition bigU_monotonicMixin {X : Type} :
    MonotonicFun.mixin_of (@big_union X).
Proof.
    rewrite /MonotonicFun.mixin_of => //= A B. by apply bigU_mor_sub.
Qed.

Canonical bigU_monotonicType (X : Type) :=
    MonotonicFun big_union (@bigU_monotonicMixin X).

(** continuity of bigU *)

Definition bigU_continuousMixin {X : Type} :
    ContinuousFun.mixin_of (MonotonicFun.class (@big_union X)).
Proof.
    (** Coq自动帮我算出来了我要证明什么。这是辅助证明的一大好处。*)
    rewrite /ContinuousFun.mixin_of /CPO.join_op //= => c.
    (** 来一点神奇的咒语…… *)
    equal_f_comp c. rewrite -[LHS]fun_assoc -[RHS]fun_assoc.
    by rewrite bigU_swapF.
Qed.

Canonical bigU_continuousType {X : Type} :=
    ContinuousFun big_union (@bigU_continuousMixin X).

End OrderDef.

(** Import this module to use the subset poset canonical structures. *)
Module CanonicalStruct.

Canonical poset_type.
Canonical lattice_type.
Canonical cpo_type.
Canonical clattice_type.
Canonical mapR_monotonicType.
Canonical mapR_continuousType.
Canonical bigU_monotonicType.
Canonical bigU_continuousType.

End CanonicalStruct.

End SubsetOrder.


Require Export List.

Inductive ltree (A : Set) : Set :=
  lnode: A -> list (ltree A) ->  ltree A .

Section define_iter_list.
Variables (A B : Set) (f : A ->  B) (op : B -> B ->  B) (e : B).

Fixpoint iter_list (l : list A) : B :=
 match l with   nil => e
               | a :: tl => op (f a) (iter_list tl) end.

End define_iter_list.
Implicit Arguments iter_list.

(* It is hard to explain, but if we define iter_list outside a section
  then the following definition is not accepted. *)

Fixpoint lcount (A : Set) (t : ltree A) {struct t} : nat :=
 match t with lnode a l => iter_list (lcount A) plus 1 l end.

(* Here is an alternative definition of iter_list that cannot
   be used to define lcount by replacing iter_list with iter_list'.
   It is a well-known property of guarded definitions for structural
   recursion that objects with the same type cannot be interchanged.
   Here the function cannot be used because recursive calls to
   iter_list' contain instances of f that are not applied to arguments.
   It is thus impossible to check whether these instances satisfy a
   structural guard condition. *)

Fixpoint iter_list' (A B : Set) (f : A ->  B) (op : B -> B ->  B) (e : B)
                    (l : list A) {struct l} : B :=
 match l with
   nil => e
  | a :: tl => op (f a) (iter_list' A B f op e tl)
 end.
Implicit Arguments iter_list'.