(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(** * Typeclass-based relations, tactics and standard instances

   This is the basic theory needed to formalize morphisms and setoids.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Export Coq.Classes.Init.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.Relations.Relation_Definitions.

Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.

(** We allow to unfold the [relation] definition while doing morphism search. *)

Section Defs.
  Context {A : Type}.

  (** We rebind relational properties in separate classes to be able to overload each proof. *)

  Class Reflexive (R : relation A) :=
    reflexivity : forall x : A, R x x.

  Definition complement (R : relation A) : relation A := fun x y => R x y -> False.

  (** Opaque for proof-search. *)
  Typeclasses Opaque complement.

  (** These are convertible. *)
  Lemma complement_inverse R : complement (flip R) = flip (complement R).
  Proof. reflexivity. Qed.

  Class Irreflexive (R : relation A) :=
    irreflexivity : Reflexive (complement R).

  Class Symmetric (R : relation A) :=
    symmetry : forall {x y}, R x y -> R y x.

  Class Asymmetric (R : relation A) :=
    asymmetry : forall {x y}, R x y -> R y x -> False.

  Class Transitive (R : relation A) :=
    transitivity : forall {x y z}, R x y -> R y z -> R x z.

  (** Various combinations of reflexivity, symmetry and transitivity. *)

  (** A [PreOrder] is both Reflexive and Transitive. *)

  Class PreOrder (R : relation A) : Prop := {
    PreOrder_Reflexive :> Reflexive R | 2 ;
    PreOrder_Transitive :> Transitive R | 2 }.

  (** A [StrictOrder] is both Irreflexive and Transitive. *)

  Class StrictOrder (R : relation A) : Prop := {
    StrictOrder_Irreflexive :> Irreflexive R ;
    StrictOrder_Transitive :> Transitive R }.

  (** By definition, a strict order is also asymmetric *)
  Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R.
  Proof. firstorder. Qed.

  (** A partial equivalence relation is Symmetric and Transitive. *)

  Class PER (R : relation A) : Prop := {
    PER_Symmetric :> Symmetric R | 3 ;
    PER_Transitive :> Transitive R | 3 }.

  (** Equivalence relations. *)

  Class Equivalence (R : relation A) : Prop := {
    Equivalence_Reflexive :> Reflexive R ;
    Equivalence_Symmetric :> Symmetric R ;
    Equivalence_Transitive :> Transitive R }.

  (** An Equivalence is a PER plus reflexivity. *)

  Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 :=
    { }.

  (** An Equivalence is a PreOrder plus symmetry. *)

  Global Instance Equivalence_PreOrder {R} `(E:Equivalence R) : PreOrder R | 10 :=
    { }.

  (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *)

  Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) :=
    antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.

  Class subrelation (R R' : relation A) : Prop :=
    is_subrelation : forall {x y}, R x y -> R' x y.

  (** Any symmetric relation is equal to its inverse. *)

  Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R.
  Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed.

  Section flip.

    Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R).
    Proof. tauto. Qed.

    Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) :=
      irreflexivity (R:=R).

    Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) :=
      fun x y H => symmetry (R:=R) H.

    Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) :=
      fun x y H H' => asymmetry (R:=R) H H'.

    Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) :=
      fun x y z H H' => transitivity (R:=R) H' H.

    Program Definition flip_Antisymmetric `(Antisymmetric eqA R) :
      Antisymmetric eqA (flip R).
    Proof. firstorder. Qed.

    (** Inversing the larger structures *)

    Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R).
    Proof. firstorder. Qed.

    Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R).
    Proof. firstorder. Qed.

    Lemma flip_PER `(PER R) : PER (flip R).
    Proof. firstorder. Qed.

    Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R).
    Proof. firstorder. Qed.

  End flip.

  Section complement.

    Definition complement_Irreflexive `(Reflexive R)
      : Irreflexive (complement R).
    Proof. firstorder. Qed.

    Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R).
    Proof. firstorder. Qed.
  End complement.

  (** Rewrite relation on a given support: declares a relation as a rewrite
   relation for use by the generalized rewriting tactic.
   It helps choosing if a rewrite should be handled
   by the generalized or the regular rewriting tactic using leibniz equality.
   Users can declare an [RewriteRelation A RA] anywhere to declare default
   relations. This is also done automatically by the [Declare Relation A RA]
   commands. *)

  Class RewriteRelation (RA : relation A).

  (** Any [Equivalence] declared in the context is automatically considered
   a rewrite relation. *)

  Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA.

  (** Leibniz equality. *)
  Section Leibniz.
    Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A.
    Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A.
    Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A.

    (** Leibinz equality [eq] is an equivalence relation.
        The instance has low priority as it is always applicable
        if only the type is constrained. *)

    Global Program Instance eq_equivalence : Equivalence (@eq A) | 10.
  End Leibniz.

End Defs.

(** Default rewrite relations handled by [setoid_rewrite]. *)
Instance: RewriteRelation impl.
Instance: RewriteRelation iff.

(** Hints to drive the typeclass resolution avoiding loops
 due to the use of full unification. *)
Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.
Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances.

Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances.
Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.
Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances.
Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances.

Hint Extern 4 (subrelation (flip _) _) =>
  class_apply @subrelation_symmetric : typeclass_instances.

Arguments irreflexivity {A R Irreflexive} [x] _.
Arguments symmetry {A} {R} {_} [x] [y] _.
Arguments asymmetry {A} {R} {_} [x] [y] _ _.
Arguments transitivity {A} {R} {_} [x] [y] [z] _ _.
Arguments Antisymmetric A eqA {_} _.

Hint Resolve irreflexivity : ord.

Unset Implicit Arguments.

(** A HintDb for relations. *)

Ltac solve_relation :=
  match goal with
  | [ |- ?R ?x ?x ] => reflexivity
  | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H
  end.

Hint Extern 4 => solve_relation : relations.

(** We can already dualize all these properties. *)

(** * Standard instances. *)

Ltac reduce_hyp H :=
  match type of H with
    | context [ _ <-> _ ] => fail 1
    | _ => red in H ; try reduce_hyp H
  end.

Ltac reduce_goal :=
  match goal with
    | [ |- _ <-> _ ] => fail 1
    | _ => red ; intros ; try reduce_goal
  end.

Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid.

Ltac reduce := reduce_goal.

Tactic Notation "apply" "*" constr(t) :=
  first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) |
    refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ].

Ltac simpl_relation :=
  unfold flip, impl, arrow ; try reduce ; program_simpl ;
    try ( solve [ dintuition ]).

Local Obligation Tactic := simpl_relation.

(** Logical implication. *)

Program Instance impl_Reflexive : Reflexive impl.
Program Instance impl_Transitive : Transitive impl.

(** Logical equivalence. *)

Instance iff_Reflexive : Reflexive iff := iff_refl.
Instance iff_Symmetric : Symmetric iff := iff_sym.
Instance iff_Transitive : Transitive iff := iff_trans.

(** Logical equivalence [iff] is an equivalence relation. *)

Program Instance iff_equivalence : Equivalence iff.

(** We now develop a generalization of results on relations for arbitrary predicates.
   The resulting theory can be applied to homogeneous binary relations but also to
   arbitrary n-ary predicates. *)

Local Open Scope list_scope.

(** A compact representation of non-dependent arities, with the codomain singled-out. *)

(* Note, we do not use [list Type] because it imposes unnecessary universe constraints *)
Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist.
Local Infix "::" := Tcons.

Fixpoint arrows (l : Tlist) (r : Type) : Type :=
  match l with
    | Tnil => r
    | A :: l' => A -> arrows l' r
  end.

(** We can define abbreviations for operation and relation types based on [arrows]. *)

Definition unary_operation A := arrows (A::Tnil) A.
Definition binary_operation A := arrows (A::A::Tnil) A.
Definition ternary_operation A := arrows (A::A::A::Tnil) A.

(** We define n-ary [predicate]s as functions into [Prop]. *)

Notation predicate l := (arrows l Prop).

(** Unary predicates, or sets. *)

Definition unary_predicate A := predicate (A::Tnil).

(** Homogeneous binary relations, equivalent to [relation A]. *)

Definition binary_relation A := predicate (A::A::Tnil).

(** We can close a predicate by universal or existential quantification. *)

Fixpoint predicate_all (l : Tlist) : predicate l -> Prop :=
  match l with
    | Tnil => fun f => f
    | A :: tl => fun f => forall x : A, predicate_all tl (f x)
  end.

Fixpoint predicate_exists (l : Tlist) : predicate l -> Prop :=
  match l with
    | Tnil => fun f => f
    | A :: tl => fun f => exists x : A, predicate_exists tl (f x)
  end.

(** Pointwise extension of a binary operation on [T] to a binary operation
   on functions whose codomain is [T].
   For an operator on [Prop] this lifts the operator to a binary operation. *)

Fixpoint pointwise_extension {T : Type} (op : binary_operation T)
  (l : Tlist) : binary_operation (arrows l T) :=
  match l with
    | Tnil => fun R R' => op R R'
    | A :: tl => fun R R' =>
      fun x => pointwise_extension op tl (R x) (R' x)
  end.

(** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *)

Fixpoint pointwise_lifting (op : binary_relation Prop)  (l : Tlist) : binary_relation (predicate l) :=
  match l with
    | Tnil => fun R R' => op R R'
    | A :: tl => fun R R' =>
      forall x, pointwise_lifting op tl (R x) (R' x)
  end.

(** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *)

Definition predicate_equivalence {l : Tlist} : binary_relation (predicate l) :=
  pointwise_lifting iff l.

(** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *)

Definition predicate_implication {l : Tlist} :=
  pointwise_lifting impl l.

(** Notations for pointwise equivalence and implication of predicates. *)

Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope.
Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope.

Local Open Scope predicate_scope.

(** The pointwise liftings of conjunction and disjunctions.
   Note that these are [binary_operation]s, building new relations out of old ones. *)

Definition predicate_intersection := pointwise_extension and.
Definition predicate_union := pointwise_extension or.

Infix "/∙\" := predicate_intersection (at level 80, right associativity) : predicate_scope.
Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_scope.

(** The always [True] and always [False] predicates. *)

Fixpoint true_predicate {l : Tlist} : predicate l :=
  match l with
    | Tnil => True
    | A :: tl => fun _ => @true_predicate tl
  end.

Fixpoint false_predicate {l : Tlist} : predicate l :=
  match l with
    | Tnil => False
    | A :: tl => fun _ => @false_predicate tl
  end.

Notation "∙⊤∙" := true_predicate : predicate_scope.
Notation "∙⊥∙" := false_predicate : predicate_scope.

(** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *)

Program Instance predicate_equivalence_equivalence :
  Equivalence (@predicate_equivalence l).

  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    fold pointwise_lifting.
    induction l. firstorder.
    intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)).
    firstorder.
  Qed.

Program Instance predicate_implication_preorder :
  PreOrder (@predicate_implication l).
  Next Obligation.
    induction l ; firstorder.
  Qed.
  Next Obligation.
    induction l. firstorder.
    unfold predicate_implication in *. simpl in *.
    intro. pose (IHl (x x0) (y x0) (z x0)). firstorder.
  Qed.

(** We define the various operations which define the algebra on binary relations,
   from the general ones. *)

Section Binary.
  Context {A : Type}.

  Definition relation_equivalence : relation (relation A) :=
    @predicate_equivalence (_::_::Tnil).

  Global Instance: RewriteRelation relation_equivalence.

  Definition relation_conjunction (R : relation A) (R' : relation A) : relation A :=
    @predicate_intersection (A::A::Tnil) R R'.

  Definition relation_disjunction (R : relation A) (R' : relation A) : relation A :=
    @predicate_union (A::A::Tnil) R R'.

  (** Relation equivalence is an equivalence, and subrelation defines a partial order. *)

  Global Instance relation_equivalence_equivalence :
    Equivalence relation_equivalence.
  Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed.

  Global Instance relation_implication_preorder : PreOrder (@subrelation A).
  Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed.

  (** *** Partial Order.
   A partial order is a preorder which is additionally antisymmetric.
   We give an equivalent definition, up-to an equivalence relation
   on the carrier. *)

  Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
    partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)).

  (** The equivalence proof is sufficient for proving that [R] must be a
   morphism for equivalence (see Morphisms).  It is also sufficient to
   show that [R] is antisymmetric w.r.t. [eqA] *)

  Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R.
  Proof with auto.
    reduce_goal.
    pose proof partial_order_equivalence as poe. do 3 red in poe.
    apply <- poe. firstorder.
  Qed.

  Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R).
  Proof. firstorder. Qed.
End Binary.

Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances.

(** The partial order defined by subrelation and relation equivalence. *)

Program Instance subrelation_partial_order :
  ! PartialOrder (relation A) relation_equivalence subrelation.

Next Obligation.
Proof.
  unfold relation_equivalence in *. compute; firstorder.
Qed.

Typeclasses Opaque arrows predicate_implication predicate_equivalence
            relation_equivalence pointwise_lifting.


Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Lia.
Require Import Metalib.LibTactics.
Require Import Language Tactical.

(** * Definitions *)

Inductive ordinary : type -> Prop :=
| Ord_Top : ordinary Top
| Ord_Tnt : ordinary Int
| Ord_Arr : forall A B,
    ordinary B -> ordinary (Arr A B)
| Ord_Rcd : forall l A,
    ordinary A ->
    ordinary (Rcd l A).

Hint Constructors ordinary : core.

Inductive splitable : type -> type -> type -> Prop :=
| Spl_And : forall A B,
    splitable (And A B) A B
| Spl_Arr : forall A B B1 B2,
    splitable B B1 B2 ->
    splitable (Arr A B) (Arr A B1) (Arr A B2)
| Spl_Rcd : forall l A A1 A2,
    splitable A A1 A2 ->
    splitable (Rcd l A) (Rcd l A1) (Rcd l A2).

Hint Constructors splitable : core.

Notation "A1 ↩ A ↪ A2" := (splitable A A1 A2) (at level 40).

(** * Splitable and Ordinary *)

(** splitable is not ordinary *)

Lemma splitable_not_ordinary :
  forall A A1 A2,
    splitable A A1 A2 -> ~ ordinary A.
Proof.
  introv Spl Ord. gen A1 A2.
  dependent induction Ord; intros; try solve [inversion Spl; eauto | eauto].
Qed.

(** * Automations *)

(** add this lemma to hint base to exclude absurd cases *)

Ltac solve_splitable :=
  match goal with
  | H1: splitable ?A _ _, H2: ordinary ?A |- _ =>
      pose proof (splitable_not_ordinary _ _ _ H1) as Contra; contradiction
  | H1: splitable (Arr _ ?B) _ _, H2: ordinary ?B |- _ =>
      dependent destruction H1;
      pose proof (splitable_not_ordinary _ _ _ H1) as Contra;
      contradiction
  | H1: splitable (Rcd _ ?A) _ _, H2: ordinary ?A |- _ =>
      dependent induction H1;
      pose proof (splitable_not_ordinary _ _ _ H1) as Contra;
      contradiction
  | H: splitable Int _ _ |- _ => inversion H
  | H: splitable Top _ _ |- _ => inversion H
  end.

Hint Extern 5 => solve_splitable : core.

Ltac solve_ordinary :=
  match goal with
  | [H: ordinary (And _ _) |- _] =>
      (inversion H)
  end.

Hint Extern 5 => solve_ordinary : core.

(** [contra_ordinary] solves contradiction cases of ordinary *)

Ltac contra_ordinary :=
  match goal with
  | H1: ordinary ?A, H2: not (ordinary ?A) |- _ => contradiction
  | H1: ordinary (Arr _ ?A), H2: not (ordinary ?A) |- _ =>
      dependent destruction H1; contradiction
  | H1: ordinary (Rcd _ ?A), H2: not (ordinary ?A) |- _ =>
      dependent destruction H1; contradiction
  end.

(** * Splitable or Ordinary *)

(** For any type A, it's [ordinary] or [splitable] **)

Lemma splitable_or_ordinary :
  forall A,
    ordinary A \/ exists A1 A2, splitable A A1 A2.
Proof.
  introv. dependent induction A; eauto.
  - destruct IHA1; destruct IHA2; eauto.
    + right. destruct_conjs; eauto.
    + right. destruct_conjs; eauto.
  - destruct IHA; eauto.
    right. destruct_conjs; eauto.
Qed.

(** * Determinism of Splitable *)

Lemma splitable_determinism :
  forall A A1 A2 A3 A4,
    splitable A A1 A2 -> splitable A A3 A4 ->
    A1 = A3 /\ A2 = A4.
Proof.
  introv Spl1 Spl2. gen A3 A4.
  dependent induction Spl1; eauto; intros.
  - dependent destruction Spl2.
    split; eauto.
  - dependent destruction Spl2.
    split; f_equal; eapply IHSpl1; eauto.
  - dependent induction Spl2.
    split; f_equal; eapply IHSpl1; eauto.
Qed.

(** * Unify Splitable Varialbes *)

(** unify variables into same names *)

Ltac subst_splitable :=
  match goal with
  | H1: splitable ?A ?A1 ?A2, H2: splitable ?A ?A3 ?A4 |- _ =>
      pose proof (splitable_determinism _ _ _ _ _ H1 H2) as Eqs;
      destruct Eqs; subst; clear H1
  end.

(** * Decidablility of Ordinary *)

Lemma ordinary_decidable :
  forall A,
    ordinary A \/ not (ordinary A).
Proof.
  introv. induction A; eauto.
  - destruct IHA1; destruct IHA2; eauto.
    + right. intros Contra. contra_ordinary.
    + right. intros Contra. contra_ordinary.
  - destruct IHA; eauto.
    right. intros Contra. contra_ordinary.
Qed.

(** * Splitable & Size *)

(** If A can split into A1 and A2, the size of A1 and A2 is smaller than A *)

Lemma splitable_decrease_size:
  forall A A1 A2,
    splitable A A1 A2 -> size_type A1 < size_type A /\ size_type A2 < size_type A.
Proof.
  introv H. dependent induction H; simpl; lia.
Qed.


Lemma option_dec : forall A (x:option A), (exists a, x = Some a) \/ x = None.
intros. destruct x; [left;exists a|right];trivial.
Save.
Implicit Arguments option_dec [A].

Definition option_map : forall (A B:Type), (A->B) -> option A -> option B :=
  fun A B f oa => match oa with
  | None => None
  | Some a => Some (f a)
  end.
Implicit Arguments option_map [A B].

Inductive option_incl (A:Type) : option A -> option A -> Prop :=
| o_inc_1 : option_incl A None None
| o_inc_2 : forall a, option_incl A None (Some a)
| o_inc_3 : forall a, option_incl A (Some a) (Some a).
Implicit Arguments option_incl [A].

Lemma option_incl_refl : forall (A:Type) (o:option A), option_incl o o.
intros. destruct o. apply o_inc_3. apply o_inc_1.
Save.

Lemma option_incl_trans : forall (A:Type) (o1 o2 o3:option A), option_incl o1 o2 -> option_incl o2 o3 -> option_incl o1 o3.
intros.
destruct H; inversion H0.
apply o_inc_1. apply o_inc_2. apply o_inc_2. apply o_inc_3.
Save.

Definition option_eq_dec : forall (A:Type) (A_eq_dec:forall (a b:A), {a=b}+{a<>b}) (o1 o2:option A), {o1=o2}+{o1<>o2}.
intros A A_eq_dec. decide equality.
Defined.

Definition option_to_bool : forall A, option A -> bool :=
  fun A o => match o with
  | None => false
  | Some _ => true
  end.
Implicit Arguments option_to_bool [A].

Definition option_mult : forall A, option (option A) -> option A :=
  fun A o => match o with
  | None => None
  | Some f => f
  end.
Implicit Arguments option_mult [A].

Definition option_informative : forall (A:Type) (o:option A), {a:A | o = Some a} + {o = None}.
intros. destruct o. left. exists a. trivial. right. trivial.
Defined.
Implicit Arguments option_informative [A].

Lemma Some_isnt_None : forall (A:Type) x (a:A),
  x = Some a -> x <> None.
unfold not. intros. subst. discriminate.
Save.
Implicit Arguments Some_isnt_None [A x a].


(* Spaces whose points are compact sets
   i.e., some version of Smyth power domains
   See Vickers' *Topology via Logic*

   We should have

   pt : A ~~> P+(A)
   OR : P+(A) * P+(A) ~~> P+(A)

   approx : Approximator A X -> Approximator P+(A) X

   which behaves by arbitrarily choosing an option
   in the powerdomain. *)

(* It appears that there is a formulation of the Smyth powerdomain
   in formal topology in Vickers' 2005
   "Some constructive roads to Tychonoff"
*)

Require Import
  FormTopC.FormTop
  Algebra.SetsC
  Algebra.OrderC
  FormTopC.Join
  FormTopC.Cont.

Set Asymmetric Patterns.
Set Universe Polymorphism.
Local Open Scope Subset.

Module Compact.
Section Defn.

Context {S : PreISpace.t}
        {POS : PreO.t (le S)}.

Definition le := JoinTop.leL (le := le S).

Instance PO : PreO.t le := JoinTop.joinPreO.

Require Import Coq.Lists.List Types.List.
Import ListNotations.

Inductive Splits : list S -> list S -> list S -> Type :=
  | SplitNil : Splits nil nil nil
  | SplitL : forall a {xs ys zs}, Splits xs ys zs
           -> Splits (a :: xs) ys (a :: zs)
  | SplitR : forall b {xs ys zs}, Splits xs ys zs
           -> Splits xs (b :: ys) (b :: zs).

Definition IxS := PreISpace.Ix S.

Inductive Ix {xs : list S} : Type :=
  | MkIx : forall a s : list S, Each IxS a
   -> Splits a s xs -> Ix.

Arguments Ix : clear implicits.

Definition Ixnil : Ix nil.
Proof.
econstructor. apply Each_nil.
apply SplitNil.
Defined.

Inductive KFinite {U : S -> Type} : list S -> Type :=
  | KNil : KFinite nil
  | KCons : forall x, U x -> forall {xs}, KFinite xs -> KFinite (x :: xs).

Arguments KFinite : clear implicits.

Require Import CMorphisms.
Lemma KFinite_Proper_impl : Proper (Same_set ==> eq ==> arrow)
  KFinite.
Proof.
unfold Proper, respectful, arrow. intros.
subst. induction X0. apply KNil.
apply KCons. apply X. assumption. assumption.
Qed.

Instance KFinite_Proper : Proper (Same_set ==> eq ==> iffT)
  KFinite.
Proof.
unfold Proper, respectful. intros. split; intros.
- eapply KFinite_Proper_impl; eassumption.
- eapply KFinite_Proper_impl. symmetry. eassumption.
  symmetry. eassumption. assumption.
Qed.

Definition Each_get {A B} {xs : list A} {x : A}
  (e : Each B xs)
  (mem : member x xs) : B x.
Proof.
induction e.
- inv mem.
- inv mem. assumption. apply IHe. assumption.
Defined.

Definition CS := PreISpace.C S.

Inductive axunion {a : list S} {axioms : Each IxS a}
  : Subset S :=
  | Mkaxunion : forall (s : S) x (el : member x a),
  CS _ (Each_get axioms el) s -> axunion s.

Arguments axunion {a} axioms _.

Lemma axunion_nil_false : forall s,
  axunion Each_nil s -> False.
Proof.
intros. induction X.
inv el.
Qed.

Lemma axunion_nil : axunion Each_nil === fun _ => False.
Proof.
apply Same_set_iff. intros. split; intros.
- eapply axunion_nil_false; eassumption.
- contradiction.
Qed.

Inductive Covering {a s : list S} {axioms : Each IxS a}
  {s' : list S} : Type :=
  | MkCovering : forall t, Splits t s s' ->
    forall u, KFinite (axunion axioms) u -> le t u -> Covering.

Arguments Covering : clear implicits.

Definition C (xs : list S) (split : Ix xs) : Subset (list S) :=
  match split with
  | MkIx a s axioms mem => Covering a s axioms
  end.

Definition CompactPreO : FormTop.PreOrder :=
  {| PO_car := list S
   ; FormTop.le := le |}.

Definition Compact : PreISpace.t :=
  {| PreISpace.S := CompactPreO
   ; PreISpace.Ix := Ix
   ; PreISpace.C := C |}.

Lemma member_le : forall a b, member a b -> [a] <=[Compact] b.
Proof.
intros. simpl. unfold le, JoinTop.leL. intros.
inv X0. Focus 2. inv X1.
exists a. split. reflexivity. assumption.
Qed.

Lemma leS_le : forall a b, a <=[S] b -> [a] <=[Compact] [b].
Proof.
intros. simpl. unfold le, JoinTop.leL. intros.
inv X0. Focus 2. inv X1. exists b. split. assumption.
constructor.
Qed.

Lemma SplitsR_All xs : Splits nil xs xs.
Proof.
induction xs. constructor. constructor. assumption.
Qed.

Lemma Splits_KFinite {U xs ys zs} :
  Splits xs ys zs -> KFinite U xs -> KFinite U ys
  -> KFinite U zs.
Proof.
intros. induction X.
- assumption.
- inv X0. apply KCons. assumption. apply IHX; assumption.
- inv X1. apply KCons. assumption. apply IHX; assumption.
Qed.

Lemma KFinite_nil {xs} :
  KFinite (fun _ : S => False) xs -> xs = nil.
Proof.
intros H. induction H. reflexivity.
contradiction.
Qed.

Lemma le_nil {xs} : le xs [] -> xs = [].
Proof.
intros. induction xs.
- reflexivity.
- unfold le, JoinTop.leL in X.
  destruct (X a here). destruct p. inv m.
Qed.

Lemma Splits_length {xs ys zs} : Splits xs ys zs
  -> length xs + length ys = length zs.
Proof.
intros H. induction H.
- reflexivity.
- simpl. rewrite IHSplits. reflexivity.
- simpl. rewrite <- plus_n_Sm. rewrite IHSplits.
  reflexivity.
Qed.

Lemma Splits_nil {xs} : Splits [] [] xs
  -> xs = [].
Proof.
intros H. apply Splits_length in H. simpl in H.
apply length_zero_iff_nil. symmetry. assumption.
Qed.

Lemma C_nil {xs} : C [] Ixnil xs -> xs = [].
Proof.
simpl. intros.
induction X.
eapply KFinite_Proper in k.
2: symmetry. 2: apply axunion_nil.
2: reflexivity. pose proof (KFinite_nil k).
subst. pose proof (le_nil l). subst.
apply Splits_nil in s. subst.
reflexivity.
Qed.

Hypothesis locS : FormTop.localized S.

Lemma Splits_nil_opp {xs ys} : Splits xs ys []
  -> xs = [] /\ ys = [].
Proof.
intros H. inv H. auto.
Qed.

Require Import Coq.Logic.Eqdep_dec.

Inductive Empty {A} : list A -> Prop :=
  | IsEmpty : Empty [].

Lemma Each_nil_unique_helper {A B} {xs : list A}
  (e : @Each A B xs) :
  match xs as xs' return @Each A B xs' -> Type with
  | [] => fun e => e = Each_nil
  | _ => fun _ => True
  end e.
Proof.
induction e. reflexivity. auto.
Qed.

Lemma Each_nil_unique {A B}
  (e : @Each A B []) : e = Each_nil.
Proof.
apply (Each_nil_unique_helper e).
Qed.

Lemma SplitNil_unique_helper {xs ys zs : list S}
  (s : Splits xs ys zs) :
  (match zs with
  | [] => match xs with
    | [] => match ys with
      | [] => fun e => e = SplitNil
      | _ => fun _ => True
      end
    | _ => fun _ => True
    end
  | _ => fun _ => True
  end) s.
Proof.
induction s; (reflexivity || auto).
Qed.

Lemma SplitNil_unique
  (s : Splits [] [] []) : s = SplitNil.
Proof.
apply (SplitNil_unique_helper s).
Qed.

Lemma Ixnil_unique : forall (i : Ix []), i = Ixnil.
Proof.
intros. induction i. unfold Ixnil.
destruct (Splits_nil_opp s0). subst.
pose proof (Each_nil_unique e). subst.
pose proof (SplitNil_unique s0). subst.
reflexivity.
Qed.

Lemma loc : FormTop.localized Compact.
Proof.
unfold FormTop.localized.
intros.
unfold FormTop.localized in locS.
generalize dependent a.
induction c.
- intros. apply le_nil in X. subst.
  exists Ixnil. intros.
  pose proof (C_nil X). subst.
  exists []. split.
  Focus 2. split; reflexivity.
  pose proof (Ixnil_unique i). subst.
  assumption.
- intros. induction i. simpl.
Abort.

Definition inj : Cont.map S Compact := fun xs x => [x] <=[Compact] xs.

Definition inj_cont : IGCont.t S Compact inj.
Proof.
constructor; intros.
- apply FormTop.grefl. exists [a]. unfold SetsC.In. constructor.
  unfold inj. reflexivity.
- unfold inj in *. apply FormTop.grefl.
  exists [a]. 2: reflexivity. split; assumption.
- unfold inj in *. etransitivity. apply leS_le.
  eassumption. eassumption.
- unfold inj in *. etransitivity; eassumption.
- induction j. simpl. induction a0.
  + apply FormTop.grefl. unfold inj in *.
    exists (a :: s). 2: apply member_le; constructor.
    simpl in X.
    econstructor. apply SplitL. apply SplitsR_All.
    2: eassumption. apply (Splits_KFinite s0).
    apply KNil.
unfold inj in *.
Admitted.

Definition Ix_singleton {a} (i : IxS a) : Ix [a].
Proof.
econstructor. 2: eapply SplitL. 2: econstructor.
econstructor. assumption. econstructor.
Defined.

Axiom undefined : forall A, A.

Require Import CRelationClasses.
Lemma lift_Cov_Ax : forall a (i : IxS a) u,
  CS a i u -> C [a] (Ix_singleton i) [u].
Proof.
intros. simpl. econstructor. apply SplitL. econstructor.
  2: reflexivity. econstructor.
  constructor 1 with a here. apply X.
  constructor.
Qed.

Local Open Scope FT.

Lemma Cov_nil {U} : [] <|[Compact] U.
Proof.
apply FormTop.ginfinity with Ixnil.
simpl. intros. induction X.
  eapply KFinite_Proper in k.
  2: symmetry. 2: apply axunion_nil.
  2: reflexivity. pose proof (KFinite_nil k).
  subst. pose proof (le_nil l). subst.
  apply Splits_nil in s. subst.
Abort.

Lemma Cov_each : forall U (xs : list S),
  (forall x : S, member x xs -> [x] <|[Compact] U)
  -> xs <|[Compact] U.
Proof.
intros. induction xs.
- apply FormTop.ginfinity with Ixnil.
  simpl. intros. induction X0.
  eapply KFinite_Proper in k.
  2: symmetry. 2: apply axunion_nil.
  2: reflexivity. pose proof (KFinite_nil k).
  subst. pose proof (le_nil l). subst.
  apply Splits_nil in s. subst.
Abort.

Lemma lift_Cov : forall a U, a <|[S] U
  -> [a] <|[Compact] Each U.
Proof.
intros.
induction X.
- apply FormTop.grefl. constructor. assumption.
  constructor.
- simpl in *. eapply FormTop.gle_left. 2: eassumption.
  apply leS_le. assumption.
- unshelve eapply FormTop.ginfinity.
  apply Ix_singleton. assumption.
  simpl. intros.
  induction X0.
econstructor.
Abort.

(** This actually doesn't work, because the
    empty compact set is a valid point of the space. *)
Definition nondet_run : forall a U, FormTop.GCov S a U
  -> forall (F : Subset (list S)), IGCont.pt Compact F
  -> SetsC.In F [a] -> { b : S & SetsC.In U b }.
Proof.
intros.
induction X.
- exists a. assumption.
- apply IHX. unfold SetsC.In.
  eapply (IGCont.pt_le_right (T := Compact) (F := F) X0).
  eassumption. apply leS_le. assumption.
- pose proof (IGCont.pt_cov X0 X1 (Ix_singleton i)) as H.
  induction H.
Abort.

End Defn.
End Compact.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.abgroups.Qabgroup.
Require Import CoRN.algebra.CRings.
Require Import CoRN.model.rings.Zring.

Local Open Scope Q_scope.

(**
** Example of a ring: $\langle$#⟨#[Q],[[+]],[[*]]$\rangle$#⟩#
Because [Q] forms an abelian group with addition, a monoid with
multiplication and it satisfies the distributive law, it is a ring.
*)

Lemma Q_mult_plus_is_dist : distributive Qmult_is_bin_fun Qplus_is_bin_fun.
Proof.
 red in |- *.
 simpl in |- *.
 exact Qmult_plus_distr_r.
Qed.

Definition Q_is_CRing : is_CRing Q_as_CAbGroup 1 Qmult_is_bin_fun.
Proof.
 apply Build_is_CRing with Qmult_is_assoc.
    apply Q_mul_is_CMonoid.
   apply Qmult_is_commut.
  apply Q_mult_plus_is_dist.
 apply Q_apart_0_1.
Defined.

Definition Q_as_CRing := Build_CRing _ _ _ Q_is_CRing.

Canonical Structure Q_as_CRing.

(** The following lemmas are used in the proof that [Q] is Archimeadian.
*)

Lemma injz_Nring : forall n,
 nring (R:=Q_as_CRing) n[=]inject_Z (nring (R:=Z_as_CRing) n).
Proof.
 intro n.
 induction  n as [| n Hrecn].
  change (([0]:Q_as_CRing)[=][0]) in |- *.
  apply eq_reflexive_unfolded.
 change (nring (R:=Q_as_CRing) n[+][1][=]inject_Z (nring (R:=Z_as_CRing) n[+][1])) in |- *.
 Step_final ((inject_Z (nring (R:=Z_as_CRing) n):Q_as_CRing)[+][1]).
 astepl ((inject_Z (nring (R:=Z_as_CRing) n):Q_as_CRing)[+] inject_Z ([1]:Z_as_CRing)).
 apply eq_symmetric_unfolded.
 apply injz_plus.
Qed.

Lemma injZ_eq : forall x y : Z, x = y -> (inject_Z x:Q_as_CRing)[=]inject_Z y.
Proof.
 intros.
 unfold inject_Z in |- *.
 simpl in |- *.
 red in |- *.
 simpl in |- *.
 rewrite H; trivial.
Qed.

Lemma nring_Q : forall n : nat, nring (R:=Q_as_CRing) n[=]inject_Z n.
Proof.
 intro n.
 induction  n as [| n Hrecn].
  change (Qmake 0%Z 1%positive==Qmake 0%Z 1%positive) in |- *.
  change ([0][=]([0]:Q_as_CRing)) in |- *.
  apply eq_reflexive_unfolded.
 change (nring (R:=Q_as_CRing) n[+][1][=]inject_Z (S n)) in |- *.
 Step_final ((inject_Z n:Q_as_CRing)[+][1]).
 astepl ((inject_Z n:Q_as_CRing)[+]inject_Z 1).
 simpl in |- *.
 red in |- *.
 unfold Qplus in |- *.
 simpl in |- *.
 rewrite Zpos_mult_morphism in |- *.
 rewrite succ_nat in |- *.
 ring.
Qed.

Lemma zring_Q : forall z, zring (R:=Q_as_CRing) z[=]inject_Z z.
Proof.
 destruct z; simpl; try reflexivity.
  rewrite -> pring_convert.
  rewrite -> nring_Q.
  now rewrite convert_is_POS.
 rewrite -> pring_convert.
 rewrite -> nring_Q.
 unfold Qeq. simpl.
 ring_simplify.
 rewrite min_convert_is_NEG.
 now rewrite Pmult_comm.
Qed.


(* (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
*)