(* (c) Copyright Microsoft Corporation and Inria. You may distribute   *)
(* under the terms of either the CeCILL-B License or the CeCILL        *)
(* version 2 License, as specified in the README file.                 *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

(*****************************************************************************)
(* This file contains the definitions of:                                    *)
(*  - choiceType : interface for type with choice operator                   *)
(*  - countType : interface for countable type                               *)
(* In addition to the lemmas relevant to these definitions, this file also   *)
(* contains definitions of Canonical Structure of choiceType for nat and     *)
(* subtype / option type / seq type / sigma type of a choice type. It also   *)
(* contains definitions of Canonical Structure of countType for nat, bool    *)
(* and subtype / option type / seq type / sigma type of a countable type and *)
(* sum and prod types of two countable types.                                *)
(*****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Technical definitions about coding and decoding of  list. This results are*)
(* useful for the definition of Canonical Structure of choice and countable  *)
(* types. *)

Module CodeSeq.

(* Goedel-style one-to-one encoding of seq T into T, for T := nat    *)
(* and T := seq (seq T0). Note that there is no such encoding in     *)
(* general for T := seq T0, since seq void ~ unit while              *)
(* seq (seq void) ~ nat.                                             *)

Module Nat.

(* The code for [:: n1; ...; nk] has binary representation           *)
(*     1 0 ... 0 1 ... 1 0 ... 0 1 0 ... 0                           *)
(*       <----->         <----->   <----->                           *)
(*        nk 0s           n2 0s     n1 0s                            *)

Definition code := foldr (fun n m => 2 ^ n * m.*2.+1) 0.

Fixpoint decode_rec (v q r : nat) {struct q} :=
  match q, r with
  | 0, _         => [:: v]
  | q'.+1, 0     => v :: [rec 0, q', q']
  | q'.+1, 1     => [rec v.+1, q', q']
  | q'.+1, r'.+2 => [rec v, q', r']
  end where "[ 'rec' v , q , r ]" := (decode_rec v q r).

Definition decode n := if n is 0 then [::] else [rec 0, n.-1, n.-1].

Lemma decodeK : cancel decode code.
Proof.
have m2s: forall n, n.*2 - n = n by move=> n; rewrite -addnn addnK.
case=> //= n; rewrite -[n.+1]mul1n -(expn0 2) -{3}[n]m2s.
elim: n {2 4}n {1 3}0 => [|q IHq] [|[|r]] v //=; rewrite {}IHq ?mul1n ?m2s //.
by rewrite expnSr -mulnA mul2n.
Qed.

Lemma codeK : cancel code decode.
Proof.
elim=> //= v s IHs; rewrite -[_ * _]prednK ?muln_gt0 ?expn_gt0 //=.
rewrite -{3}[v]addn0; elim: v {1 4}0 => [|v IHv {IHs}] q.
  rewrite mul1n /= -{1}addnn -{4}IHs; move: (_ s) {IHs} => n.
  by elim: {1 3}n => //=; case: n.
rewrite expnS -mulnA mul2n -{1}addnn -[_ * _]prednK ?muln_gt0 ?expn_gt0 //.
by rewrite doubleS addSn /= addSnnS; elim: {-2}_.-1 => //=.
Qed.

End Nat.

Module Seq2.
Section Seq2.

Variable T : Type.

(* Auxiliary functions that pad s2 : seq (seq T) with leading [::], *)
(* compute the padding, and strip it.                               *)
(* To encode a sequence we flatten its contents and prepend padding *)
(* whose length encodes (via Nat.code) the shape of the sequence.   *)
(* More precisely code for a sequence s3 with shape sh == shape s3  *)
(* and contents sc == flatten s3 is:                                *)
(*  - pad (Nat.code sh) [::]        if sc = [::]                    *)
(*  - pad (Nat.code sh) (strip sc)  if sc has padding               *)
(*  - pad (Nat.code (behead sh)) sc if sc != [::] has no padding    *)
(* The omitted padding/shape can be readily reconstructed; it is    *)
(* obviously necessary to delete the padding to avoid confusion     *)
(* with the shape encoding; beheading the shape makes the encoding  *)
(* one-to-one (otherwise, the contents following the padding could  *)
(* never exceed the capacity of the shape encoded by the padding.   *)

Definition pad n s2 : seq (seq T) := ncons n [::] s2.

Definition padding := find [pred s : seq T | size s > 0].

Definition strip s2 := drop (padding s2) s2.

Lemma stripK : forall s2, pad (padding s2) (strip s2) = s2.
Proof. by elim=> [|[]] //= s2 ->. Qed.

Lemma padKl : forall n s2, padding (pad n (strip s2)) = n.
Proof. by move=> n s2; elim: n => /= [|n -> //]; elim: s2 => [|[]]. Qed.

Lemma padKr : forall n s2, strip (pad n (strip s2)) = strip s2.
Proof. by move=> n s2; rewrite /strip padKl nconsK. Qed.

Definition code s3 :=
  let sh := shape s3 in let s2' := strip (flatten s3) in
  pad (Nat.code (drop (maxn (sumn sh) 1 <= size s2') sh)) s2'.

Definition decode s2 :=
  let: (sh', s2') := let n := padding s2 in (Nat.decode n, drop n s2) in
  let m := sumn sh' in let m' := size s2' in
  reshape (ncons (maxn m 1 <= m') (m' - m) sh') (pad (m - m') s2').

Lemma codeK : cancel code decode.
Proof.
rewrite /code => s3; set sh := shape s3; set s2' := strip _.
rewrite /decode padKl nconsK Nat.codeK.
case le_s2': (maxn (sumn sh) 1 <= size s2'); last first.
  rewrite drop0 le_s2' /= -size_flatten size_drop subKn ?find_size // stripK.
  exact: flattenK.
move: le_s2'; rewrite !leq_maxl size_drop size_flatten -/sh andbC subn_gt0.
case/andP=> lt_sh; rewrite lt_sh -subn_eq0 subKn /s2' /strip; last exact: ltnW.
move/eqP->; rewrite subn0 drop1 drop0; case def_sh: sh lt_sh => //= [n sh'] _.
by rewrite leq_addl addnK addnC -subn_sub subnn -[ncons _ _ _]def_sh flattenK.
Qed.

Lemma decodeK : cancel decode code.
Proof.
rewrite /decode => s2; set sh' := Nat.decode _; set s2' := drop _ _.
set sh := ncons _ _ _; set s3' := pad _ _; have sz_s3': sumn sh = size s3'.
  rewrite size_ncons {s3'}/sh addnC add_sub_maxn leq_maxl andbC.
  case: posnP => [->|_]; first by rewrite max0n.
  case: leqP => [_|lt_m_m'] /=; first by rewrite addnC add_sub_maxn maxnC.
  by apply/eqP; rewrite eq_sym eqn_maxr ltnW.
rewrite /code reshapeKl ?reshapeKr ?{}sz_s3' // padKr size_ncons addnC.
by rewrite add_sub_maxn -maxnA leq_maxl leqnn {sh}nconsK Nat.decodeK stripK.
Qed.

End Seq2.
End Seq2.

End CodeSeq.

Section OtherEncodings.
(* Miscellaneous encodings, option T c-> seq T and T c-> seq (seq T) *)

Variable T : Type.

Definition seq_of_opt := @oapp T _ (nseq 1) [::].
Lemma seq_of_optK : cancel seq_of_opt ohead. Proof. by case. Qed.

Definition seq2_of (x : T) := [::[::x]].
Lemma seq2_ofK : pcancel seq2_of (ohead \o head [::]). Proof. by []. Qed.

End OtherEncodings.

(* Encoding sum and prod into the generic sum (sigT) Type.    *)
(* We didn't require these in eqtype because we defined       *)
(* specialized comparison functions for sum and prod, rather  *)
(* deriving them from sigT. While the encoding for pairs is   *)
(* straightforward, the one for sums must allow for the fact  *)
(* that a canonical structure on {i : I & T_ i} will require  *)
(* T_ i to have a uniform canonical structure. To do this we  *)
(* pass the structure and its coercion to Type explicitly to  *)
(* the encoding, so that the structure will be inferred when  *)
(* the encoding is applied.                                   *)

Section ProdTag.

Variables T1 T2 : Type.

Definition tag_of_pair (p : T1 * T2) :=  @Tagged T1 p.1 (fun _ => T2) p.2.

Definition pair_of_tag (u : {i : T1 & T2}) := (tag u, tagged u).

Lemma tag_of_pairK : cancel tag_of_pair pair_of_tag. Proof. by case. Qed.

Lemma pair_of_tagK : cancel pair_of_tag tag_of_pair. Proof. by case. Qed.

End ProdTag.

Section SumTag.

Variables (sT : Type) (T1 T2 : sT) (sT_sort :> sT -> Type).

Definition summand i := if i then T1 else T2.

Definition tag_of_sum s :=
  match s with
  | inl x => @Tagged _ true [eta summand] x
  | inr y => @Tagged _ false [eta summand] y
  end.

Definition sum_of_tag (u : {i : bool & summand i}) :=
  (if tag u as i return summand i -> _ then inl _ else @inr _ _) (tagged u).

Lemma tag_of_sumK : cancel tag_of_sum sum_of_tag. Proof. by case. Qed.

Lemma sum_of_tagK : cancel sum_of_tag tag_of_sum. Proof. by do 2!case. Qed.

End SumTag.

(* Structures for Types with a choice function, and for Types with   *)
(* countably many elements. The two concepts are closely linked: we  *)
(* indeed make Countable a subclass of Choice, as countable choice   *)
(* is valid in CiC. This apparent redundancy is needed to ensure the *)
(* consistency of the Canonical Structure inference, as the          *)
(* canonical Choice for a given type may differ from the countable   *)
(* choice for its canonical Countable structure, e.g., for options.  *)
(* Nevertheless for most standard datatype constructors, including   *)
(* sums and pairs, Choice can only be satisfied constructively via   *)
(* countability, so in practice we build most Choice and Countable   *)
(* structures simultaneously.                                        *)
(*   For T : choiceType and P : pred T, we have actually two choice  *)
(* functions: xchoose : (exists x, P x) -> T, and choose : T -> T    *)
(*   We always have P (xchoose exP), while P (choose P x0) only if   *)
(* P x0 holds. Both xchoose and choose are extensional in P and do   *)
(* not depend on the witness exP or x0 (provided P x0). Note that    *)
(* xchoose is slightly more powerful, but less convenient to use.    *)
(* The Choice structure actually contains an xchoose function for    *)
(* seq (seq T), as this allows us to derive a Choice structure for   *)
(* seq T (and thus for iter n seq T for any n).                      *)
(*   For T : countType we have two functions:                        *)
(*    pickle : T -> nat, and unpickle : nat -> option T              *)
(* The two functions provide an effective embedding of T in nat: we  *)
(* have pcancel pickle unpickle, i.e., unpickle \o pickle =1 some.   *)
(* The names of the generic functions underline the correspondence   *)
(* with the notion of "Serializable" types in programming languages. *)
(* Note that unpickle needs to be a partial function to account for  *)
(* a possibly empty T (e.g., T = {x | P x}). We derive a pickle_inv  *)
(* function that is an exact inverse to pickle, i.e., we have both   *)
(* pcancel pickle pickle_inv, and ocancel pickle_inv pickle.         *)
(*   Finally, we need to provide a join class to let type inference  *)
(* unify subType and countType class constraints, as we can have     *)
(* a countable subType of an uncountable choiceType (the problem     *)
(* did not arise earlier with eqType or choiceType because in        *)
(* in practice the base type of an Equality/Choice subType is always *)
(* an Equality/Choice Type).                                         *)

Module Choice.

Section Mixin.

Variable T : Type.
Implicit Types P Q : pred T.

Definition xfun := forall P, (exists x, P x) -> T.
Implicit Type f : xfun.

Definition correct f := forall P xP, P (f P xP).
Definition extensional f := forall P Q xP xQ, P =1 Q -> f P xP = f Q xQ.

Record mixin_of : Type := Mixin {
  xchoose : xfun;
  xchooseP : correct xchoose;
  eq_xchoose : extensional xchoose
}.

End Mixin.

Record class_of (T : Type) : Type :=
  Class { base :> Equality.class_of T; ext2 : mixin_of (seq (seq T)) }.

Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.

Definition pack := let k T c m := Pack (Class c m) T in Equality.unpack k.

Section PcanMixin.

Variables (T sT : Type) (m : mixin_of T) (f : sT -> T) (f' : T -> option sT).
Hypothesis fK : pcancel f f'.

Section Xfun.

Variables (sP : pred sT) (xsP : exists x, sP x).

Lemma pcan_xchoose_proof : exists x, oapp sP false (f' x).
Proof. by case: xsP => x sPx; exists (f x); rewrite fK. Qed.

Lemma pcan_xchoose_sig :
  {x | Some x = f' (xchoose m pcan_xchoose_proof) & sP x}.
Proof.
by case def_x: (f' _) (xchooseP m pcan_xchoose_proof) => //= [x]; exists x.
Qed.

Definition pcan_xchoose := s2val pcan_xchoose_sig.

Lemma pcan_xchooseP : sP pcan_xchoose.
Proof. exact: (s2valP' pcan_xchoose_sig). Qed.

End Xfun.

Lemma eq_pcan_xchoose : extensional pcan_xchoose.
Proof.
move=> sP sQ exsP exsQ eqsPQ; apply: (_ : injective some) => [? ? [] //|].
rewrite !(s2valP (pcan_xchoose_sig _)); congr f'; apply: eq_xchoose.
by case/f'=> //=.
Qed.

Definition PcanMixin := Mixin pcan_xchooseP eq_pcan_xchoose.

End PcanMixin.

Coercion ext0 T m := PcanMixin (ext2 m) (@seq2_ofK T).

Definition CanMixin2 T sT f f' (fK : @cancel _ (seq (seq sT)) f f') :=
  PcanMixin (ext2 (class T)) (can_pcan fK).

(* Construct class_of T directly from an encoding seq (seq T) c-> nat.  *)
(* This is used to build a Choice base class for Countable types.       *)

Lemma nat_xchooseP : correct ex_minn.
Proof. by move=> P xP; case: ex_minnP. Qed.

Lemma eq_nat_xchoose : extensional ex_minn.
Proof.
move=> P Q xP xQ eqPQ; do 2![case: ex_minnP] => m Pm min_m n Qn min_n {xP xQ}.
by apply/eqP; rewrite eqn_leq min_m ?min_n ?eqPQ // -eqPQ.
Qed.

Definition natMixin T := @PcanMixin nat T (Mixin nat_xchooseP eq_nat_xchoose).

Coercion eqType cT := Equality.Pack (class cT) cT.

End Choice.

Notation choiceType := Choice.type.
Notation ChoiceMixin := Choice.Mixin.
Notation ChoiceType := Choice.pack.
Canonical Structure Choice.eqType.

Notation "[ 'choiceType' 'of' T 'for' cT ]" :=
    (@Choice.repack cT (@Choice.Pack T) T)
  (at level 0, format "[ 'choiceType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'choiceType' 'of' T ]" :=
    (Choice.repack (fun c => @Choice.Pack T c) T)
  (at level 0, format "[ 'choiceType'  'of'  T ]") : form_scope.

Section ChoiceTheory.

Variable T : choiceType.
Implicit Types P Q : pred T.

Definition xchoose := Choice.xchoose (Choice.class T).

Lemma xchooseP : Choice.correct xchoose.
Proof. exact: Choice.xchooseP. Qed.

Lemma eq_xchoose : Choice.extensional xchoose.
Proof. exact: Choice.eq_xchoose. Qed.

Definition choose P x0 :=
  if insub x0 : {? x | P x} is Some (exist x Px) then
    xchoose (ex_intro [eta P] x Px)
  else x0.

Lemma chooseP : forall P x0, P x0 -> P (choose P x0).
Proof. by move=> P x0 Px0; rewrite /choose (insubT P Px0) xchooseP. Qed.

Lemma choose_id : forall P x0 y0, P x0 -> P y0 -> choose P x0 = choose P y0.
Proof.
rewrite /choose => P x0 y0 Px0 Py0.
rewrite (insubT P Px0) (insubT P Py0) /=; exact: eq_xchoose.
Qed.

Lemma eq_choose : forall P Q, P =1 Q -> choose P =1 choose Q.
Proof.
rewrite /choose => P Q eqPQ x0.
do [case: insubP; rewrite eqPQ] => [[x Px] Qx0 _| ?]; last by rewrite insubN.
rewrite (insubT Q Qx0); exact: eq_xchoose.
Qed.

Definition PcanChoiceMixin sT f f' (fK : @pcancel T sT f f') :=
  Choice.CanMixin2 (mapK (map_pK fK)).

Definition CanChoiceMixin sT f f' (fK : @cancel T sT f f') :=
  PcanChoiceMixin (can_pcan fK).

Section SubChoice.

Variables (P : pred T) (sT : subType P).

Definition sub_choiceMixin := PcanChoiceMixin (@valK T P sT).
Canonical Structure sub_choiceType := Eval hnf in ChoiceType sub_choiceMixin.

End SubChoice.

End ChoiceTheory.

Prenex Implicits xchoose choose.

Notation "[ 'choiceMixin' 'of' T 'by' <: ]" :=
    (sub_choiceMixin _ : Choice.mixin_of (seq (seq T)))
  (at level 0, format "[ 'choiceMixin'  'of'  T  'by'  <: ]") : form_scope.

(* Canonical Structure of choiceType *)
Section SomeChoiceTypes.

Variables (T : choiceType) (P : pred T).

Definition seq_choiceMixin := Choice.CanMixin2 (@CodeSeq.Seq2.codeK T).
Canonical Structure seq_choiceType := Eval hnf in ChoiceType seq_choiceMixin.

Definition option_choiceMixin := CanChoiceMixin (@seq_of_optK T).
Canonical Structure option_choiceType :=
  Eval hnf in ChoiceType option_choiceMixin.

Definition sig_choiceMixin := [choiceMixin of {x | P x} by <:].
Canonical Structure sig_choiceType := Eval hnf in ChoiceType sig_choiceMixin.

End SomeChoiceTypes.

Module Countable.

Record mixin_of (T : Type) : Type := Mixin {
  pickle : T -> nat;
  unpickle : nat -> option T;
  pickleK : pcancel pickle unpickle
}.

Section PickleSeq.

Variables (T : Type) (p : T -> nat) (u : nat -> option T).
Hypothesis pK : pcancel p u.

Definition pickle_seq s := CodeSeq.Nat.code (map p s).

Definition unpickle_seq n := Some (pmap u (CodeSeq.Nat.decode n)).

Lemma pickle_seqK : pcancel pickle_seq unpickle_seq.
Proof. by move=> s; rewrite /unpickle_seq CodeSeq.Nat.codeK map_pK. Qed.

End PickleSeq.

Definition ChoiceMixin T m :=
  Choice.natMixin (pickle_seqK (pickle_seqK (@pickleK T m))).

Definition EqMixin T m := PcanEqMixin (@pickleK T m).

Record class_of (T : Type) : Type :=
  Class { base :> Choice.class_of T; ext :> mixin_of T }.

Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.

Definition pack := let k T c m := Pack (Class c m) T in Choice.unpack k.

Definition eqType cT := Equality.Pack (class cT) cT.
Coercion choiceType cT := Choice.Pack (class cT) cT.

End Countable.

Notation countType := Countable.type.
Notation CountType := Countable.pack.
Notation CountMixin := Countable.Mixin.
Notation CountChoiceMixin := Countable.ChoiceMixin.
Canonical Structure Countable.eqType.
Canonical Structure Countable.choiceType.

Definition unpickle T := Countable.unpickle (Countable.class T).
Definition pickle T := Countable.pickle (Countable.class T).
Implicit Arguments unpickle [T].
Prenex Implicits pickle unpickle.

Notation "[ 'countType' 'of' T 'for' cT ]" :=
    (@Countable.repack cT (@Countable.Pack T) T)
 (at level 0, format "[ 'countType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'countType' 'of' T ]" :=
    (Countable.repack (fun c => @Countable.Pack T c) T)
  (at level 0, format "[ 'countType'  'of'  T ]") : form_scope.

Section CountableTheory.

Variable T : countType.

Lemma pickleK : @pcancel nat T pickle unpickle.
Proof. exact: Countable.pickleK. Qed.

Definition pickle_inv n :=
  obind (fun x : T => if pickle x == n then Some x else None) (unpickle n).

Lemma pickle_invK : ocancel pickle_inv pickle.
Proof.
by rewrite /pickle_inv => n; case def_x: (unpickle n) => //= [x]; case: eqP.
Qed.

Lemma pickleK_inv : pcancel pickle pickle_inv.
Proof. by rewrite /pickle_inv => x; rewrite pickleK /= eqxx. Qed.

Lemma pcan_pickleK : forall sT f f',
  @pcancel T sT f f' -> pcancel (pickle \o f) (pcomp f' unpickle).
Proof. by move=> sT f f' fK x; rewrite /pcomp pickleK /= fK. Qed.

Definition PcanCountMixin sT f f' (fK : pcancel f f') :=
  @CountMixin sT _ _ (pcan_pickleK fK).

Definition CanCountMixin sT f f' (fK : cancel f f') :=
  @PcanCountMixin sT _ _ (can_pcan fK).

Definition sub_countMixin P sT := PcanCountMixin (@valK T P sT).

Definition seq_countMixin := CountMixin (Countable.pickle_seqK pickleK).
Canonical Structure seq_countType := Eval hnf in CountType seq_countMixin.

End CountableTheory.

Notation "[ 'countMixin' 'of' T 'by' <: ]" :=
    (sub_countMixin _ : Countable.mixin_of T)
  (at level 0, format "[ 'countMixin'  'of'  T  'by'  <: ]") : form_scope.

Section SubCountType.

Variables (T : choiceType) (P : pred T).
Import Countable.

Structure subCountType : Type :=
  SubCountType {subCount_sort :> subType P; _ : mixin_of subCount_sort}.

Coercion sub_countType (sT : subCountType) :=
  Eval hnf in pack (let: SubCountType _ m := sT return mixin_of sT in m).
Canonical Structure sub_countType.

Definition SubCountType_for sT :=
  let k _ c eqU :=
    let: Class _ m := c in
    (let: erefl in _ = U := eqU return mixin_of U -> _ in @SubCountType sT) m
  in unpack k.

End SubCountType.

Definition ereflType := @erefl Type.

(* This assumes that T has both countType and subType structures. *)
Notation "[ 'subCountType' 'of' T ]" := (SubCountType_for (ereflType T))
  (at level 0, format "[ 'subCountType'  'of'  T ]") : form_scope.

Section TagCountType.

Variables (I : countType) (T_ : I -> countType).
Import CodeSeq.Nat.

Definition tag_pickle (u : {i : I & T_ i}) :=
  let: existS i x := u in code [:: pickle i; pickle x].

Definition tag_unpickle n :=
  if decode n is [:: ni; nx] then
    obind (fun i => omap (@Tagged I i T_) (unpickle nx)) (unpickle ni)
  else None.

Lemma tag_pickleK : pcancel tag_pickle tag_unpickle.
Proof. by case=> i x; rewrite /tag_unpickle codeK /= pickleK /= pickleK. Qed.

Definition tag_countMixin := CountMixin tag_pickleK.
Definition tag_choiceMixin := CountChoiceMixin tag_countMixin.
Canonical Structure tag_choiceType := Eval hnf in ChoiceType tag_choiceMixin.
Canonical Structure tag_countType := Eval hnf in CountType tag_countMixin.

End TagCountType.

(* Canonical Structure of countType *)
Section CanonicalCount.

Variables (T T1 T2 : countType) (P : pred T).

Lemma unit_pickleK : pcancel (fun _ => 0) (fun _ => Some tt).
Proof. by case. Qed.
Definition unit_countMixin := CountMixin unit_pickleK.
Definition unit_choiceMixin := CountChoiceMixin unit_countMixin.
Canonical Structure unit_choiceType := Eval hnf in ChoiceType unit_choiceMixin.
Canonical Structure unit_countType := Eval hnf in CountType unit_countMixin.

Lemma bool_pickleK : pcancel nat_of_bool (some \o leq 1). Proof. by case. Qed.
Definition bool_countMixin := CountMixin bool_pickleK.
Definition bool_choiceMixin := CountChoiceMixin bool_countMixin.
Canonical Structure bool_choiceType := Eval hnf in ChoiceType bool_choiceMixin.
Canonical Structure bool_countType := Eval hnf in CountType bool_countMixin.

Lemma nat_pickleK : pcancel id (@Some nat). Proof. by []. Qed.
Definition nat_countMixin := CountMixin nat_pickleK.
Definition nat_choiceMixin := CountChoiceMixin nat_countMixin.
Canonical Structure nat_choiceType := Eval hnf in ChoiceType nat_choiceMixin.
Canonical Structure nat_countType := Eval hnf in CountType nat_countMixin.

Definition pos_nat_choiceMixin := [choiceMixin of pos_nat by <:].
Canonical Structure pos_nat_choiceType :=
  Eval hnf in ChoiceType pos_nat_choiceMixin.
Definition pos_nat_countMixin := [countMixin of pos_nat by <:].
Canonical Structure pos_nat_countType :=
  Eval hnf in CountType pos_nat_countMixin.
Canonical Structure pos_nat_subCountType :=
  Eval hnf in [subCountType of pos_nat].

Canonical Structure bitseq_choiceType := Eval hnf in [choiceType of bitseq].
Canonical Structure bitseq_countType :=  Eval hnf in [countType of bitseq].

Definition option_countMixin :=
  CountMixin (pcan_pickleK (can_pcan (@seq_of_optK T))).
Canonical Structure option_countType :=
  Eval hnf in CountType option_countMixin.

Definition sig_countMixin := [countMixin of {x | P x} by <:].
Canonical Structure sig_countType := Eval hnf in CountType sig_countMixin.
Canonical Structure sig_subCountType :=
  Eval hnf in [subCountType of {x | P x}].

Definition prod_countMixin := CanCountMixin (@tag_of_pairK T1 T2).
Definition prod_choiceMixin := CountChoiceMixin prod_countMixin.
Canonical Structure prod_choiceType := Eval hnf in ChoiceType prod_choiceMixin.
Canonical Structure prod_countType := Eval hnf in CountType prod_countMixin.

Definition sum_countMixin := CanCountMixin (@tag_of_sumK _ T1 T2 id).
Definition sum_choiceMixin := CountChoiceMixin sum_countMixin.
Canonical Structure sum_choiceType := Eval hnf in ChoiceType sum_choiceMixin.
Canonical Structure sum_countType := Eval hnf in CountType sum_countMixin.

End CanonicalCount.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto. (* Import the Verifiable C system *)
Require Import VST.progs64.sumarray. (* Import the AST of this C program *)
(* The next line is "boilerplate", always required after importing an AST. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(* Functional spec of this program.  *)
Definition sum_Z : list Z -> Z := fold_right Z.add 0.

Lemma sum_Z_app:
  forall a b, sum_Z (a++b) =  sum_Z a + sum_Z b.
Proof.
  intros. induction a; simpl; lia.
Qed.

Definition sumarray_spec : ident * funspec :=
 DECLARE _sumarray
  WITH a: val, sh : share, contents : list Z, size: Z
  PRE [ (tptr tuint), tint ]
          PROP  (readable_share sh; 0 <= size <= Int.max_signed;
                 Forall (fun x => 0 <= x <= Int.max_unsigned) contents)
          PARAMS (a; Vint (Int.repr size))
          GLOBALS () (*TODO: make this line optional, ie insert GLOBALx nil during parsing of notation.
                          Currently, omitting the line leads to failaure of start_function, specifically of compute_close_precondition_eq *)
          SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a)
  POST [ tuint ]
        PROP () LOCAL(temp ret_temp  (Vint (Int.repr (sum_Z contents))))
           SEP (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a).

(* Note: It would also be reasonable to let [contents] have type [list int].
  Then the [Forall] would not be needed in the PROP part of PRE.
*)

(* The precondition of "int main(void){}" always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr (1+2+3+4))))
     SEP(TT).

(* Note: It would also be reasonable to let [contents] have type [list int].
  Then the [Forall] would not be needed in the PROP part of PRE.
*)

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
        ltac:(with_library prog [sumarray_spec; main_spec]).

(** Proof that f_sumarray, the body of the sumarray() function,
 ** satisfies sumarray_spec, in the global context (Vprog,Gprog).
 **)
Lemma body_sumarray: semax_body Vprog Gprog f_sumarray sumarray_spec.
Proof.
start_function. (* Always do this at the beginning of a semax_body proof *)
(* The next two lines do forward symbolic execution through
   the first two executable statements of the function body *)
forward.  (* i = 0; *)
forward.  (* s = 0; *)
(* To do symbolic execution through a [while] loop, we must
 * provide a loop invariant, so we use [forward_while] with
 * the invariant as an argument .*)
forward_while
 (EX i: Z,
   PROP  (0 <= i <= size)
   LOCAL (temp _a a;
          temp _i (Vint (Int.repr i));
          temp _n (Vint (Int.repr size));
          temp _s (Vint (Int.repr (sum_Z (sublist 0 i contents)))))
   SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a)).
(* forward_while leaves four subgoals; here we label them
   with the * bullet. *)
* (* Prove that current precondition implies loop invariant *)
Exists 0.   (* Instantiate the existential on the right-side of |--   *)
entailer!.  (* Simplify this entailment as much as possible; in this
      case, it solves entirely; in other cases, entailer! leaves subgoals *)
* (* Prove that loop invariant implies typechecking condition *)
entailer!.  (* Typechecking conditions usually solve quite easily *)
* (* Prove postcondition of loop body implies loop invariant *)
(* In order to get to the postcondition of the loop body, of course,
   we must forward-symbolic-execute through the loop body;
   so we start that here. *)
(* "forward" fails and tells us to first make (0 <= i < Zlength contents)
   provable by auto, so we assert the following: *)
assert_PROP (Zlength contents = size). {
  entailer!. do 2 rewrite Zlength_map. reflexivity.
}
forward. (* x = a[i] *)
forward. (* s += x; *)
forward. (* i++; *)
 (* Now we have reached the end of the loop body, and it's
   time to prove that the _current precondition_  (which is the
   postcondition of the loop body) entails the loop invariant. *)
 Exists (i+1).
 entailer!. simpl.
 f_equal.
 rewrite (sublist_split 0 i (i+1)) by lia.
 rewrite sum_Z_app. rewrite (sublist_one i) by lia.
 autorewrite with sublist. normalize.
 simpl. rewrite Z.add_0_r. reflexivity.
* (* After the loop *)
forward.  (* return s; *)
 (* Here we prove that the postcondition of the function body
    entails the postcondition demanded by the function specification. *)
entailer!.
autorewrite with sublist in *.
autorewrite with sublist.
reflexivity.
Qed.

(* Contents of the extern global initialized array "_four" *)
Definition four_contents := [1; 2; 3; 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_call (*  s = sumarray(four,4); *)
  (gv _four, Ews,four_contents,4).
 repeat constructor; computable.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
  prove_semax_prog.
  semax_func_cons body_sumarray.
  semax_func_cons body_main.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Abelian_group_cat.
Require Export Group_facts.
(** Title "Lemmas on abelian groups, monoids, semi-groups." *)
Section Sgroup.
Variable S : ABELIAN_SGROUP.

Lemma ABELIAN_SGROUP_com :
 forall x y : S, Equal (sgroup_law _ x y) (sgroup_law _ y x).
exact (abelian_sgroup_com_prf S).
Qed.

Lemma ABELIAN_SGROUP_permute :
 forall x y z : S,
 Equal (sgroup_law _ x (sgroup_law _ y z))
   (sgroup_law _ y (sgroup_law _ x z)).
intros x y z; try assumption.
apply Trans with (sgroup_law S (sgroup_law S x y) z); auto with algebra.
apply Trans with (sgroup_law S (sgroup_law S y x) z); auto with algebra.
apply SGROUP_comp; auto with algebra.
apply ABELIAN_SGROUP_com.
Qed.

Lemma ABELIAN_SGROUP4 :
 forall x y z t : S,
 Equal (sgroup_law _ (sgroup_law _ x y) (sgroup_law _ z t))
   (sgroup_law _ (sgroup_law _ x z) (sgroup_law _ y t)).
intros x y z t; try assumption.
apply Trans with (sgroup_law S x (sgroup_law S y (sgroup_law S z t)));
 auto with algebra.
apply Trans with (sgroup_law S x (sgroup_law S (sgroup_law S y z) t));
 auto with algebra.
apply Trans with (sgroup_law S x (sgroup_law S (sgroup_law S z y) t));
 auto with algebra.
apply SGROUP_comp; auto with algebra.
apply SGROUP_comp; auto with algebra.
apply ABELIAN_SGROUP_com.
apply Trans with (sgroup_law S x (sgroup_law S z (sgroup_law S y t)));
 auto with algebra.
Qed.
End Sgroup.
Hint Immediate ABELIAN_SGROUP_com ABELIAN_SGROUP_permute ABELIAN_SGROUP4:
  algebra.
Section Monoid.
Variable M : ABELIAN_MONOID.

Lemma ABELIAN_MONOID_com :
 forall x y : M, Equal (sgroup_law _ x y) (sgroup_law _ y x).
change
  (forall x y : M:ABELIAN_SGROUP, Equal (sgroup_law _ x y) (sgroup_law _ y x))
 in |- *; auto with algebra.
Qed.

Lemma ABELIAN_MONOID_permute :
 forall x y z : M,
 Equal (sgroup_law _ x (sgroup_law _ y z))
   (sgroup_law _ y (sgroup_law _ x z)).
change
  (forall x y z : M:ABELIAN_SGROUP,
   Equal (sgroup_law _ x (sgroup_law _ y z))
     (sgroup_law _ y (sgroup_law _ x z))) in |- *;
 auto with algebra.
Qed.

Lemma ABELIAN_MONOID4 :
 forall x y z t : M,
 Equal (sgroup_law _ (sgroup_law _ x y) (sgroup_law _ z t))
   (sgroup_law _ (sgroup_law _ x z) (sgroup_law _ y t)).
change
  (forall x y z t : M:ABELIAN_SGROUP,
   Equal (sgroup_law _ (sgroup_law _ x y) (sgroup_law _ z t))
     (sgroup_law _ (sgroup_law _ x z) (sgroup_law _ y t)))
 in |- *; auto with algebra.
Qed.
End Monoid.
Hint Immediate ABELIAN_MONOID_com ABELIAN_MONOID_permute ABELIAN_MONOID4:
  algebra.
Section Group.
Variable G : ABELIAN_GROUP.

Lemma ABELIAN_GROUP_com :
 forall x y : G, Equal (sgroup_law _ x y) (sgroup_law _ y x).
change
  (forall x y : G:ABELIAN_SGROUP, Equal (sgroup_law _ x y) (sgroup_law _ y x))
 in |- *; auto with algebra.
Qed.

Lemma ABELIAN_GROUP_permute :
 forall x y z : G,
 Equal (sgroup_law _ x (sgroup_law _ y z))
   (sgroup_law _ y (sgroup_law _ x z)).
change
  (forall x y z : G:ABELIAN_SGROUP,
   Equal (sgroup_law _ x (sgroup_law _ y z))
     (sgroup_law _ y (sgroup_law _ x z))) in |- *;
 auto with algebra.
Qed.

Lemma ABELIAN_GROUP4 :
 forall x y z t : G,
 Equal (sgroup_law _ (sgroup_law _ x y) (sgroup_law _ z t))
   (sgroup_law _ (sgroup_law _ x z) (sgroup_law _ y t)).
change
  (forall x y z t : G:ABELIAN_SGROUP,
   Equal (sgroup_law _ (sgroup_law _ x y) (sgroup_law _ z t))
     (sgroup_law _ (sgroup_law _ x z) (sgroup_law _ y t)))
 in |- *; auto with algebra.
Qed.
End Group.
Hint Immediate ABELIAN_GROUP_com ABELIAN_GROUP_permute ABELIAN_GROUP4:
  algebra.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Extraction to Ocaml: conversion from/to [big_int] *)

(** NB: The extracted code should be linked with [nums.cm(x)a]
    from ocaml's stdlib and with the wrapper [big.ml] that
    simplifies the use of [Big_int] (it can be found in the sources
    of Coq). *)

Require Coq.extraction.Extraction.

Require Import Arith ZArith.

Parameter bigint : Type.
Parameter bigint_zero : bigint.
Parameter bigint_succ : bigint -> bigint.
Parameter bigint_opp : bigint -> bigint.
Parameter bigint_twice : bigint -> bigint.

Extract Inlined Constant bigint => "Big.big_int".
Extract Inlined Constant bigint_zero => "Big.zero".
Extract Inlined Constant bigint_succ => "Big.succ".
Extract Inlined Constant bigint_opp => "Big.opp".
Extract Inlined Constant bigint_twice => "Big.double".

Definition bigint_of_nat : nat -> bigint :=
 (fix loop acc n :=
  match n with
   | O => acc
   | S n => loop (bigint_succ acc) n
  end) bigint_zero.

Fixpoint bigint_of_pos p :=
 match p with
  | xH => bigint_succ bigint_zero
  | xO p => bigint_twice (bigint_of_pos p)
  | xI p => bigint_succ (bigint_twice (bigint_of_pos p))
 end.

Fixpoint bigint_of_z z :=
 match z with
  | Z0 => bigint_zero
  | Zpos p => bigint_of_pos p
  | Zneg p => bigint_opp (bigint_of_pos p)
 end.

Fixpoint bigint_of_n n :=
 match n with
  | N0 => bigint_zero
  | Npos p => bigint_of_pos p
 end.

(** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and
    [pos_of_bigint] are total and return zero (resp. one) for
    non-positive inputs. *)

Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A.
Extract Constant bigint_natlike_rec => "Big.nat_rec".

Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S.

Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A.
Extract Constant bigint_poslike_rec => "Big.positive_rec".

Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH.

Parameter bigint_zlike_case :
 forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A.
Extract Constant bigint_zlike_case => "Big.z_rec".

Definition z_of_bigint : bigint -> Z :=
 bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i))
                        (fun i => Zneg (pos_of_bigint i)).

Definition n_of_bigint : bigint -> N :=
 bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0).

(* Tests:

Definition small := 1234%nat.
Definition big := 12345678901234567890%positive.

Definition nat_0 := nat_of_bigint (bigint_of_nat 0).
Definition nat_1 := nat_of_bigint (bigint_of_nat small).
Definition pos_1 := pos_of_bigint (bigint_of_pos 1).
Definition pos_2 := pos_of_bigint (bigint_of_pos big).
Definition n_0 := n_of_bigint (bigint_of_n 0).
Definition n_1 := n_of_bigint (bigint_of_n 1).
Definition n_2 := n_of_bigint (bigint_of_n (Npos big)).
Definition z_0 := z_of_bigint (bigint_of_z 0).
Definition z_1 := z_of_bigint (bigint_of_z 1).
Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)).
Definition z_m1 := z_of_bigint (bigint_of_z (-1)).
Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)).

Definition test :=
 (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2).
Definition check :=
 (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big).

Extraction "/tmp/test.ml" check test.

... and we check that test=check
*)