(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.Max.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.
Require Import Coq.Structures.Equalities.

Require Import Coq.FSets.FSets.
Require Import Metalib.CoqListFacts.
Require Import Metalib.FSetExtra.
Require Import Metalib.FSetWeakNotin.
Require Import Metalib.LibTactics.

Require Import Omega.

(* ********************************************************************** *)
(** * Defining atoms *)

(** Atoms are structureless objects such that we can always generate
    one fresh from a finite collection.  Equality on atoms is [eq] and
    decidable.  We use Coq's module system to make abstract the
    implementation of atoms. *)

Module Type ATOM <: UsualDecidableType.

  Parameter atom : Set.
  Definition t := atom.

  Parameter eq_dec : forall x y : atom, {x = y} + {x <> y}.

  Parameter atom_fresh_for_list :
    forall (xs : list t), {x : atom | ~ List.In x xs}.

  Parameter fresh : list atom -> atom.

  Parameter fresh_not_in : forall l, ~ In (fresh l) l.

  Parameter nat_of : atom -> nat.

  Hint Resolve eq_dec.

  Include HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.

End ATOM.

(** The implementation of the above interface is hidden for
    documentation purposes. *)

Module Atom : ATOM.

  (* begin hide *)
  Definition atom := nat.
  Definition t := atom.

  Definition eq_dec := eq_nat_dec.

  Lemma max_lt_r : forall x y z,
    x <= z -> x <= max y z.
  Proof.
    induction x. auto with arith.
    induction y. auto with arith.
      simpl. induction z. omega. auto with arith.
  Qed.

  Lemma nat_list_max : forall (xs : list nat),
    { n : nat | forall x, List.In x xs -> x <= n }.
  Proof.
    induction xs as [ | x xs [y H] ].
    (* case: nil *)
    exists 0. inversion 1.
    (* case: cons x xs *)
    exists (max x y). intros z J. simpl in J. destruct J as [K | K].
      subst. auto with arith.
      auto using max_lt_r.
  Qed.

  Lemma atom_fresh_for_list :
    forall (xs : list nat), { n : nat | ~ List.In n xs }.
  Proof.
    intros xs. destruct (nat_list_max xs) as [x H].
    exists (S x). intros J. lapply (H (S x)). omega. trivial.
  Qed.

  Definition fresh (l : list atom) :=
    match atom_fresh_for_list l with
      (exist _ x _) => x
    end.

  Lemma fresh_not_in : forall l, ~ In (fresh l) l.
  Proof.
    intro l. unfold fresh.
    destruct atom_fresh_for_list. auto.
  Qed.

  Definition nat_of := fun (x : atom) => x.

  Include HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.

  (* end hide *)

End Atom.

(** We make [atom], [fresh], [fresh_not_in] and [atom_fresh_for_list] available
    without qualification. *)

Notation atom := Atom.atom.
Notation fresh := Atom.fresh.
Notation fresh_not_in := Atom.fresh_not_in.
Notation atom_fresh_for_list := Atom.atom_fresh_for_list.

(* Automatically unfold Atom.eq *)
Global Arguments Atom.eq /.

(** It is trivial to declare an instance of [EqDec] for [atom]. *)

Instance EqDec_atom : @EqDec atom eq eq_equivalence.
Proof. exact Atom.eq_dec. Defined.

(* ********************************************************************** *)
(** * Finite sets of atoms *)

(** We use our implementation of atoms to obtain an implementation of
    finite sets of atoms.  We give the resulting type an intuitive
    name, as well as import names of set operations for use within
    this library.  In order to avoid polluting Coq's namespace, we do
    not use [Module Export]. *)

Module Import AtomSetImpl : FSetExtra.WSfun Atom :=
  FSetExtra.Make Atom.

Notation atoms :=
  AtomSetImpl.t.

(** The [AtomSetDecide] module provides the [fsetdec] tactic for
    solving facts about finite sets of atoms. *)

Module Export AtomSetDecide := Coq.FSets.FSetDecide.WDecide_fun Atom AtomSetImpl.

(** The [AtomSetNotin] module provides the [destruct_notin] and
    [solve_notin] for reasoning about non-membership in finite sets of
    atoms, as well as a variety of lemmas about non-membership. *)

Module Export AtomSetNotin := FSetWeakNotin.Notin_fun Atom AtomSetImpl.

(** Given the [fsetdec] tactic, we typically do not need to refer to
    specific lemmas about finite sets.  However, instantiating
    functors from the FSets library makes a number of setoid rewrites
    available.  These rewrites are crucial to developments since they
    allow us to replace a set with an extensionally equal set (see the
    [Equal] relation on finite sets) in propositions about finite
    sets. *)

Module AtomSetFacts := FSetFacts.WFacts_fun Atom AtomSetImpl.
Module AtomSetProperties := FSetProperties.WProperties_fun Atom AtomSetImpl.

Export AtomSetFacts.

(* ********************************************************************** *)
(** * Properties *)

(** For any given finite set of atoms, we can generate an atom fresh
    for it. *)

Lemma atom_fresh : forall L : atoms, { x : atom | ~ In x L }.
Proof.
  intros L. destruct (atom_fresh_for_list (elements L)) as [a H].
  exists a. intros J. contradiction H.
  rewrite <- CoqListFacts.InA_iff_In. auto using elements_1.
Qed.

(* ********************************************************************** *)
(** * Tactic support for picking fresh atoms *)

(* begin hide *)

(** The auxiliary tactic [simplify_list_of_atom_sets] takes a list of
    finite sets of atoms and unions everything together, returning the
    resulting single finite set. *)

Ltac simplify_list_of_atom_sets L :=
  let L := eval simpl in L in
  let L := ltac_remove_dups L in
  let L := eval simpl in (List.fold_right union empty L) in
  match L with
    | context C [union ?E empty] => context C [ E ]
  end.

(* end hide *)

(** [gather_atoms_with F] returns the union of all the finite sets
    [F x] where [x] is a variable from the context such that [F x]
    type checks. *)

Ltac gather_atoms_with F :=
  let apply_arg x :=
    match type of F with
      | _ -> _ -> _ -> _ => constr:(@F _ _ x)
      | _ -> _ -> _ => constr:(@F _ x)
      | _ -> _ => constr:(@F x)
    end in
  let rec gather V :=
    match goal with
      | H : _ |- _ =>
        let FH := apply_arg H in
        match V with
          | context [FH] => fail 1
          | _ => gather (union FH V)
        end
      | _ => V
    end in
  let L := gather empty in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
    sets and returns the same set cleaned up: empty sets are removed
    and items are laid out in a nicely parenthesized way. *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | union ?E1 ?E2 => let Acc2 := go Acc E2 in go Acc2 E1
     | empty => Acc
     | ?E1 => match Acc with
                | empty => E1
                | _ => constr:(union E1 Acc)
              end
     end
  in go empty V.

(** The tactic [pick fresh Y for L] takes a finite set of atoms [L]
    and a fresh name [Y], and adds to the context an atom with name
    [Y] and a proof that [~ In Y L], i.e., that [Y] is fresh for [L].
    The tactic will fail if [Y] is already declared in the context.

    The variant [pick fresh Y] is similar, except that [Y] is fresh
    for "all atoms in the context."  This version depends on the
    tactic [gather_atoms], which is responsible for returning the set
    of "all atoms in the context."  By default, it returns the empty
    set, but users are free (and expected) to redefine it. *)

Ltac gather_atoms :=
  constr:(empty).

Tactic Notation "pick" "fresh" ident(Y) "for" constr(L) :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (atom_fresh L) as [Y Fr]).

Tactic Notation "pick" "fresh" ident(Y) :=
  let L := gather_atoms in
  pick fresh Y for L.

Ltac pick_fresh y :=
  pick fresh y.

(** Example: We can redefine [gather_atoms] to return all the
    "obvious" atoms in the context using the [gather_atoms_with] thus
    giving us a "useful" version of the "[pick fresh]" tactic. *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  constr:(union A B).

Lemma example_pick_fresh_use : forall (x y z : atom) (L1 L2 L3: atoms), True.
(* begin show *)
Proof.
  intros x y z L1 L2 L3.
  pick fresh k.

  (** At this point in the proof, we have a new atom [k] and a
      hypothesis [Fr] that [k] is fresh for [x], [y], [z], [L1], [L2],
      and [L3]. *)

  trivial.
Qed.
(* end show *)


Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.

Local Open Scope logic_base.

Class BasicLogicEquiv (L:Language) (Gamma:LogicEquiv L) := {
  logic_equiv_refl: forall x, x--||--x;
  logic_equiv_symm:forall x y,x --||-- y -> y --||-- x;
  logic_equiv_trans: forall x y z, x --||-- y -> y --||-- z -> x --||-- z}.

Class EquivDerivable1 (L:Language) (GammaD:Derivable1 L) (GammaL:LogicEquiv L): Type :={
  logic_equiv_derivable1:forall x y,x --||-- y <->
                        derivable1 x y /\ derivable1 y x
}.

Section RewriteClass.

Context {L:Language}
        {GammaE: LogicEquiv L}
        {bE: BasicLogicEquiv L GammaE}.

Instance logic_equiv_impp_rewrite: RewriteRelation logic_equiv.
Qed.

Instance logic_equiv_refl_instance: Reflexive logic_equiv.
Proof.
  hnf;intros.
  apply logic_equiv_refl.
Qed.

Instance logic_equiv_symm_instance: Symmetric logic_equiv.
Proof.
  hnf.
  apply logic_equiv_symm.
Qed.

Instance logic_equiv_trans_instance: Transitive logic_equiv.
Proof.
  hnf.
  apply logic_equiv_trans.
Qed.

Instance logic_equiv_trans_equiv: Equivalence logic_equiv.
Proof.
  constructor.
  + apply logic_equiv_refl_instance.
  + apply logic_equiv_symm_instance.
  + apply logic_equiv_trans_instance.
Qed.

Instance logic_equiv_proper_logic_equiv:
  Proper (logic_equiv ==> logic_equiv ==> Basics.impl) logic_equiv.
Proof.
  hnf;intros.
  hnf;intros.
  unfold Basics.flip in H.
  intro.
  pose proof logic_equiv_trans _ _ _ H1 H0.
  pose proof logic_equiv_symm _ _ H.
  pose proof logic_equiv_trans _ _ _ H3 H2. auto.
Qed.

Instance logic_equiv_proper_derivable1
         {GammaD1: Derivable1 L}
         {GammaED1: EquivDerivable1 L GammaD1 GammaE}
         {bD: BasicDeduction L GammaD1}:
  Proper (logic_equiv ==> logic_equiv ==> Basics.impl) derivable1.
Proof.
  hnf; intros.
  hnf; intros.
  hnf; intros.
  apply logic_equiv_derivable1 in H.
  apply logic_equiv_derivable1 in H0.
  destruct H, H0.
  rewrite H2, <- H0.
  auto.
Qed.

End RewriteClass.

Existing Instances logic_equiv_impp_rewrite
                   logic_equiv_refl_instance
                   logic_equiv_symm_instance
                   logic_equiv_trans_instance
                   logic_equiv_trans_equiv
                   logic_equiv_proper_logic_equiv
                   logic_equiv_proper_derivable1.


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

Require Export complexes_similitudes.
Set Implicit Arguments.
Unset Strict Implicit.

Definition isocele_rectangle_direct (A B C : PO) :=
  A <> B /\
  isocele A B C /\ cons_AV (vec A B) (vec A C) = image_angle pisurdeux.

Lemma iso_rec_dir_distinct :
 forall A B C : PO, isocele_rectangle_direct A B C -> A <> C.
unfold isocele_rectangle_direct, isocele in |- *; intros.
elim H;
 [ intros H0 H1; elim H1; [ intros H2 H3; try clear H1 H; try exact H2 ] ].
apply isometrie_distinct with (2 := H2); auto.
Qed.
#[export] Hint Resolve iso_rec_dir_distinct: geo.

Lemma iso_rec_dir_complexe :
 forall (a b c : C) (A B C : PO),
 a = affixe A ->
 b = affixe B ->
 c = affixe C ->
 isocele_rectangle_direct A B C ->
 Cplus c (Copp a) = Cmult i (Cplus b (Copp a)).
unfold isocele_rectangle_direct, isocele in |- *; intros.
elim H2;
 [ intros H3 H4; elim H4; [ intros H5 H6; try clear H4 H2; try exact H6 ] ].
rewrite forme_polaire_i.
apply rotation_complexe with (J := A) (M := B) (M' := C); auto.
apply rotation_def2; auto.
Qed.

Lemma complexe_iso_rec_dir :
 forall (a b c : C) (A B C : PO),
 a = affixe A ->
 b = affixe B ->
 c = affixe C ->
 A <> B ->
 Cplus c (Copp a) = Cmult i (Cplus b (Copp a)) ->
 isocele_rectangle_direct A B C.
unfold isocele_rectangle_direct, isocele in |- *; intros.
cut (distance A B = distance A C); intros.
cut (A <> C); intros.
split; [ try assumption | idtac ].
split; [ try assumption | idtac ].
cut (Cplus b (Copp a) <> zeroC); intros.
cut (Cplus c (Copp a) <> zeroC); intros.
rewrite
 (angle_vecteurs_arguments (A:=A) (B:=B) (A':=A) (B':=C)
    (z:=Cplus b (Copp a)) (z':=Cplus c (Copp a)));
 auto with geo.
rewrite H3; rewrite forme_polaire_i; rewrite Cmult_argument; auto.
rewrite argument_module_un.
elim existence_argument with (z := Cplus b (Copp a));
 [ intros; try clear existence_argument | auto ].
rewrite H8; repeat rewrite <- mes_opp.
repeat rewrite <- add_mes_compatible.
replace (pisurdeux + x + - x) with pisurdeux; [ auto | ring ].
auto with geo.
apply diff_nonzero with (3 := H5); auto.
apply diff_nonzero with (3 := H2); auto.
apply isometrie_distinct with (2 := H4); auto.
rewrite <- (module_difference H H0).
rewrite <- (module_difference H H1).
rewrite H3; rewrite forme_polaire_i; rewrite Cmult_module;
 rewrite complexe_polaire_module; ring.
Qed.

Lemma deux_iso_rec_dir_complexe :
 forall (a b c d e : C) (A B C D E : PO),
 a = affixe A ->
 b = affixe B ->
 c = affixe C ->
 d = affixe D ->
 e = affixe E ->
 isocele_rectangle_direct A B C ->
 isocele_rectangle_direct A D E ->
 Cplus e (Copp c) = Cmult i (Cplus d (Copp b)).
intros a b c d e A B C D E aA bB cC dD eE ABC ADE.
generalize (iso_rec_dir_complexe aA bB cC ABC);
 intros H11.
generalize (iso_rec_dir_complexe aA dD eE ADE);
 intros H12.
replace (Cplus e (Copp c)) with
 (Cplus (Cplus e (Copp a)) (Copp (Cplus c (Copp a))));
 [ idtac | ring ].
rewrite H12; auto.
rewrite H11; auto.
replace (Cplus d (Copp b)) with
 (Cplus (Cplus d (Copp a)) (Copp (Cplus b (Copp a))));
 ring.
Qed.

Theorem deux_isocele_rectangle_direct :
 forall A B C D E : PO,
 B <> D :>PO ->
 isocele_rectangle_direct A B C ->
 isocele_rectangle_direct A D E ->
 distance B D = distance C E /\
 cons_AV (vec B D) (vec C E) = image_angle pisurdeux.
intros.
elim existence_affixe_point with (M := A); intros a; intros.
elim existence_affixe_point with (M := B); intros b; intros.
elim existence_affixe_point with (M := C); intros c; intros.
elim existence_affixe_point with (M := D); intros d; intros.
elim existence_affixe_point with (M := E); intros e; intros.
cut (Cplus e (Copp c) = Cmult i (Cplus d (Copp b))); intros.
cut (distance B D = distance C E); intros.
cut (C <> E); intros.
split; [ try assumption | idtac ].
cut (Cplus d (Copp b) <> zeroC); intros.
cut (Cplus e (Copp c) <> zeroC); intros.
rewrite
 (angle_vecteurs_arguments (A:=B) (B:=D) (A':=C) (B':=E)
    (z:=Cplus d (Copp b)) (z':=Cplus e (Copp c)));
 auto with geo.
rewrite H7; rewrite forme_polaire_i; rewrite Cmult_argument; auto.
rewrite argument_module_un.
elim existence_argument with (z := Cplus d (Copp b));
 [ intros; try clear existence_argument | auto ].
rewrite H12; repeat rewrite <- mes_opp.
repeat rewrite <- add_mes_compatible.
replace (pisurdeux + x + - x) with pisurdeux; [ auto | ring ].
auto with geo.
apply diff_nonzero with (3 := H9); auto.
apply diff_nonzero with (3 := H); auto.
apply isometrie_distinct with (2 := H8); auto.
rewrite <- (module_difference H3 H5).
rewrite <- (module_difference H4 H6).
rewrite H7; rewrite forme_polaire_i; rewrite Cmult_module;
 rewrite complexe_polaire_module; ring.
apply
 (@deux_iso_rec_dir_complexe a b c d e A B C D E); auto.
Qed.


(** Lib.v: various general-purpose properties *)
Require Export Tactics.
Require Export Relations.
Require Export List.
Require Export Bool.
Require Export ZArith.
Require Export EqBoolAux.
Require Export PosAux.
Require Export BinArray.
Require Export MapSignatures.
Require Export MapList.

Lemma in_nth_error : forall (A:Set) (l:list A) n a,
  nth_error l n = Some a -> In a l.
Proof.
  induction l; simpl; intros.
  destruct n; discriminate.
  destruct n; simpl in H.
  inversion H; auto.
  right; eauto.
Qed.

Lemma app_cons : forall (A:Set) (l1 l2:list A) a,
  l1++a::l2 = (l1++a::nil)++l2.
Proof.
  induction l1; simpl; intros.
  reflexivity.
  rewrite IHl1; reflexivity.
Qed.

Lemma length_app_cons_nil : forall (A:Set) (l:list A) a,
  length (l++a::nil) = S (length l).
Proof.
  induction l; simpl; intros.
  reflexivity.
  rewrite IHl; reflexivity.
Qed.

Lemma app_inj_right : forall (A:Set) (l1 r1 l2 r2:list A),
  length l1 = length l2 ->
  l1++r1 = l2++r2 -> r1=r2.
Proof.
  induction l1; destruct l2; simpl; intros; try discriminate; auto.
  injection H; injection H0; intros; eauto.
Qed.

Lemma app_inj : forall (A:Set) (l1 r1 l2 r2:list A),
  length l1 = length l2 ->
  l1++r1 = l2++r2 -> l1=l2 /\ r1=r2.
Proof.
  induction l1; destruct l2; simpl; intros; try discriminate; auto.
  injection H; injection H0; intros.
  elim IHl1 with r1 l2 r2; intros; auto.
  subst; auto.
Qed.

Lemma app_exists_if_length : forall (A:Set) (l:list A) n,
  (n <= length l)%nat ->
  exists l1, exists l2, length l1 = n /\ l = l1 ++ l2.
Proof.
  induction l; simpl; intros.
  exists (@nil A).
  destruct n.
  exists (@nil A); simpl; auto.
  apply False_ind; omega.
  destruct n.
  exists (@nil A); exists (a::l); auto.
  destruct (IHl n) as [l1 [l2 [H1 H2]]].
  omega.
  exists (a::l1); exists l2; split; simpl; auto.
  rewrite H2; auto.
Qed.

Lemma app_length_le : forall (A:Set) (l1 l2:list A),
  (length l1 <= length (l1++l2))%nat.
Proof.
  induction l1; simpl; intros.
  omega.
  generalize (IHl1 l2); omega.
Qed.

Lemma length_app_length : forall (A B:Set) (l1 l3 :list A) (l2 l4 :list B),
  length l1 = length l2 ->
  length (l1++l3) = length (l2++l4) ->
  length l3 = length l4.
Proof.
  induction l1; destruct l2; intros; try discriminate;
  simpl in *; auto.
  injection H; injection H0; intros; eapply IHl1; eauto.
Qed.

Lemma not_none_some : forall (A:Type) (a:option A) (b:A),
  a <> None -> exists b, a = Some b.
Proof.
  intros; destruct a; try(exists a; auto); try (apply False_ind; auto).
Qed.

Section eq_dec.
  Variable t:Set.
  Variable P:t->t->Prop.
  Variable test_bool : t -> t -> bool.
  Definition test_bool_spec : Prop := forall x y, if test_bool x y then P x y else ~ P x y.
  Variable test_bool_prop : test_bool_spec.
  Lemma P_dec : forall l l':t, {P l l'}+{~P l l'}.
  Proof.
    intros x y; generalize (test_bool_prop x y); case (test_bool x y); auto.
  Qed.
End eq_dec.
Implicit Arguments P_dec.
Implicit Arguments test_bool_spec.


Require Import String Lib.Word List Arith.
Require Import Equality Eqdep_dec FunctionalExtensionality.
Require Import Lib.CommonTactics Lib.StringEq.

Set Implicit Arguments.

Record Attribute (A : Type) := { attrName: string; attrType: A }.

Section Attribute.
  Variable A: Type.

  Implicit Types k : A.
  Implicit Types a : Attribute A.

  Lemma attribute_inv:
    forall n1 n2 k1 k2, {| attrName := n1; attrType := k1 |} = {| attrName := n2; attrType := k2 |} ->
      n1 = n2 /\ k1 = k2.
  Proof.
    intros; inv H; auto.
  Qed.

  Definition Attribute_dec (kdec: forall (k1 k2: A), {k1 = k2} + {k1 <> k2})
  : forall (a1 a2: Attribute A), {a1 = a2} + {a1 <> a2}.
  Proof.
    intros;
    repeat decide equality.
  Qed.

  Fixpoint getAttribute (n: string) (attrs: list (Attribute A)) :=
    match attrs with
      | nil => None
      | attr :: attrs' =>
        if string_eq n (attrName attr) then Some attr
        else getAttribute n attrs'
    end.

  Lemma in_NoDup_attr:
    forall a1 a2 attrs,
      NoDup (map (@attrName _) attrs) ->
      attrName a1 = attrName a2 -> In a1 attrs -> In a2 attrs -> a1 = a2.
  Proof.
    induction attrs; intros; simpl in *; [destruct H1|].
    destruct a1 as [an1 ab1], a2 as [an2 ab2]; simpl in *.
    destruct H1; [subst|].
    - destruct H2; [auto|].
      inv H; elim H3.
      replace an2 with (attrName {| attrName := an2; attrType := ab2 |}) by reflexivity.
      apply in_map; auto.
    - destruct H2.
      + subst; inv H.
        elim H3.
        replace an2 with (attrName {| attrName := an2; attrType := ab1 |}) by reflexivity.
        apply in_map; auto.
      + inv H; apply IHattrs; auto.
  Qed.

  Fixpoint getAttrType (n: string) (attrs: list (Attribute A)) :=
    match attrs with
      | nil => None
      | attr :: attrs' =>
        if string_eq n (attrName attr)
        then Some (attrType attr)
        else getAttrType n attrs'
    end.

  Lemma getAttrType_attrType_getAttribute n attrs:
    getAttrType n attrs = match getAttribute n attrs with
                            | None => None
                            | Some a => Some (attrType a)
                          end.
  Proof.
    induction attrs; simpl; auto.
    destruct (string_eq n (attrName a)); auto.
  Qed.

  Definition namesOf (attrs: list (Attribute A)) := map (@attrName _) attrs.

  Lemma namesOf_app:
    forall (l1 l2: list (Attribute A)),
      namesOf (l1 ++ l2) = namesOf l1 ++ namesOf l2.
  Proof.
    unfold namesOf; simpl; intros.
    rewrite map_app; reflexivity.
  Qed.

  Lemma getAttribute_app:
    forall n (attrs1 attrs2: list (Attribute A)) dm
           (Hdm: dm = getAttribute n (attrs1 ++ attrs2)),
      dm = getAttribute n attrs1 \/ dm = getAttribute n attrs2.
  Proof.
    induction attrs1; intros; simpl; [right; assumption|].
    simpl in Hdm; destruct (string_eq n (attrName a)); subst; intuition.
  Qed.

  Lemma getAttribute_Some_name:
    forall n (attrs: list (Attribute A)) dm
           (Hdm: Some dm = getAttribute n attrs),
      attrName dm = n.
  Proof.
    induction attrs; intros; simpl; [inv Hdm|].
    simpl in Hdm.
    remember (string_eq _ _) as seq; destruct seq; [|auto].
    apply string_eq_dec_eq in Heqseq.
    inv Hdm; reflexivity.
  Qed.

  Lemma getAttribute_Some_body:
    forall n (attrs: list (Attribute A)) dm
           (Hdm: Some dm = getAttribute n attrs),
      In dm attrs.
  Proof.
    induction attrs; intros; simpl; [inv Hdm|].
    simpl in Hdm.
    destruct (string_eq _ _); [|auto].
    left; inv Hdm; reflexivity.
  Qed.

  Lemma getAttribute_Some:
    forall n (attrs: list (Attribute A)) dm
           (Hdm: Some dm = getAttribute n attrs),
      In n (map (@attrName _) attrs).
  Proof.
    induction attrs; intros; simpl; [inv Hdm|].
    simpl in Hdm.
    remember (string_eq _ _) as seq; destruct seq.
    - left; apply string_eq_dec_eq in Heqseq; auto.
    - right; eauto.
  Qed.

  Lemma getAttribute_None:
    forall n (attrs: list (Attribute A))
           (Hdm: None = getAttribute n attrs),
      ~ In n (map (@attrName _) attrs).
  Proof.
    induction attrs; intros; intuition; inv H.
    - simpl in Hdm.
      remember (string_eq _ _) as seq; destruct seq; [inv Hdm|].
      apply string_eq_dec_neq in Heqseq; elim Heqseq; reflexivity.
    - inv Hdm.
      remember (string_eq _ _) as seq; destruct seq; [inv H1|].
      apply IHattrs; auto.
  Qed.
End Attribute.

Section MapAttr.
  Variable A B: Type.
  Variable f: A -> B.
  Definition changeAttr (a: Attribute A) := (attrName a, f (attrType a)).

  Definition mapAttr (ls: list (Attribute A)) := map changeAttr ls.
End MapAttr.

#[global] Hint Unfold attrName attrType namesOf changeAttr mapAttr.


From MetaCoq.Template Require Import All.

From MetaCoq Require Import All.
Require Import String List.
Local Open Scope string.
Import ListNotations MCMonadNotation Nat.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import TemplateToPCUIC.
From MetaCoq.PCUIC Require Import PCUICToTemplate.

Load param_test.

MetaCoq Run (
    tmQuote (@vecᵗ)
    >>= tmPrint
).

MetaCoq Run (
    (* qt <- tmQuote (@list);; *)
    qt <- tmQuote (@listᵗ);;
    (* qt <- tmQuote (@roseSAᵗ);; *)
    (* qt <- tmQuote (@roseᵗ);; *)
    (* qt <- tmQuote (@roseAᵗ);; *)
    match qt with
    | Ast.tInd {| inductive_mind := kn |} _ =>
        tmQuoteInductive kn >>= tmPrint
    | _ => tmFail "try again"
    end
).

MetaCoq Quote Definition f1 :=
    (fun (n:nat) =>
    fix f (m:nat) (k:nat) :=
    match k with
    O => true
    | S l => true && f m l
    end).

MetaCoq Quote Definition f2 :=
    (fun A (xs:list A) =>
    match xs with
    | [] => true
    | _ => false
    end).

MetaCoq Quote Definition f3 :=
    (fun A N (xs:list A) (h:nonUniDepTest A N xs true 0) =>
    match h return bool with (* without return bool, the MC term gets large *)
    | CD1 H1 H2 _ _ => true
    | CD2 H1 _ _ _ _ => false
    end).

MetaCoq Quote Definition f4 :=
    (fun A (h:indexTest A 0 true) =>
    match h return bool with (* without return bool, the MC term gets large *)
    end).

MetaCoq Quote Definition f5 :=
    (fun
    A N (P:forall xs b n, nonUniDepTest A N xs b n -> Prop)
    (HCD1: forall xs H1 H2, P xs true 0 (CD1 A N xs H1 H2))
    (HCD2: forall xs H1, P xs false 1 (CD2 A N xs H1)) =>
    fix f xs b n i : P xs b n i :=
    match i as j in nonUniDepTest _ _ _ c m return P xs _ _ j with
    | CD1 H1 H2 => HCD1 xs H1 H2
    | CD2 H1 => HCD2 xs H1
    end
    ).

MetaCoq Quote Definition f6 :=
    (fun
    A N (P:forall xs b n, nonUniDepTest A N xs b n -> Prop)
    (HCD1: forall xs H1 (IH_H1: P [] false 1 H1) H2 (IH_H2: P [] false 0 H2), P xs true 0 (CD1 A N xs H1 H2))
    (HCD2: forall xs H1 (IH_H1: P (xs ++ xs)%list true 0 H1), P xs false 1 (CD2 A N xs H1)) =>
    fix f xs b n i : P xs b n i :=
    match i as j in nonUniDepTest _ _ _ c m return P xs _ _ j with
    | CD1 H1 H2 => HCD1 xs H1 (f _ _ _ H1) H2 (f _ _ _ H2)
    | CD2 H1 => HCD2 xs H1 (f _ _ _ H1)
    end
    ).

Print f6.


(** * The slice displayed category

- Definition of the slice displayed category
- Proof that a morphism is cartesian if and only if
  it is a pullback

*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.limits.pullbacks.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Local Open Scope cat.

(** ** The displayed codomain

The total category associated to this displayed category is going to be
isomorphic to the arrow category, but it won't be the same:
the components of the objects and morphisms will be arranged differently

*)

(* TODO: perhaps rename [slice_disp], and make [C] implicit? *)
Section Codomain_Disp.

Context (C : category).

Definition cod_disp_ob_mor : disp_cat_ob_mor C.
Proof.
  exists (λ x : C, ∑ y, y --> x).
  simpl; intros x y xx yy f.
    exact (∑ ff : pr1 xx --> pr1 yy, ff · pr2 yy = pr2 xx · f).
Defined.

Definition cod_id_comp : disp_cat_id_comp _ cod_disp_ob_mor.
Proof.
  split.
  - simpl; intros.
    exists (identity _ ).
    abstract (
        etrans; [apply id_left |];
        apply pathsinv0, id_right ).
  - simpl; intros x y z f g xx yy zz ff gg.
    exists (pr1 ff · pr1 gg).
    abstract (
        apply pathsinv0;
        etrans; [apply assoc |];
        etrans; [apply maponpaths_2, (! (pr2 ff)) |];
        etrans; [eapply pathsinv0, assoc |];
        etrans; [apply maponpaths, (! (pr2 gg))|];
        apply assoc).
Defined.

Definition cod_disp_data : disp_cat_data _
  := (cod_disp_ob_mor ,, cod_id_comp).

Lemma cod_disp_axioms : disp_cat_axioms C cod_disp_data.
Proof.
  repeat apply tpair; intros; try apply homset_property.
  - apply subtypePath.
    { intro. apply homset_property. }
    etrans. apply id_left.
    destruct ff as [ff H].
    apply pathsinv0.
    etrans. use (pr1_transportf (A := C⟦x,y⟧)).
    cbn; apply (eqtohomot (transportf_const _ _)).
  - apply subtypePath.
    { intro. apply homset_property. }
    etrans. apply id_right.
    destruct ff as [ff H].
    apply pathsinv0.
    etrans. use (pr1_transportf (A := C⟦x,y⟧)).
    cbn; apply (eqtohomot (transportf_const _ _)).
  - apply subtypePath.
    { intro. apply homset_property. }
    etrans. apply assoc.
    destruct ff as [ff H].
    apply pathsinv0.
    etrans. unfold mor_disp.
    use (pr1_transportf (A := C⟦x,w⟧)).
    cbn; apply (eqtohomot (transportf_const _ _)).
  - apply (isofhleveltotal2 2).
    + apply homset_property.
    + intro. apply isasetaprop. apply homset_property.
Qed.

Definition disp_codomain : disp_cat C
  := (cod_disp_data ,, cod_disp_axioms).

End Codomain_Disp.

Section Pullbacks_Cartesian.

Context {C:category}.

Definition isPullback_cartesian_in_cod_disp
    { Γ Γ' : C } {f : Γ' --> Γ}
    {p : disp_codomain _ Γ} {p' : disp_codomain _ Γ'} (ff : p' -->[f] p)
  : (isPullback (pr2 ff)) -> is_cartesian ff.
Proof.
  intros Hpb Δ g q hh.
  eapply iscontrweqf.
  2: {
    use Hpb.
    + exact (pr1 q).
    + exact (pr1 hh).
    + simpl in q. use (pr2 q · g).
    + etrans. apply (pr2 hh). apply assoc.
  }
  eapply weqcomp.
  2: apply weqtotal2asstol.
  apply weq_subtypes_iff.
  - intro. apply isapropdirprod; apply homset_property.
  - intro. apply (isofhleveltotal2 1).
    + apply homset_property.
    + intros. apply homsets_disp.
  - intros gg; split; intros H.
    + exists (pr2 H).
      apply subtypePath.
        intro; apply homset_property.
      exact (pr1 H).
    + split.
      * exact (maponpaths pr1 (pr2 H)).
      * exact (pr1 H).
Qed.

Definition cartesian_isPullback_in_cod_disp
    { Γ Γ' : C } {f : Γ' --> Γ}
    {p : disp_codomain _ Γ} {p' : disp_codomain _ Γ'} (ff : p' -->[f] p)
  : (isPullback (pr2 ff)) <- is_cartesian ff.
Proof.
  intros cf c h k H.
  destruct p as [a x].
  destruct p' as [b y].
  destruct ff as [H1 H2].
  unfold is_cartesian in cf.
  simpl in *.
  eapply iscontrweqf.
  2: {
    use cf.
    + exact Γ'.
    + exact (identity _ ).
    + exists c. exact k.
    + cbn. exists h.
      etrans. apply H. apply maponpaths. apply (! id_left _ ).
  }
  eapply weqcomp.
  apply weqtotal2asstor.
  apply weq_subtypes_iff.

  - intro. apply (isofhleveltotal2 1).
    + apply homset_property.
    + intros.
      match goal with |[|- isofhlevel 1 (?x = _ )] =>
                       set (X := x) end.
      set (XR := @homsets_disp _ (disp_codomain C )).
      specialize (XR _ _ _ _ _ X).
      apply XR.
  - cbn. intro. apply isapropdirprod; apply homset_property.
  - intros gg; split; intros HRR.
    + split.
      * exact (maponpaths pr1 (pr2 HRR)).
      * etrans. apply (pr1 HRR). apply id_right.
    + use tpair.
      * rewrite id_right.
        exact (pr2 HRR).
      * apply subtypePath.
        intro; apply homset_property.
      exact (pr1 HRR).
Qed.

Definition cartesian_iff_isPullback
    { Γ Γ' : C } {f : Γ' --> Γ}
    {p : disp_codomain _ Γ} {p' : disp_codomain _ Γ'} (ff : p' -->[f] p)
  : (isPullback (pr2 ff)) <-> is_cartesian ff.
Proof.
  split.
  - apply isPullback_cartesian_in_cod_disp.
  - apply cartesian_isPullback_in_cod_disp.
Defined.

End Pullbacks_Cartesian.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 15: Deep and Shallow Embeddings
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Shared notations and definitions; main material starts afterward. *)

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
Definition heap := fmap nat nat.
Definition assertion := heap -> Prop.

Local Hint Extern 1 (_ <= _) => linear_arithmetic : core.
Local Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.

Example h0 : heap := $0 $+ (0, 2) $+ (1, 1) $+ (2, 8) $+ (3, 6).

Local Hint Rewrite max_l max_r using linear_arithmetic : core.

Ltac simp := repeat (simplify; subst; propositional;
                     try match goal with
                         | [ H : ex _ |- _ ] => invert H
                         end); try linear_arithmetic.

(** * Basic concepts of shallow, deep, and mixed embeddings *)

(* We often have many options for how to encode some sort of formal expression.
 * The simplest way is to write it directly as a Gallina functional program,
 * which Coq knows how to evaluate directly.  That style is called
 * *shallow embedding*. *)

Module SimpleShallow.
  Definition foo (x y : nat) : nat :=
    let u := x + y in
    let v := u * y in
    u + v.
End SimpleShallow.

(* Alternatively, we can do as we have been through most of the chapters: define
 * inductive types of program syntax, along with semantics for syntax trees.
 * That style is called *deep embedding*. *)

Module SimpleDeep.
  Inductive exp :=
  | Const (n : nat)
  | Var (x : var)
  | Plus (e1 e2 : exp)
  | Times (e1 e2 : exp)
  | Let (x : var) (e1 e2 : exp).

  Definition foo : exp :=
    Let "u" (Plus (Var "x") (Var "y"))
        (Let "v" (Times (Var "u") (Var "y"))
             (Plus (Var "u") (Var "v"))).

  Fixpoint interp (e : exp) (v : fmap var nat) : nat :=
    match e with
    | Const n => n
    | Var x => v $! x
    | Plus e1 e2 => interp e1 v + interp e2 v
    | Times e1 e2 => interp e1 v * interp e2 v
    | Let x e1 e2 => interp e2 (v $+ (x, interp e1 v))
    end.
End SimpleDeep.

(* We defined function [foo] in shallow and deep styles, and it is easy to prove
 * that the encodings are equivalent. *)
Theorem shallow_to_deep : forall x y,
    SimpleShallow.foo x y = SimpleDeep.interp SimpleDeep.foo ($0 $+ ("x", x) $+ ("y", y)).
Proof.
  unfold SimpleShallow.foo.
  simplify.
  reflexivity.
Qed.

(* More interestingly, we can mix characteristics of the two styles.  To explain
 * exactly how, it's important to introduce the distinction between the
 * *metalanguage*, in which we do our proofs (e.g., Coq for us); and the
 * *object language*, which we formalize explicitly (e.g., lambda calculus,
 * simple imperative programs, ...).  With *higher-order abstract syntax*, we
 * represent binders of the object language using the function types of the
 * metalanguage. *)
Module SimpleMixed.
  Inductive exp :=
  | Const (n : nat)
  | Var (x : string)
  | Plus (e1 e2 : exp)
  | Times (e1 e2 : exp)
  | Let (e1 : exp) (e2 : nat -> exp).
  (* Note a [Let] body is a *function* over the computed value attached to the
   * variable being bound. *)

  Definition foo : exp :=
    Let (Plus (Var "x") (Var "y"))
        (fun u => Let (Times (Const u) (Var "y"))
                      (fun v => Plus (Const u) (Const v))).

  Fixpoint interp (e : exp) (v : fmap var nat) : nat :=
    match e with
    | Var x => v $! x
    | Const n => n
    | Plus e1 e2 => interp e1 v + interp e2 v
    | Times e1 e2 => interp e1 v * interp e2 v
    | Let e1 e2 => interp (e2 (interp e1 v)) v
    end.

  (* We can even do useful transformations on such expressions within Gallina,
   * as in this function to recursively simplify additions of 0 and
   * multiplications by 1. *)
  Fixpoint reduce (e : exp) : exp :=
    match e with
    | Var x => Var x
    | Const n => Const n
    | Plus e1 e2 =>
      let e1' := reduce e1 in
      let e2' := reduce e2 in
      match e1' with
      | Const 0 => e2'
      | _ => match e2' with
             | Const 0 => e1'
             | _ => Plus e1' e2'
             end
      end
    | Times e1 e2 =>
      let e1' := reduce e1 in
      let e2' := reduce e2 in
      match e1' with
      | Const 1 => e2'
      | _ => match e2' with
             | Const 1 => e1'
             | _ => Times e1' e2'
             end
      end
    | Let e1 e2 =>
      let e1' := reduce e1 in
      match e1' with
      | Const n => reduce (e2 n)
      | _ => Let e1' (fun n => reduce (e2 n))
      end
    end.

  (* This example shows simplification, even under binders. *)
  Compute (reduce (Let (Plus (Const 0) (Const 1))
                       (fun n => Let (Times (Var "x") (Const 2))
                                     (fun m => Times (Const n) (Const m))))).

  (* The transformation is provably meaning-preserving. *)
  Theorem reduce_ok : forall v e, interp (reduce e) v = interp e v.
  Proof.
    induct e; simplify;
    repeat match goal with
           | [ H : _ = interp _ _ |- _ ] => rewrite <- H
           | [ |- context[match ?E with _ => _ end] ] => cases E; simplify; subst; try linear_arithmetic
    end; eauto.
  Qed.
End SimpleMixed.

Theorem shallow_to_mixed : forall x y,
    SimpleShallow.foo x y = SimpleMixed.interp SimpleMixed.foo ($0 $+ ("x", x) $+ ("y", y)).
Proof.
  unfold SimpleShallow.foo.
  simplify.
  reflexivity.
Qed.

(** * Shallow embedding of a language very similar to the one we used last chapter *)

(* With the basic terminology out of the way, let's see these ideas in action,
 * to encode the sort of imperative language we studied in the previous
 * chapter. *)

Module Shallow.
  (* As a shallow embedding, we can represent imperative programs as functional
   * programs that manipulate heaps explicitly. *)
  Definition cmd result := heap -> heap * result.
  (* Parameter [result] gives the type of the value being computed by a
   * command.  The command is a function taking the initial heap as input, and
   * it returns a pair of the final heap and the command's result. *)

  (* We can redefine Hoare triples over these functional programs. *)
  Definition hoare_triple (P : assertion) {result} (c : cmd result) (Q : result -> assertion) :=
    forall h, P h
              -> let (h', r) := c h in
                 Q r h'.

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  (* Standard rules of Hoare logic can be proved as lemmas.  For instance,
   * here's the rule of consequence. *)
  Theorem consequence : forall P {result} (c : cmd result) Q
                               (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'.
  Proof.
    unfold hoare_triple; simplify.
    specialize (H h).
    specialize (H0 h).
    cases (c h).
    auto.
  Qed.

  (* However, the programs themselves look quite different from those we saw in
   * the previous chapter.  This function computes the maximum among the first [i]
   * cells of memory and the accumulator [acc]. *)
  Fixpoint array_max (i acc : nat) : cmd nat :=
    fun h =>
      match i with
      | O => (h, acc)
      | S i' =>
        let h_i' := h $! i' in
        array_max i' (max h_i' acc) h
      end.

  (* We can prove its correctness via preconditions and postconditions. *)

  Lemma array_max_ok' : forall len i acc,
    {{ h ~> forall j, i <= j < len -> h $! j <= acc }}
      array_max i acc
    {{ r&h ~> forall j, j < len -> h $! j <= r }}.
  Proof.
    induct i; unfold hoare_triple in *; simplify; propositional; auto.

    specialize (IHi (max (h $! i) acc) h); propositional.
    cases (array_max i (max (h $! i) acc) h); simplify; propositional; subst.
    apply IHi; auto.
    simplify.
    cases (j0 ==n i); subst; auto.
    assert (h $! j0 <= acc) by auto.
    linear_arithmetic.
  Qed.

  Theorem array_max_ok : forall len,
    {{ _ ~> True }}
      array_max len 0
    {{ r&h ~> forall i, i < len -> h $! i <= r }}.
  Proof.
    simplify.
    eapply consequence.
    apply array_max_ok' with (len := len).

    simplify.
    linear_arithmetic.

    auto.
  Qed.

  (* We can also run the program on concrete inputs. *)
  Example run_array_max0 : array_max 4 0 h0 = (h0, 8).
  Proof.
    unfold h0.
    simplify.
    reflexivity.
  Qed.

  (* One more example in the same style: increment each of the first [i] cells
   * of memory. *)

  Fixpoint increment_all (i : nat) : cmd unit :=
    fun h =>
      match i with
      | O => (h, tt)
      | S i' => increment_all i' (h $+ (i', S (h $! i')))
      end.

  Lemma increment_all_ok' : forall len h0 i,
    {{ h ~> (forall j, j < i -> h $! j = h0 $! j)
       /\ (forall j, i <= j < len -> h $! j = S (h0 $! j)) }}
      increment_all i
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    induct i; unfold hoare_triple in *; simplify; propositional; auto.

    specialize (IHi (h $+ (i, S (h $! i)))); propositional.
    cases (increment_all i (h $+ (i, S (h $! i)))); simplify; propositional; subst.
    apply H; simplify; auto.

    cases (j0 ==n i); subst; auto.
    simplify; auto.
    simplify; auto.
  Qed.

  Theorem increment_all_ok : forall len h0,
    {{ h ~> h = h0 }}
      increment_all len
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    simplify.
    eapply consequence.
    apply increment_all_ok' with (len := len).

    simplify; subst; propositional.
    linear_arithmetic.

    simplify.
    auto.
  Qed.

  Example run_increment_all0 : increment_all 4 h0 = ($0 $+ (0, 3) $+ (1, 2) $+ (2, 9) $+ (3, 7), tt).
  Proof.
    unfold h0.
    simplify.
    f_equal.
    maps_equal.
  Qed.
End Shallow.

(** * A basic deep embedding *)

(* One disadvantage of the last style of programs is computational efficiency:
 * real CPU architectures don't manipulate memory as functional maps that are
 * passed around, and the abstraction gap between our code and CPUs prevents us
 * from taking maximum advantage of the hardware to achieve good performance.
 * To help regain that efficiency, let's do a deep embedding of the language.
 * Actually, it's a mixed embedding, with no explicit concept of variables,
 * using higher-order abstract syntax to represent binders. *)

Module Deep.
  Inductive cmd : Set -> Type :=
  | Return {result : Set} (r : result) : cmd result
  | Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
  | Read (a : nat) : cmd nat
  | Write (a v : nat) : cmd unit.

  (* These constructors are most easily explained through examples.  We'll
   * translate both of the programs from the shallow embedding above. *)

  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).

  Fixpoint array_max (i acc : nat) : cmd nat :=
    match i with
    | O => Return acc
    | S i' =>
      h_i' <- Read i';
      array_max i' (max h_i' acc)
    end.

  Fixpoint increment_all (i : nat) : cmd unit :=
    match i with
    | O => Return tt
    | S i' =>
      v <- Read i';
      _ <- Write i' (S v);
      increment_all i'
    end.

  (* Note how this is truly a mixed encoding: we freely use Gallina constructs
   * like [match], mixed in with instructions specific to the object language,
   * like reading or writing memory.  An interpreter explains what it all means,
   * reducing programs to their original type from the shallow embedding. *)

  Fixpoint interp {result} (c : cmd result) (h : heap) : heap * result :=
    match c with
    | Return _ r => (h, r)
    | Bind _ _ c1 c2 =>
      let (h', r) := interp c1 h in
      interp (c2 r) h'
    | Read a => (h, h $! a)
    | Write a v => (h $+ (a, v), tt)
    end.

  Example run_array_max0 : interp (array_max 4 0) h0 = (h0, 8).
  Proof.
    unfold h0.
    simplify.
    reflexivity.
  Qed.

  Example run_increment_all0 : interp (increment_all 4) h0 = ($0 $+ (0, 3) $+ (1, 2) $+ (2, 9) $+ (3, 7), tt).
  Proof.
    unfold h0.
    simplify.
    f_equal.
    maps_equal.
  Qed.

  (* This time, we define a Hoare-triple relation syntactically. *)
  Inductive hoare_triple : assertion -> forall {result}, cmd result -> (result -> assertion) -> Prop :=
  | HtReturn : forall P {result : Set} (v : result),
      hoare_triple P (Return v) (fun r h => P h /\ r = v)

  | HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
      hoare_triple P c1 Q
      -> (forall r, hoare_triple (Q r) (c2 r) R)
      -> hoare_triple P (Bind c1 c2) R
    (* Interesting thing about this rule: the second premise uses nested
     * universal quantification over all possible results of the first command. *)

  | HtRead : forall P a,
      hoare_triple P (Read a) (fun r h => P h /\ r = h $! a)
  | HtWrite : forall P a v,
      hoare_triple P (Write a v) (fun _ h => exists h', P h' /\ h = h' $+ (a, v))
  | HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'.

  Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P c Q'.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  (* Here are a few tactics, whose details we won't explain, but which
   * streamline the individual program proofs below. *)
  Ltac basic := apply HtReturn || eapply HtRead || eapply HtWrite.
  Ltac step0 := basic || eapply HtBind || (eapply HtStrengthen; [ basic | ]).
  Ltac step := step0; simp.
  Ltac ht := simp; repeat step; eauto.
  Ltac conseq := simplify; eapply HtConsequence.
  Ltac use_IH H := conseq; [ apply H | .. ]; ht.

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  Lemma array_max_ok' : forall len i acc,
    {{ h ~> forall j, i <= j < len -> h $! j <= acc }}
      array_max i acc
    {{ r&h ~> forall j, j < len -> h $! j <= r }}.
  Proof.
    induct i; ht.
    use_IH IHi.
    cases (j ==n i); simp.
    assert (h $! j <= acc) by auto.
    linear_arithmetic.
  Qed.

  Theorem array_max_ok : forall len,
    {{ _ ~> True }}
      array_max len 0
    {{ r&h ~> forall i, i < len -> h $! i <= r }}.
  Proof.
    conseq.
    apply array_max_ok' with (len := len).
    simp.
    simp.
    auto.
  Qed.

  Lemma increment_all_ok' : forall len h0 i,
    {{ h ~> (forall j, j < i -> h $! j = h0 $! j)
       /\ (forall j, i <= j < len -> h $! j = S (h0 $! j)) }}
      increment_all i
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    induct i; ht.
    use_IH IHi.
    cases (j ==n i); simp.
    auto.
    auto.
  Qed.

  Theorem increment_all_ok : forall len h0,
    {{ h ~> h = h0 }}
      increment_all len
    {{ _&h ~> forall j, j < len -> h $! j = S (h0 $! j) }}.
  Proof.
    conseq.
    apply increment_all_ok' with (len := len).
    simp.
    simp.
    auto.
  Qed.

  (* It's easy to prove the syntactic Hoare-triple relation sound with
   * respect to the semantic one from the shallow embedding. *)
  Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> let (h', r) := interp c h in
                      Q r h'.
  Proof.
    induct 1; simplify; propositional; eauto.

    specialize (IHhoare_triple h).
    cases (interp c1 h).
    apply H1; eauto.

    specialize (IHhoare_triple h).
    cases (interp c h).
    eauto.
  Qed.
End Deep.

(* We use Coq's *extraction* feature to produce OCaml versions of our deeply
 * embedded programs.  Then we can run them using OCaml intepreters, which are
 * able to take advantage of the side effects built into OCaml, as a
 * performance optimization.  This command generates file "Deep.ml", which can
 * be loaded along with "DeepInterp.ml" to run the generated code.  Note how
 * the latter file uses OCaml's built-in mutable hash-table type for efficient
 * representation of program memories. *)
Extraction "Deep.ml" Deep.array_max Deep.increment_all.

(** * A slightly fancier deep embedding, adding unbounded loops *)

Module Deeper.
  (* All programs in the last embedding must terminate, but let's add loops with
   * the potential to run forever, which takes us beyond what is representable
   * in the shallow embedding, since Gallina enforces termination for all
   * programs. *)

  (* We use this type to represent the outcome of a single loop iteration.
   * These are functional loops, where we successively modify an accumulator
   * value across iterations. *)
  Inductive loop_outcome acc :=
  | Done (a : acc)  (* The loop finished, and here is the final accumulator. *)
  | Again (a : acc) (* Keep looping, with this new accumulator. *).

  Inductive cmd : Set -> Type :=
  | Return {result : Set} (r : result) : cmd result
  | Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
  | Read (a : nat) : cmd nat
  | Write (a v : nat) : cmd unit
  | Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc.

  (* Again, it's all easier to explain with an example. *)

  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
  Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

  (* This program finds the first occurrence in memory of value [needle]. *)
  Definition index_of (needle : nat) : cmd nat :=
    for i := 0 loop
      h_i <- Read i;
      if h_i ==n needle then
        Return (Done i)
      else
        Return (Again (S i))
    done.

  (* Next, we write a single-stepping interpreter for this language.  We can
   * no longer write a straightforward big-stepping interpeter, as programs of
   * the object language can diverge, while Gallina enforces termination. *)

  Inductive stepResult (result : Set) :=
  | Answer (r : result)
  | Stepped (h : heap) (c : cmd result).

  Fixpoint step {result} (c : cmd result) (h : heap) : stepResult result :=
    match c with
    | Return _ r => Answer r
    | Bind _ _ c1 c2 =>
      match step c1 h with
      | Answer r => Stepped h (c2 r)
      | Stepped h' c1' => Stepped h' (Bind c1' c2)
      end
    | Read a => Answer (h $! a)
    | Write a v => Stepped (h $+ (a, v)) (Return tt)
    | Loop _ init body =>
      Stepped h (r <- body init;
                 match r with
                 | Done r' => Return r'
                 | Again r' => Loop r' body
                 end)
    end.

  Fixpoint multiStep {result} (c : cmd result) (h : heap) (n : nat) : stepResult result :=
    match n with
    | O => Stepped h c
    | S n' => match step c h with
              | Answer r => Answer r
              | Stepped h' c' => multiStep c' h' n'
              end
    end.

  Example run_index_of : multiStep (index_of 6) h0 20 = Answer 3.
  Proof.
    unfold h0.
    simplify.
    reflexivity.
  Qed.

  Inductive hoare_triple : assertion -> forall {result}, cmd result -> (result -> assertion) -> Prop :=
  | HtReturn : forall P {result : Set} (v : result),
      hoare_triple P (Return v) (fun r h => P h /\ r = v)
  | HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
      hoare_triple P c1 Q
      -> (forall r, hoare_triple (Q r) (c2 r) R)
      -> hoare_triple P (Bind c1 c2) R
  | HtRead : forall P a,
      hoare_triple P (Read a) (fun r h => P h /\ r = h $! a)
  | HtWrite : forall P a v,
      hoare_triple P (Write a v) (fun _ h => exists h', P h' /\ h = h' $+ (a, v))
  | HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'

  | HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc))
                    (I : loop_outcome acc -> assertion),
      (forall acc, hoare_triple (I (Again acc)) (body acc) I)
      -> hoare_triple (I (Again init)) (Loop init body) (fun r h => I (Done r) h).
  (* The loop rule contains a tricky new kind of invariant, parameterized on the
   * current loop state: either [Done] for a finished loop or [Again] for a loop
   * still in progress. *)

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P c Q'.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> hoare_triple P' c Q.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Ltac basic := apply HtReturn || eapply HtRead || eapply HtWrite.
  Ltac step0 := basic || eapply HtBind || (eapply HtStrengthen; [ basic | ]).
  Ltac step := step0; simp.
  Ltac ht := simp; repeat step; eauto.
  Ltac conseq := simplify; eapply HtConsequence.
  Ltac use_IH H := conseq; [ apply H | .. ]; ht.
  Ltac loop_inv Inv := eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]; ht.

  (* We prove our [index_of] example correct, relying crucially on a tactic
   * [loop_inv] to prove a loop by giving its loop invariant, which, recall, is
   * parameterized on a [loop_outcome]. *)
  Theorem index_of_ok : forall hinit needle,
    {{ h ~> h = hinit }}
      index_of needle
    {{ r&h ~> h = hinit
         /\ hinit $! r = needle
         /\ forall i, i < r -> hinit $! i <> needle }}.
  Proof.
    simplify.
    loop_inv (fun r h => h = hinit
                         /\ match r with
                            | Done r' => hinit $! r' = needle
                                         /\ forall i, i < r' -> hinit $! i <> needle
                            | Again r' => forall i, i < r' -> hinit $! i <> needle
                            end).
    cases (r ==n needle); ht.
    cases (i ==n acc); simp.
    apply H3 with (i := i); auto.
  Qed.

  (* The single-stepping interpreter forms the basis for defining transition
   * systems from commands. *)
  Definition trsys_of {result} (c : cmd result) (h : heap) := {|
    Initial := {(c, h)};
    Step := fun p1 p2 => step (fst p1) (snd p1) = Stepped (snd p2) (fst p2)
  |}.

  (* We now prove soundness of [hoare_triple], starting from a number of
   * inversion lemmas for it, collapsing the potential effects of many nested
   * rule-of-consequence applications. *)

  Lemma invert_Return : forall {result : Set} (r : result) P Q,
    hoare_triple P (Return r) Q
    -> forall h, P h -> Q r h.
  Proof.
    induct 1; propositional; eauto.
  Qed.

  Lemma invert_Bind : forall {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
    hoare_triple P (Bind c1 c2) Q
    -> exists R, hoare_triple P c1 R
                 /\ forall r, hoare_triple (R r) (c2 r) Q.
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    eexists; propositional.
    eapply HtWeaken.
    eassumption.
    auto.
    eapply HtStrengthen.
    apply H4.
    auto.
  Qed.

  (* Highly technical point: in some of the inductions below, we wind up needing
   * to show that the cases for [Read] and [Write] can never overlap, which
   * would imply that they have the same result types, which would mean that the
   * types [unit] and [nat] are equal. *)
  Lemma unit_not_nat : unit = nat -> False.
  Proof.
    simplify.
    assert (exists x : unit, forall y : unit, x = y).
    exists tt; simplify.
    cases y; reflexivity.
    rewrite H in H0.
    invert H0.
    specialize (H1 (S x)).
    linear_arithmetic.
  Qed.

  Lemma invert_Read : forall a P Q,
    hoare_triple P (Read a) Q
    -> forall h, P h -> Q (h $! a) h.
  Proof.
    induct 1; propositional; eauto.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Write : forall a v P Q,
    hoare_triple P (Write a v) Q
    -> forall h, P h -> Q tt (h $+ (a, v)).
  Proof.
    induct 1; propositional; eauto.
    symmetry in x0.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Loop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
      hoare_triple P (Loop init body) Q
      -> exists I, (forall acc, hoare_triple (I (Again acc)) (body acc) I)
                   /\ (forall h, P h -> I (Again init) h)
                   /\ (forall r h, I (Done r) h -> Q r h).
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    exists x; propositional; eauto.
  Qed.

  Lemma step_sound : forall {result} (c : cmd result) h Q,
      hoare_triple (fun h' => h' = h) c Q
      -> match step c h with
         | Answer r => Q r h
         | Stepped h' c' => hoare_triple (fun h'' => h'' = h') c' Q
         end.
  Proof.
    induct c; simplify; propositional.

    eapply invert_Return.
    eauto.
    simplify; auto.

    apply invert_Bind in H0.
    invert H0; propositional.
    apply IHc in H0.
    cases (step c h); auto.
    econstructor.
    apply H2.
    equality.
    auto.
    econstructor; eauto.

    eapply invert_Read; eauto.
    simplify; auto.

    eapply HtStrengthen.
    econstructor.
    simplify; propositional; subst.
    eapply invert_Write; eauto.
    simplify; auto.

    apply invert_Loop in H0.
    invert H0; propositional.
    econstructor.
    eapply HtWeaken.
    apply H0.
    equality.
    simplify.
    cases r.
    eapply HtStrengthen.
    econstructor.
    simplify.
    propositional; subst; eauto.
    eapply HtStrengthen.
    eapply HtLoop.
    auto.
    simplify.
    eauto.
  Qed.

  (* Clever choice of strengthened invariant here: intermediate commands are
   * checked against degenerate preconditions that force equality to the current
   * heap, and the postcondition is preserved across all steps. *)
  Lemma hoare_triple_sound' : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => hoare_triple (fun h => h = snd p)
                                                          (fst p)
                                                          Q).
  Proof.
    simplify.

    apply invariant_induction; simplify.

    propositional; subst; simplify.
    eapply HtConsequence.
    eassumption.
    equality.
    auto.

    eapply step_sound in H1.
    rewrite H2 in H1.
    auto.
  Qed.

  (* Proving: if we reach a [Return] state, the postcondition holds. *)
  Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => forall r, fst p = Return r
                                                       -> Q r (snd p)).
  Proof.
    simplify.

    eapply invariant_weaken.
    eapply hoare_triple_sound'; eauto.
    simplify.
    rewrite H2 in H1.
    eapply invert_Return; eauto.
    simplify; auto.
  Qed.
End Deeper.

Extraction "Deeper.ml" Deeper.index_of.

(** * Adding the possibility of program failure *)

(* Let's model another effect that can be implemented using native OCaml
 * features.  We'll add a very basic form of exceptions, namely just one
 * (uncatchable) exception, for program failure.  We'll prove, by the end, that
 * verified programs never throw the exception. *)

Module DeeperWithFail.
  Inductive loop_outcome acc :=
  | Done (a : acc)
  | Again (a : acc).

  Inductive cmd : Set -> Type :=
  | Return {result : Set} (r : result) : cmd result
  | Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
  | Read (a : nat) : cmd nat
  | Write (a v : nat) : cmd unit
  | Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc
  | Fail {result} : cmd result.

  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
  Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

  (* This program loops forever, maintaining a tally in memory address 0.
   * We periodically test that address, failing if it's ever found to be 0. *)
  Definition forever : cmd nat :=
    _ <- Write 0 1;
    for i := 1 loop
      h_i <- Read i;
      acc <- Read 0;
      match acc with
      | 0 => Fail
      | _ =>
        _ <- Write 0 (acc + h_i);
        Return (Again (i + 1))
      end
    done.

  (* We adapt our single-stepper with a new result kind, for failure. *)

  Inductive stepResult (result : Set) :=
  | Answer (r : result)
  | Stepped (h : heap) (c : cmd result)
  | Failed.

  Arguments Failed {result}.

  Fixpoint step {result} (c : cmd result) (h : heap) : stepResult result :=
    match c with
    | Return _ r => Answer r
    | Bind _ _ c1 c2 =>
      match step c1 h with
      | Answer r => Stepped h (c2 r)
      | Stepped h' c1' => Stepped h' (Bind c1' c2)
      | Failed => Failed
      end
    | Read a => Answer (h $! a)
    | Write a v => Stepped (h $+ (a, v)) (Return tt)
    | Loop _ init body =>
      Stepped h (r <- body init;
                 match r with
                 | Done r' => Return r'
                 | Again r' => Loop r' body
                 end)
    | Fail _ => Failed
    end.

  Fixpoint multiStep {result} (c : cmd result) (h : heap) (n : nat) : stepResult result :=
    match n with
    | O => Stepped h c
    | S n' => match step c h with
              | Answer r => Answer r
              | Stepped h' c' => multiStep c' h' n'
              | Failed => Failed
              end
    end.

  Inductive hoare_triple : assertion -> forall {result}, cmd result -> (result -> assertion) -> Prop :=
  | HtReturn : forall P {result : Set} (v : result),
      hoare_triple P (Return v) (fun r h => P h /\ r = v)
  | HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
      hoare_triple P c1 Q
      -> (forall r, hoare_triple (Q r) (c2 r) R)
      -> hoare_triple P (Bind c1 c2) R
  | HtRead : forall P a,
      hoare_triple P (Read a) (fun r h => P h /\ r = h $! a)
  | HtWrite : forall P a v,
      hoare_triple P (Write a v) (fun _ h => exists h', P h' /\ h = h' $+ (a, v))
  | HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P' c Q'

  | HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) I,
      (forall acc, hoare_triple (I (Again acc)) (body acc) I)
      -> hoare_triple (I (Again init)) (Loop init body) (fun r h => I (Done r) h)

  | HtFail : forall {result},
      hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False).
    (* The rule for [Fail] simply enforces that this command can't be reachable,
     * since it gets an unsatisfiable precondition. *)

  Notation "{{ h ~> P }} c {{ r & h' ~> Q }}" :=
    (hoare_triple (fun h => P) c (fun r h' => Q)) (at level 90, c at next level).

  Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
      hoare_triple P c Q
      -> (forall r h, Q r h -> Q' r h)
      -> hoare_triple P c Q'.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : assertion),
      hoare_triple P c Q
      -> (forall h, P' h -> P h)
      -> hoare_triple P' c Q.
  Proof.
    simplify.
    eapply HtConsequence; eauto.
  Qed.

  Ltac basic := apply HtReturn || eapply HtRead || eapply HtWrite.
  Ltac step0 := basic || eapply HtBind || (eapply HtStrengthen; [ basic | ])
                || (eapply HtConsequence; [ apply HtFail | .. ]).
  Ltac step := step0; simp.
  Ltac ht := simp; repeat step.
  Ltac conseq := simplify; eapply HtConsequence.
  Ltac use_IH H := conseq; [ apply H | .. ]; ht.
  Ltac loop_inv0 Inv := (eapply HtWeaken; [ apply HtLoop with (I := Inv) | .. ])
                        || (eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]).
  Ltac loop_inv Inv := loop_inv0 Inv; ht.

  Theorem forever_ok :
    {{ _ ~> True }}
      forever
    {{ _&_ ~> False }}.
  Proof.
    ht.
    loop_inv (fun (r : loop_outcome nat) h => h $! 0 > 0 /\ match r with
                                                            | Done _ => False
                                                            | _ => True
                                                            end).
    cases r1; ht.
  Qed.

  Definition trsys_of {result} (c : cmd result) (h : heap) := {|
    Initial := {(c, h)};
    Step := fun p1 p2 => step (fst p1) (snd p1) = Stepped (snd p2) (fst p2)
  |}.

  (* Next, we adapt the proof of soundness from before. *)

  Lemma invert_Return : forall {result : Set} (r : result) P Q,
    hoare_triple P (Return r) Q
    -> forall h, P h -> Q r h.
  Proof.
    induct 1; propositional; eauto.
  Qed.

  Lemma invert_Bind : forall {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
    hoare_triple P (Bind c1 c2) Q
    -> exists R, hoare_triple P c1 R
                 /\ forall r, hoare_triple (R r) (c2 r) Q.
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    eexists; propositional.
    eapply HtWeaken.
    eassumption.
    auto.
    eapply HtStrengthen.
    apply H4.
    auto.
  Qed.

  Lemma unit_not_nat : unit = nat -> False.
  Proof.
    simplify.
    assert (exists x : unit, forall y : unit, x = y).
    exists tt; simplify.
    cases y; reflexivity.
    rewrite H in H0.
    invert H0.
    specialize (H1 (S x)).
    linear_arithmetic.
  Qed.

  Lemma invert_Read : forall a P Q,
    hoare_triple P (Read a) Q
    -> forall h, P h -> Q (h $! a) h.
  Proof.
    induct 1; propositional; eauto.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Write : forall a v P Q,
    hoare_triple P (Write a v) Q
    -> forall h, P h -> Q tt (h $+ (a, v)).
  Proof.
    induct 1; propositional; eauto.
    symmetry in x0.
    apply unit_not_nat in x0.
    propositional.
  Qed.

  Lemma invert_Loop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
      hoare_triple P (Loop init body) Q
      -> exists I, (forall acc, hoare_triple (I (Again acc)) (body acc) I)
                   /\ (forall h, P h -> I (Again init) h)
                   /\ (forall r h, I (Done r) h -> Q r h).
  Proof.
    induct 1; propositional; eauto.

    invert IHhoare_triple; propositional.
    exists x; propositional; eauto.
  Qed.

  Lemma invert_Fail : forall result P Q,
    hoare_triple P (Fail (result := result)) Q
    -> forall h, P h -> False.
  Proof.
    induct 1; propositional; eauto.
  Qed.

  Lemma step_sound : forall {result} (c : cmd result) h Q,
      hoare_triple (fun h' => h' = h) c Q
      -> match step c h with
         | Answer r => Q r h
         | Stepped h' c' => hoare_triple (fun h'' => h'' = h') c' Q
         | Failed => False
         end.
  Proof.
    induct c; simplify; propositional.

    eapply invert_Return.
    eauto.
    simplify; auto.

    apply invert_Bind in H0.
    invert H0; propositional.
    apply IHc in H0.
    cases (step c h); auto.
    econstructor.
    apply H2.
    equality.
    auto.
    econstructor; eauto.

    eapply invert_Read; eauto.
    simplify; auto.

    eapply HtStrengthen.
    econstructor.
    simplify; propositional; subst.
    eapply invert_Write; eauto.
    simplify; auto.

    apply invert_Loop in H0.
    invert H0; propositional.
    econstructor.
    eapply HtWeaken.
    apply H0.
    equality.
    simplify.
    cases r.
    eapply HtStrengthen.
    econstructor.
    simplify.
    propositional; subst; eauto.
    eapply HtStrengthen.
    eapply HtLoop.
    auto.
    simplify.
    eauto.

    eapply invert_Fail; eauto.
    simplify; eauto.
  Qed.

  Lemma hoare_triple_sound' : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => hoare_triple (fun h => h = snd p)
                                                          (fst p)
                                                          Q).
  Proof.
    simplify.

    apply invariant_induction; simplify.

    propositional; subst; simplify.
    eapply HtConsequence.
    eassumption.
    equality.
    auto.

    eapply step_sound in H1.
    rewrite H2 in H1.
    auto.
  Qed.

  Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
      hoare_triple P c Q
      -> forall h, P h
                   -> invariantFor (trsys_of c h)
                                   (fun p => step (fst p) (snd p) <> Failed).
  Proof.
    simplify.

    eapply invariant_weaken.
    eapply hoare_triple_sound'; eauto.
    simplify.
    eapply step_sound in H1.
    cases (step (fst s) (snd s)); equality.
  Qed.

  (** ** Showcasing the opportunity to create new programming abstractions,
       * without modifying the language definition *)

  (* Here's an example of a new programming construct defined within Gallina,
   * without extending the definition of object-language syntax.  It's for
   * folding a command over every one of the first [len] cells in memory.  We
   * work with some accumulator type [A], initializing the accumulator to [init]
   * and calling [combine] to update the accumulator for each value we read out
   * of memory. *)
  Definition heapfold {A : Set} (init : A) (combine : A -> nat -> cmd A) (len : nat) : cmd A :=
    p <- for p := (0, init) loop
           if len <=? fst p then
             Return (Done p)
           else
             h_i <- Read (fst p);
             acc <- combine (snd p) h_i;
             Return (Again (S (fst p), acc))
         done;
    Return (snd p).

  (* Next, two pretty mundane facts about list operations. *)

  Lemma firstn_nochange : forall A (ls : list A) n,
      length ls <= n
      -> firstn n ls = ls.
  Proof.
    induct ls; simplify.

    cases n; simplify; auto.

    cases n; simplify.
    linear_arithmetic.
    rewrite IHls; auto.
  Qed.

  Lemma fold_left_firstn : forall A B (f : A -> B -> A) (d : B) (ls : list B) (init : A) n,
      n < length ls
      -> f (fold_left f (firstn n ls) init) (nth_default d ls n)
         = fold_left f (firstn (S n) ls) init.
  Proof.
    induct ls; simplify.
    linear_arithmetic.
    cases n; simplify.
    unfold nth_default; simplify.
    reflexivity.
    rewrite <- IHls by linear_arithmetic.
    unfold nth_default; simplify.
    reflexivity.
  Qed.

  Local Hint Rewrite firstn_nochange fold_left_firstn using linear_arithmetic : core.

  (* Here's the soundness theorem for [heapfold], relying on a hypothesis of
   * soundness for [combine]. *)
  Theorem heapfold_ok : forall {A : Set} (init : A) combine
                               (ls : list nat) (f : A -> nat -> A),
    (forall P v acc,
      {{h ~> P h}}
        combine acc v
      {{r&h ~> r = f acc v /\ P h}})
    -> {{h ~> forall i, i < length ls -> h $! i = nth_default 0 ls i}}
         heapfold init combine (length ls)
       {{r&h ~> (forall i, i < length ls -> h $! i = nth_default 0 ls i)
           /\ r = fold_left f ls init}}.
  Proof.
    ht.
    loop_inv (fun r h => (forall i, i < length ls -> h $! i = nth_default 0 ls i)
                         /\ match r with
                            | Done (_, acc) => acc = fold_left f ls init
                            | Again (i, acc) => acc = fold_left f (firstn i ls) init
                            end).
    cases (length ls <=? a); ht; auto; simp; auto.
    rewrite H2 by assumption.
    simplify.
    reflexivity.
    simp; auto.
    simp.
  Qed.

  (* Here's a concrete use of [heapfold], to implement [array_max] more
   * succinctly. *)
  Definition array_max (len : nat) : cmd nat :=
    heapfold 0 (fun n m => Return (max n m)) len.

  (* Next, some more lemmas about lists and arithmetic *)

  Lemma le_max' : forall v ls acc,
      v <= acc
      -> v <= fold_left max ls acc.
  Proof.
    induct ls; simplify; auto.
  Qed.

  Lemma le_max : forall ls i acc,
      i < Datatypes.length ls
      -> nth_default 0 ls i <= fold_left max ls acc.
  Proof.
    induct ls; simplify.

    linear_arithmetic.

    cases i; simplify.
    unfold nth_default; simplify.
    apply le_max'; linear_arithmetic.
    unfold nth_default; simplify.
    apply IHls; linear_arithmetic.
  Qed.

  Local Hint Resolve le_max : core.

  (* Finally, a short proof of [array_max], appealing mostly to the generic
   * proof of [heapfold] *)
  Theorem array_max_ok : forall ls : list nat,
    {{ h ~> forall i, i < length ls -> h $! i = nth_default 0 ls i}}
      array_max (length ls)
    {{ r&h ~> forall i, i < length ls -> h $! i <= r }}.
  Proof.
    conseq.
    apply heapfold_ok with (f := max); ht.
    simp; auto.
    simp.
    rewrite H1 by assumption.
    auto.
  Qed.
End DeeperWithFail.

Extraction "DeeperWithFail.ml" DeeperWithFail.forever.


Require Import VST.floyd.proofauto.
Require Import VST.progs.sumarray.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.
Definition Gprog: funspecs := nil.
Definition Delta1 : tycontext :=
  ltac:(let x := constr:(func_tycontext f_sumarray Vprog Gprog nil)
         in let y := eval hnf in x
         in exact y).

(* This example is from the "EX, Intros, Exists" chapter of the Verifiable C Reference Manual *)
Lemma exercise1:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
 ENTAIL Delta,
   EX x:Z,
    PROP(0<=x) LOCAL(temp _i (Vint (Int.repr x)))
    SEP (EX y:Z, !!(x<y) && data_at sh tint (Vint (Int.repr y)) p)
|-- EX u: Z,
     PROP(0<u) LOCAL()
     SEP (data_at sh tint (Vint (Int.repr u)) p).
Proof.
intros.
Intros a b.
Exists b.
entailer!.
Qed.

(* These examples of [rep_omega] are from is from the "Integers: nat, Z, int" chapter of the Verifiable C Reference Manual *)
Lemma exercise2:
  forall x,
  Int.min_signed <= x <= Int.max_signed ->
  Int.signed (Int.repr x) = x.
Proof.
intros x H.
(* Notice that the premise H is needed for the next line *)
rewrite Int.signed_repr by rep_omega.
auto.
Qed.

Lemma exercise3:
  forall n, 0 <= n <= Int.max_signed ->
  Int.min_signed <= 0 <= n.
Proof.
intros.
rep_omega.
Qed.

Lemma exercise3b:
  forall al: list Z ,  Zlength al < 50 ->
         0 <= Zlength al < Int.max_signed.
Proof.
intros.
rep_omega.
Qed.

Lemma exercise3c:
  forall i,
         0 <= Int.unsigned (Int.repr i) <= Int.max_unsigned.
Proof.
intros.
rep_omega.
Qed.

(**  How to manage semi-opaque constants, using Hint Rewrite : rep_omega. *)
(* Suppose you have an uninitialized array of size N: *)

Definition N : Z := 20.

Lemma exercise4:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: list_repeat (Z.to_nat (N-2)) Vundef) p
 |--  !! (0 <= Zlength (list_repeat (Z.to_nat (N-2)) Vundef) < Int.max_signed).
Proof.
intros.
simpl.
(* It's not nice that [simpl] unfolded the list_repeat. *)
entailer!.
repeat rewrite Zlength_cons. rewrite Zlength_nil.
rep_omega.
Abort.

(* To avoid unfolding of the list_repeat, let us make N opaque. *)

Global Opaque N.

Lemma exercise4b:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: list_repeat (Z.to_nat (N-2)) Vundef) p
 |--  !! (0 <= Zlength (list_repeat (Z.to_nat (N-2)) Vundef) < Int.max_signed).
Proof.
intros.
simpl.
(* That's better; the data_at is more concise.  But now, unfortunately: *)
entailer!.
rewrite Zlength_list_repeat.
Fail rep_omega.
(* now rep_omega does not know that N=20. *)
Abort.

(* To tell rep_omega that N=20, just add a hint to the rep_omega database: *)

Lemma N_eq: N=20.
Proof. reflexivity. Qed.
Hint Rewrite N_eq : rep_omega.

Lemma exercise4c:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: list_repeat (Z.to_nat (N-2)) Vundef) p
 |--  !! (0 <= Zlength (list_repeat (Z.to_nat (N-2)) Vundef) < Int.max_signed).
Proof.
intros.
simpl.
(* That's still good; the data_at is more concise.  *)
entailer!.
rewrite Zlength_list_repeat.
rep_omega.
rep_omega.
Qed.

(* Summary: Make your constant Global Opaque, but add a Hint Rewrite rule to the rep_omega database. *)