(*
  Copyright (c) 2016-2020, Adam Chlipala
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are met:

  - Redistributions of source code must retain the above copyright notice,
    this list of conditions and the following disclaimer.
  - Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
  - The names of contributors may not be used to endorse or promote products
    derived from this software without specific prior written permission.

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  POSSIBILITY OF SUCH DAMAGE.
*)

Require Import Bool Classical FunctionalExtensionality List.

Set Implicit Arguments.

Axiom prop_ext : forall P Q : Prop,
  (P <-> Q) -> P = Q.

Section set.
  Variable A : Type.

  Definition set := A -> Prop.
  Definition In (x : A) (s : set) := s x.

  Definition constant (ls : list A) : set := fun x => List.In x ls.
  Definition universe : set := fun _ => True.
  Definition check (P : Prop) : set := fun _ => P.

  Definition union (s1 s2 : set) : set := fun x => s1 x \/ s2 x.
  Definition intersection (s1 s2 : set) : set := fun x => s1 x /\ s2 x.
  Definition minus (s1 s2 : set) : set := fun x => s1 x /\ ~s2 x.
  Definition complement (s : set) : set := fun x => ~s x.

  Definition subseteq (s1 s2 : set) := forall x, s1 x -> s2 x.
  Definition subset (s1 s2 : set) := subseteq s1 s2 /\ ~subseteq s2 s1.

  Definition scomp (P : A -> Prop) : set := P.

  Theorem sets_equal : forall s1 s2 : set, (forall x, s1 x <-> s2 x) -> s1 = s2.
  Proof.
    intros.
    apply functional_extensionality; intros.
    apply prop_ext; auto.
  Qed.
End set.

Infix "\in" := In (at level 70).
(*Notation "[ P ]" := (check P).*)
Infix "\cup" := union (at level 40).
Infix "\cap" := intersection (at level 40).
Infix "\setminus" := minus (at level 40).
Infix "\subseteq" := subseteq (at level 70).
Infix "\subset" := subset (at level 70).
Notation "[ x | P ]" := (scomp (fun x => P)).

Module Type EMPTY.
End EMPTY.
Module SetNotations(M : EMPTY).
  Notation "{ }" := (constant nil).
  Notation "{ x1 , .. , xN }" := (constant (cons x1 (.. (cons xN nil) ..))).
End SetNotations.

Ltac sets' tac :=
  unfold In, constant, universe, check, union, intersection, minus, complement, subseteq, subset, scomp in *;
    tauto || intuition tac.

Ltac sets tac :=
  try match goal with
        | [ |- @eq (set _) _ _ ] => apply sets_equal; intro; split
      end; sets' tac.

(** * Some of the usual properties of set operations *)

Section properties.
  Variable A : Type.
  Variable x : A.
  Variables s1 s2 s3 : set A.

  Theorem union_comm : s1 \cup s2 = s2 \cup s1.
  Proof.
    sets idtac.
  Qed.

  Theorem union_assoc : (s1 \cup s2) \cup s3 = s1 \cup (s2 \cup s3).
  Proof.
    sets idtac.
  Qed.

  Theorem intersection_comm : s1 \cap s2 = s2 \cap s1.
  Proof.
    sets idtac.
  Qed.

  Theorem intersection_assoc : (s1 \cap s2) \cap s3 = s1 \cap (s2 \cap s3).
  Proof.
    sets idtac.
  Qed.

  Theorem not_union : complement (s1 \cup s2) = complement s1 \cap complement s2.
  Proof.
    sets idtac.
  Qed.

  Theorem not_intersection : complement (s1 \cap s2) = complement s1 \cup complement s2.
  Proof.
    sets idtac.
  Qed.

  Theorem subseteq_refl : s1 \subseteq s1.
  Proof.
    unfold subseteq; eauto.
  Qed.

  Theorem subseteq_In : s1 \subseteq s2 -> x \in s1 -> x \in s2.
  Proof.
    unfold subseteq, In; eauto.
  Qed.

  Theorem cap_split : forall (P1 P2 : A -> Prop),
    (forall s, P1 s \/ P2 s)
    -> s1 \cap [s | P1 s] \subseteq s2
    -> s1 \cap [s | P2 s] \subseteq s3
    -> s1 \subseteq (s2 \cap [s | P1 s]) \cup (s3 \cap [s | P2 s]).
  Proof.
    intros; sets eauto.
    specialize (H x0).
    specialize (H0 x0).
    specialize (H1 x0).
    tauto.
  Qed.

  Variables ss1 ss2 : list A.

  Theorem union_constant : constant ss1 \cup constant ss2 = constant (ss1 ++ ss2).
  Proof.
    unfold constant, union; simpl.

    apply sets_equal; simpl; intuition.
  Qed.
End properties.

#[global]
Hint Resolve subseteq_refl subseteq_In : core.

(*Hint Rewrite union_constant.*)

(** * Removing duplicates from constant sets *)

Inductive removeDups A : list A -> list A -> Prop :=
| RdNil : removeDups nil nil
| RdNew : forall x ls ls',
  ~List.In x ls
  -> removeDups ls ls'
  -> removeDups (x :: ls) (x :: ls')
| RdDup : forall x ls ls',
  List.In x ls
  -> removeDups ls ls'
  -> removeDups (x :: ls) ls'.

Theorem removeDups_fwd : forall A x (ls ls' : list A),
  removeDups ls ls'
  -> List.In x ls
  -> List.In x ls'.
Proof.
  induction 1; simpl; intuition.
  subst; eauto.
Qed.

Theorem removeDups_bwd : forall A x (ls ls' : list A),
  removeDups ls ls'
  -> List.In x ls'
  -> List.In x ls.
Proof.
  induction 1; simpl; intuition.
Qed.

Theorem removeDups_ok : forall A (ls ls' : list A),
  removeDups ls ls'
  -> constant ls = constant ls'.
Proof.
  intros.
  apply sets_equal.
  unfold constant; intuition eauto using removeDups_fwd, removeDups_bwd.
Qed.

Ltac someMatch ls :=
  match ls with
  | ?x :: ?ls' =>
    let rec someMatch' ls :=
        match ls with
        | x :: _ => idtac
        | _ :: ?ls' => someMatch' ls'
        end
    in someMatch' ls'
  | _ :: ?ls' => someMatch ls'
  end.

Ltac removeDups :=
  match goal with
  | [ |- context[constant ?ls] ] =>
    someMatch ls;
    erewrite (@removeDups_ok _ ls)
      by repeat (apply RdNil
                 || (apply RdNew; [ simpl; intuition congruence | ])
                 || (apply RdDup; [ simpl; intuition congruence | ]))
  end.

(** * Simplifying set subtraction with constant sets *)

Inductive doSubtract A : list A -> list A -> list A -> Prop :=
| DsNil : forall ls, doSubtract nil ls nil
| DsKeep : forall x ls ls0 ls',
  ~List.In x ls0
  -> doSubtract ls ls0 ls'
  -> doSubtract (x :: ls) ls0 (x :: ls')
| DsDrop : forall x ls ls0 ls',
  List.In x ls0
  -> doSubtract ls ls0 ls'
  -> doSubtract (x :: ls) ls0 ls'.

Theorem doSubtract_fwd : forall A x (ls ls0 ls' : list A),
  doSubtract ls ls0 ls'
  -> List.In x ls
  -> ~List.In x ls0
  -> List.In x ls'.
Proof.
  induction 1; simpl; intuition.
  subst; eauto.
  tauto.
Qed.

Theorem doSubtract_bwd1 : forall A x (ls ls0 ls' : list A),
  doSubtract ls ls0 ls'
  -> List.In x ls'
  -> List.In x ls.
Proof.
  induction 1; simpl; intuition.
Qed.

Theorem doSubtract_bwd2 : forall A x (ls ls0 ls' : list A),
  doSubtract ls ls0 ls'
  -> List.In x ls'
  -> List.In x ls0
  -> False.
Proof.
  induction 1; simpl; intuition.
  subst; eauto.
Qed.

Theorem doSubtract_ok : forall A (ls ls0 ls' : list A),
  doSubtract ls ls0 ls'
  -> constant ls \setminus constant ls0 = constant ls'.
Proof.
  unfold minus.
  intros.
  apply sets_equal.
  unfold constant; intuition eauto using doSubtract_fwd, doSubtract_bwd1, doSubtract_bwd2.
Qed.

Ltac fancy_neq :=
  solve [ repeat match goal with
                 | [ H : @eq (nat -> _) _ _ |- _ ] => apply (f_equal (fun f => f 0)) in H
                 | [ H : _ = _ |- _ ] => inversion H; clear H; subst
                 end ].

Ltac doSubtract :=
  match goal with
  | [ |- context[@minus ?A (@constant ?A1 ?ls) (@constant ?A2 ?ls0)] ] =>
    match A with
    | A1 => idtac
    | _ => change (@constant A1 ls) with (@constant A ls)
    end;
    match A with
    | A2 => idtac
    | _ => change (@constant A2 ls0) with (@constant A ls0)
    end;
    erewrite (@doSubtract_ok A ls ls0)
      by repeat (apply DsNil
                 || (apply DsKeep; [ simpl; intuition (congruence || fancy_neq) | ])
                 || (apply DsDrop; [ simpl; intuition congruence | ]))
  end.

(** Undetermined set variables in fixed points should be turned into the empty set. *)
Ltac unifyTails :=
  match goal with
  | [ |- context[_ \cup ?x] ] => is_evar x;
    match type of x with
    | set ?A => unify x (constant (@nil A))
    | ?A -> Prop => unify x (constant (@nil A))
    end
  end.

(** * But wait... there's a reflective way to do some of this, too. *)

Require Import Arith.
Import List ListNotations.

Section setexpr.
  Variable A : Type.

  Inductive setexpr :=
  | Literal (vs : list nat)
  | Constant (s : set A)
  | Union (e1 e2 : setexpr).

  Fixpoint interp_setexpr (env : list A) (e : setexpr) : set A :=
    match e with
    | Literal vs =>
      match env with
      | [] => constant []
      | x :: _ => constant (map (nth_default x env) vs)
      end
    | Constant s => s
    | Union e1 e2 => interp_setexpr env e1 \cup interp_setexpr env e2
    end.

  Record normal_form := {
    Elements : list nat;
    Other : option (set A)
  }.

  Fixpoint member (n : nat) (ls : list nat) : bool :=
    match ls with
    | [] => false
    | m :: ls' => (n =? m) || member n ls'
    end.

  Fixpoint dedup (ls : list nat) : list nat :=
    match ls with
    | [] => []
    | n :: ls =>
      let ls' := dedup ls in
      if member n ls' then ls' else n :: ls'
    end.

  Fixpoint setmerge (ls1 ls2 : list nat) : list nat :=
    match ls1 with
    | [] => ls2
    | n :: ls1' =>
      if member n ls2 then setmerge ls1' ls2 else n :: setmerge ls1' ls2
    end.

  Fixpoint normalize_setexpr (e : setexpr) : normal_form :=
    match e with
    | Literal vs => {| Elements := dedup vs; Other := None |}
    | Constant s => {| Elements := []; Other := Some s |}
    | Union e1 e2 =>
      let nf1 := normalize_setexpr e1 in
      let nf2 := normalize_setexpr e2 in
        {| Elements := setmerge nf1.(Elements) nf2.(Elements);
           Other := match nf1.(Other), nf2.(Other) with
                    | None, None => None
                    | o, None => o
                    | None, o => o
                    | Some s1, Some s2 => Some (s1 \cup s2)
                    end |}
    end.

  Definition interp_normal_form (env : list A) (nf : normal_form) : set A :=
    let cs := match env with
              | [] => constant []
              | x :: _ => constant (map (nth_default x env) nf.(Elements))
              end in
    match nf.(Other) with
    | None => cs
    | Some o => cs \cup o
    end.

  Lemma member_ok : forall n ns,
      if member n ns then In n ns else ~In n ns.
  Proof.
    induction ns; simpl; intuition.
    case_eq (n =? a); simpl; intros.
    apply beq_nat_true in H; auto.
    apply beq_nat_false in H.
    destruct (member n ns); intuition.
  Qed.

  Lemma In_dedup_fwd : forall n ns,
      In n (dedup ns)
      -> In n ns.
  Proof.
    induction ns; simpl; intuition.
    pose proof (member_ok a (dedup ns)).
    destruct (member a (dedup ns)); simpl in *; intuition.
  Qed.

  Lemma In_dedup_bwd : forall n ns,
      In n ns
      -> In n (dedup ns).
  Proof.
    induction ns; simpl; intuition.
    pose proof (member_ok a (dedup ns)).
    destruct (member a (dedup ns)); simpl in *; intuition congruence.
    pose proof (member_ok a (dedup ns)).
    destruct (member a (dedup ns)); simpl in *; intuition congruence.
  Qed.

  Lemma constant_dedup : forall (f : _ -> A) vs,
      constant (map f (dedup vs)) = constant (map f vs).
  Proof.
    induction vs; simpl; intuition.
    pose proof (member_ok a (dedup vs)).
    case_eq (member a (dedup vs)); intro.
    rewrite IHvs.
    rewrite H0 in H.
    apply In_dedup_fwd in H.
    apply sets_equal.
    unfold constant.
    simpl.
    intuition.
    apply in_map_iff.
    eauto.
    simpl.
    apply sets_equal.
    simpl.
    intuition congruence.
  Qed.

  Lemma constant_map_setmerge : forall (f : _ -> A) ns2 ns1,
      constant (map f (setmerge ns1 ns2)) = constant (map f ns1) \cup constant (map f ns2).
  Proof.
    induction ns1; simpl; intros.

    sets ltac:(simpl in *; intuition).

    pose proof (member_ok a ns2).
    destruct (member a ns2).
    rewrite IHns1.
    sets ltac:(simpl in *; intuition).
    right.
    eapply in_map_iff; eauto.

    simpl.
    sets ltac:(simpl in *; intuition).
    change (In x (map f (setmerge ns1 ns2))) with ((fun x => In x (map f (setmerge ns1 ns2))) x) in H1.
    rewrite IHns1 in H1.
    tauto.
    change (In x (map f (setmerge ns1 ns2))) with ((fun x => In x (map f (setmerge ns1 ns2))) x).
    rewrite IHns1.
    tauto.
    change (In x (map f (setmerge ns1 ns2))) with ((fun x => In x (map f (setmerge ns1 ns2))) x).
    rewrite IHns1.
    tauto.
  Qed.

  Theorem normalize_setexpr_ok : forall env e,
      interp_normal_form env (normalize_setexpr e) = interp_setexpr env e.
  Proof.
    induction e; simpl; intros.

    unfold interp_normal_form; simpl.
    destruct env; trivial.
    apply constant_dedup.

    unfold interp_normal_form; simpl.
    destruct env; sets ltac:(simpl in *; intuition).

    unfold interp_normal_form in *; simpl in *.
    destruct (Other (normalize_setexpr e1)), (Other (normalize_setexpr e2)).
    destruct env.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
    rewrite <- IHe1.
    rewrite <- IHe2.
    rewrite constant_map_setmerge.
    sets ltac:(simpl in *; intuition).
    destruct env.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
    rewrite constant_map_setmerge.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
    destruct env.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
    rewrite constant_map_setmerge.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
    destruct env.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
    rewrite constant_map_setmerge.
    rewrite <- IHe1.
    rewrite <- IHe2.
    sets ltac:(simpl in *; intuition).
  Qed.

  Fixpoint included (ns1 ns2 : list nat) : bool :=
    match ns1 with
    | [] => true
    | n :: ns1' => member n ns2 && included ns1' ns2
    end.

  Lemma included_true : forall ns2 ns1,
      included ns1 ns2 = true
      -> (forall x, In x ns1 -> In x ns2).
  Proof.
    induction ns1; simpl; intuition subst.

    pose proof (member_ok x ns2).
    destruct (member x ns2); simpl in *; auto; congruence.

    pose proof (member_ok a ns2).
    destruct (member a ns2); simpl in *; auto; congruence.
  Qed.

  Theorem compare_sets : forall env e1 e2,
      let nf1 := normalize_setexpr e1 in
      let nf2 := normalize_setexpr e2 in
      match Other nf1, Other nf2 with
      | None, None => included nf1.(Elements) nf2.(Elements)
                      && included nf2.(Elements) nf1.(Elements) = true
      | _, _ => False
      end
      -> interp_setexpr env e1 = interp_setexpr env e2.
  Proof.
    intros.
    do 2 rewrite <- normalize_setexpr_ok.
    subst nf1.
    subst nf2.
    unfold interp_normal_form.
    destruct (Other (normalize_setexpr e1)), (Other (normalize_setexpr e2)); intuition.
    destruct env; trivial.
    apply andb_true_iff in H; intuition.
    specialize (included_true _ _ H0).
    specialize (included_true _ _ H1).
    clear H0 H1.
    intros.
    apply sets_equal.
    unfold constant; simpl; intuition.
    apply in_map_iff.
    apply in_map_iff in H1.
    firstorder.
    apply in_map_iff.
    apply in_map_iff in H1.
    firstorder.
  Qed.
End setexpr.

Ltac quote E env k :=
  let T := type of E in
  match eval hnf in T with
  | ?A -> Prop =>
    let rec lookup E env k :=
        match env with
        | [] => k 0 [E]
        | E :: _ => k 0 env
        | ?E' :: ?env' =>
          lookup E env' ltac:(fun pos env'' => k (S pos) (E' :: env''))
        end in

    let rec lookups Es env k :=
        match Es with
        | [] => k (@nil nat) env
        | ?E :: ?Es' =>
          lookup E env ltac:(fun pos env' =>
              lookups Es' env' ltac:(fun poss env'' =>
                                       k (pos :: poss) env''))
        end in

    let rec quote' E env k :=
        match E with
        | constant ?Es =>
          lookups Es env ltac:(fun poss env' => k (Literal A poss) env')
        | ?E1 \cup ?E2 =>
          quote' E1 env ltac:(fun e1 env' =>
            quote' E2 env' ltac:(fun e2 env'' =>
              k (Union e1 e2) env''))
        | _ =>
          (let pf := constr:(eq_refl : E = constant []) in
           k (Literal A []) env)
          || k (Constant E) env
        end in

    quote' E env k
  end.

Ltac sets_cbv := cbv beta iota zeta delta [interp_normal_form normalize_setexpr nth_default
                                           setmerge Elements Other nth_error map dedup member beq_nat orb
                                           andb included].

Ltac sets_cbv_in H := cbv beta iota zeta delta [interp_normal_form normalize_setexpr nth_default
                                                                   setmerge Elements Other nth_error map dedup member beq_nat orb
                                                                   andb included] in H.

Ltac normalize_set :=
  match goal with
  | [ |- context[@union ?A ?X ?Y] ] =>
    quote (@union A X Y) (@nil A) ltac:(fun e env =>
      change (@union A X Y) with (interp_setexpr env e));
    rewrite <- normalize_setexpr_ok; sets_cbv
  | [ H : context[@union ?A ?X ?Y] |- _ ] =>
    quote (@union A X Y) (@nil A) ltac:(fun e env =>
      change (@union A X Y) with (interp_setexpr env e) in H);
    rewrite <- normalize_setexpr_ok in H; sets_cbv_in H
  end.

Ltac compare_sets :=
  match goal with
  | [ |- @eq ?T ?X ?Y ] =>
    match eval hnf in T with
    | ?A -> _ =>
      quote X (@nil A) ltac:(fun x env =>
        quote Y env ltac:(fun y env' =>
          change (interp_setexpr env' x = interp_setexpr env' y)));
      apply compare_sets; sets_cbv; reflexivity
    end
  end.


Set Warnings "-notation-overridden,-parsing".
Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import omega.Omega.
From Coq Require Import Logic.FunctionalExtensionality.
Require Import Imp.

Definition Assertion := state -> Prop.

Module ExAssertions.
Definition as1 : Assertion := fun st => st X = 3.
Definition as2 : Assertion := fun st => st X <= st Y.
Definition as3 : Assertion :=
  fun st => st X = 3 \/ st X <= st Y.
Definition as4 : Assertion :=
  fun st => st Z * st Z <= st X /\
            ~ (((S (st Z)) * (S (st Z))) <= st X).
Definition as5 : Assertion :=
  fun st => st Z = max (st X) (st Y).
Definition as6 : Assertion := fun st => True.
Definition as7: Assertion := fun st => False.

End ExAssertions.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition Aexp : Type := state -> nat.

Definition assert_of_Prop (P : Prop) : Assertion := fun _ => P.
Definition Aexp_of_nat (n : nat) : Aexp := fun _ => n.

Definition Aexp_of_aexp (a : aexp) : Aexp := fun st => aeval st a.

Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.

Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.

Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.

Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).

Notation "~ P" := (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q" := (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q" := (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q" := (fun st => assert P st ->  assert Q st) : assertion_scope.
Notation "P <-> Q" := (fun st => assert P st <->  assert Q st) : assertion_scope.
Notation "a = b" := (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b" := (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b" := (fun st => mkAexp a st <= mkAexp b st) : assertion_scope.
Notation "a < b" := (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b" := (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b" := (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b" := (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b" := (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b" := (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

Definition ap {X} (f : nat -> X) (x : Aexp) :=
  fun st => f (x st).

Definition ap2 {X} (f : nat -> nat -> X) (x : Aexp) (y : Aexp) (st : state) :=
  f (x st) (y st).

Module ExPrettyAssertions.
Definition as1 : Assertion := X = 3.
Definition as2 : Assertion := X <= Y.
Definition as3 : Assertion := X = 3 \/ X <= Y.
Definition as4 : Assertion :=
  Z * Z <= X /\
            ~ (((ap S Z) * (ap S Z)) <= X).
Definition as5 : Assertion :=
  Z = ap2 max X Y.
Definition as6 : Assertion := True.
Definition as7 : Assertion := False.
End ExPrettyAssertions.

Definition hoare_triple
           (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
     st =[ c ]=> st'  ->
     P st  ->
     Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  apply H.  Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~ (P st)) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  unfold not in H. apply H in HP.
  inversion HP.  Qed.

Definition assn_sub X a (P:Assertion) : Assertion :=
  fun (st : state) =>
    P (X !-> aeval st a ; st).

Notation "P [ X |-> a ]" := (assn_sub X a P)
  (at level 10, X at next level).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} X ::= a {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

Example assn_sub_example :
  {{(X < 5) [X |-> X + 1]}}
  X ::= X + 1
  {{X < 5}}.
Proof.
  apply hoare_asgn.  Qed.

Definition manual_grade_for_hoare_asgn_examples : option (nat*string) := None.

Definition manual_grade_for_hoare_asgn_wrong : option (nat*string) := None.

Theorem hoare_asgn_fwd :
  forall m a P,
  {{fun st => P st /\ st X = m}}
    X ::= a
  {{fun st => P (X !-> m ; st)
           /\ st X = aeval (X !-> m ; st) a }}.
Proof.
  unfold hoare_triple. intros.
  split.
  - inversion H. subst.
    inversion H0.
    replace (t_update (t_update st X (aeval st a)) X m) with (st).
    apply H1.
    rewrite t_update_shadow.
    rewrite <- H2. symmetry. apply t_update_same.
  - inversion H. subst.
    destruct H0.
    rewrite t_update_shadow.
    simpl.

Theorem hoare_asgn_fwd_exists :
  forall a P,
  {{fun st => P st}}
    X ::= a
  {{fun st => exists m, P (X !-> m ; st) /\
                st X = aeval (X !-> m ; st) a }}.
Proof.
  intros a P.
   Admitted.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Example hoare_asgn_example1 :
  {{True}} X ::= 1 {{X = 1}}.
Proof.

  apply hoare_consequence_pre
    with (P' := (X = 1) [X |-> 1]).
  apply hoare_asgn.
  intros st H. unfold assn_sub, t_update. simpl. reflexivity.
Qed.

Example assn_sub_example2 :
  {{X < 4}}
  X ::= X + 1
  {{X < 5}}.
Proof.

  apply hoare_consequence_pre
    with (P' := (X < 5) [X |-> X + 1]).
  apply hoare_asgn.
  intros st H. unfold assn_sub, t_update. simpl in *. omega.
Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

Example hoare_asgn_example1' :
  {{True}}
  X ::= 1
  {{X = 1}}.
Proof.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  intros st H.  reflexivity.  Qed.

Lemma silly1 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. apply HP.

Abort.

Lemma silly2 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. eapply HQ. destruct HP as [y HP'].
  Fail apply HP'.

Abort.

Lemma silly2_fixed :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP'].
  eapply HQ. apply HP'.
Qed.

Lemma silly2_eassumption : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ. destruct HP as [y HP']. eapply HQ. eassumption.
Qed.

Definition manual_grade_for_hoare_asgn_examples_2 : option (nat*string) := None.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

Example hoare_asgn_example3 : forall (a:aexp) (n:nat),
  {{(a = n)%assertion}}
  X ::= a;; SKIP
  {{X = n}}.
Proof.
  intros a n. eapply hoare_seq.
  -
    apply hoare_skip.
  -
    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. simpl in *. subst. reflexivity.
Qed.

Example hoare_asgn_example4 :
  {{True}}
  X ::= 1;; Y ::= 2
  {{ (X = 1 /\ Y = 2)}}.
Proof.
   Admitted.

Definition swap_program : com
  . Admitted.

Theorem swap_exercise :
  {{X <= Y}}
  swap_program
  {{Y <= X}}.
Proof.
   Admitted.

Definition manual_grade_for_hoarestate1 : option (nat*string) := None.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Coercion bassn : bexp >-> Assertion.

Arguments bassn /.

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

Theorem hoare_if : forall P Q (b:bexp) c1 c2,
  {{ P /\ b }} c1 {{Q}} ->
  {{ P /\ ~ b}} c2 {{Q}} ->
  {{P}} TEST b THEN c1 ELSE c2 FI {{Q}}.

Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  -
    apply (HTrue st st').
      assumption.
      split. assumption.
      apply bexp_eval_true. assumption.
  -
    apply (HFalse st st').
      assumption.
      split. assumption.
      apply bexp_eval_false. assumption. Qed.

Example if_example :
    {{True}}
  TEST X = 0
    THEN Y ::= 2
    ELSE Y ::= X + 1
  FI
    {{X <= Y}}.
Proof.

  apply hoare_if.
  -
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold bassn, assn_sub, t_update, assert_implies.
    simpl. intros st [_ H].
    apply eqb_eq in H.
    rewrite H. omega.
  -
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold assn_sub, t_update, assert_implies.
    simpl; intros st _. omega.
Qed.

Theorem if_minus_plus :
  {{True}}
  TEST X <= Y
    THEN Z ::= Y - X
    ELSE Y ::= X + Z
  FI
  {{Y = X + Z}}.
Proof.
   Admitted.

Module If1.

Inductive com : Type :=
  | CSkip : com
  | CAss : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CIf1 : bexp -> com -> com.

Bind Scope imp_scope with com.

Notation "'SKIP'" :=
  CSkip : imp_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
Notation "X '::=' a" :=
  (CAss X a) (at level 60) : imp_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : imp_scope.
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity) : imp_scope.
Notation "'IF1' b 'THEN' c 'FI'" :=
  (CIf1 b c) (at level 80, right associativity) : imp_scope.

Reserved Notation "st '=[' c ']=>' st'" (at level 40).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ SKIP ]=> st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st  =[ WHILE b DO c END ]=> st''

  where "st '=[' c ']=>' st'" := (ceval c st st').

Definition hoare_triple
           (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
       st =[ c ]=> st' ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

Lemma hoare_if1_good :
  {{ X + Y = Z }}
  (IF1 ~(Y = 0) THEN
    X ::= X + Y
  FI)
  {{ X = Z }}.
Proof.  Admitted.

End If1.

Definition manual_grade_for_if1_hoare : option (nat*string) := None.

Theorem hoare_while : forall P (b:bexp) c,
  {{P /\ b}} c {{P}} ->
  {{P}} WHILE b DO c END {{P /\ ~ b}}.
Proof.
  intros P b c Hhoare st st' He HP.

  remember (WHILE b DO c END)%imp as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  -
    split. assumption. apply bexp_eval_false. assumption.
  -
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Example while_example :
    {{X <= 3}}
  WHILE X <= 2
  DO X ::= X + 1 END
    {{X = 3}}.
Proof.
  eapply hoare_consequence_post.
  apply hoare_while.
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  unfold bassn, assn_sub, assert_implies, t_update. simpl.
    intros st [H1 H2]. apply leb_complete in H2. omega.
  unfold bassn, assert_implies. intros st [Hle Hb].
    simpl in Hb. destruct ((st X) <=? 2) eqn : Heqle.
    exfalso. apply Hb; reflexivity.
    apply leb_iff_conv in Heqle. simpl in *. omega.
Qed.

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE true DO SKIP END {{Q}}.
Proof.

  intros P Q.
  apply hoare_consequence_pre with (P' := (True:Assertion)).
  eapply hoare_consequence_post.
  apply hoare_while.
  -
    apply hoare_post_true. intros st. apply I.
  -
    simpl. intros st [Hinv Hguard].
    exfalso. apply Hguard. reflexivity.
  -
    intros st H. constructor.  Qed.

Module RepeatExercise.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Reserved Notation "st '=[' c ']=>' st'" (at level 40).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      st =[ SKIP ]=> st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st  =[ WHILE b DO c END ]=> st''

where "st '=[' c ']=>' st'" := (ceval st c st').

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion)
                        : Prop :=
  forall st st', st =[ c ]=> st' -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level).

Definition ex1_repeat :=
  REPEAT
    X ::= 1;;
    Y ::= Y + 1
  UNTIL X = 1 END.

Theorem ex1_repeat_works :
  empty_st =[ ex1_repeat ]=> (Y !-> 1 ; X !-> 1).
Proof.
   Admitted.

End RepeatExercise.

Definition manual_grade_for_hoare_repeat : option (nat*string) := None.

Module Himp.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : string -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'HAVOC' X" := (CHavoc X) (at level 60).

Reserved Notation "st '=[' c ']=>' st'" (at level 40).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ SKIP ]=> st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=> st'' ->
      st  =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st  =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st  =[ WHILE b DO c END ]=> st''
  | E_Havoc : forall st X n,
      st =[ HAVOC X ]=> (X !-> n ; st)

where "st '=[' c ']=>' st'" := (ceval c st st').

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st', st =[ c ]=> st' -> P st -> Q st'.

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Definition havoc_pre (X : string) (Q : Assertion) : Assertion
  . Admitted.

Theorem hoare_havoc : forall (Q : Assertion) (X : string),
  {{ havoc_pre X Q }} HAVOC X {{ Q }}.
Proof.
   Admitted.

Theorem havoc_post : forall (P : Assertion) (X : string),
  {{ P }} HAVOC X {{ fun st => exists (n:nat), P [X |-> n] st }}.
Proof.
  intros P X. eapply hoare_consequence_pre.
  - apply hoare_havoc.
  - unfold assert_implies, assn_sub.
     Admitted.

End Himp.

Module HoareAssertAssume.

Inductive com : Type :=
  | CSkip : com
  | CAss : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CAssert : bexp -> com
  | CAssume : bexp -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'ASSERT' b" :=
  (CAssert b) (at level 60).
Notation "'ASSUME' b" :=
  (CAssume b) (at level 60).

Inductive result : Type :=
  | RNormal : state -> result
  | RError : result.

Inductive ceval : com -> state -> result -> Prop :=

  | E_Skip : forall st,
      st =[ SKIP ]=> RNormal st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> RNormal (x !-> n ; st)
  | E_SeqNormal : forall c1 c2 st st' r,
      st  =[ c1 ]=> RNormal st' ->
      st' =[ c2 ]=> r ->
      st  =[ c1 ;; c2 ]=> r
  | E_SeqError : forall c1 c2 st,
      st =[ c1 ]=> RError ->
      st =[ c1 ;; c2 ]=> RError
  | E_IfTrue : forall st r b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> r ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> r
  | E_IfFalse : forall st r b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> r ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> r
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> RNormal st
  | E_WhileTrueNormal : forall st st' r b c,
      beval st b = true ->
      st  =[ c ]=> RNormal st' ->
      st' =[ WHILE b DO c END ]=> r ->
      st  =[ WHILE b DO c END ]=> r
  | E_WhileTrueError : forall st b c,
      beval st b = true ->
      st =[ c ]=> RError ->
      st =[ WHILE b DO c END ]=> RError

  | E_AssertTrue : forall st b,
      beval st b = true ->
      st =[ ASSERT b ]=> RNormal st
  | E_AssertFalse : forall st b,
      beval st b = false ->
      st =[ ASSERT b ]=> RError
  | E_Assume : forall st b,
      beval st b = true ->
      st =[ ASSUME b ]=> RNormal st

where "st '=[' c ']=>' r" := (ceval c st r).

Definition hoare_triple
           (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st r,
     st =[ c ]=> r  -> P st  ->
     (exists st', r = RNormal st' /\ Q st').

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Theorem assert_assume_differ : exists (P:Assertion) b (Q:Assertion),
       ({{P}} ASSUME b {{Q}})
  /\ ~ ({{P}} ASSERT b {{Q}}).
 Admitted.

Theorem assert_implies_assume : forall P b Q,
     ({{P}} ASSERT b {{Q}})
  -> ({{P}} ASSUME b {{Q}}).
Proof.
 Admitted.

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} X ::= a {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  exists (X !-> aeval st a ; st). split; try reflexivity.
  assumption. Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st r Hc HP.
  unfold hoare_triple in Hhoare.
  assert (exists st', r = RNormal st' /\ Q' st').
  { apply (Hhoare st); assumption. }
  destruct H as [st' [Hr HQ']].
  exists st'. split; try assumption.
  apply Himp. assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
  {{Q}} c2 {{R}} ->
  {{P}} c1 {{Q}} ->
  {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st r H12 Pre.
  inversion H12; subst.
  - eapply H1.
    + apply H6.
    + apply H2 in H3. apply H3 in Pre.
        destruct Pre as [st'0 [Heq HQ]].
        inversion Heq; subst. assumption.
  -
     apply H2 in H5. apply H5 in Pre.
     destruct Pre as [st' [C _]].
     inversion C.
Qed.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  eexists. split. reflexivity. assumption.
Qed.

Theorem hoare_if : forall P Q (b:bexp) c1 c2,
  {{ P /\ b}} c1 {{Q}} ->
  {{ P /\ ~ b}} c2 {{Q}} ->
  {{P}} TEST b THEN c1 ELSE c2 FI {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  -
    apply (HTrue st st').
      assumption.
      split. assumption.
      apply bexp_eval_true. assumption.
  -
    apply (HFalse st st').
      assumption.
      split. assumption.
      apply bexp_eval_false. assumption. Qed.

Theorem hoare_while : forall P (b:bexp) c,
  {{P /\ b}} c {{P}} ->
  {{P}} WHILE b DO c END {{ P /\ ~b}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  -
    eexists. split. reflexivity. split.
    assumption. apply bexp_eval_false. assumption.
  -
    clear IHHe1.
    apply IHHe2. reflexivity.
    clear IHHe2 He2 r.
    unfold hoare_triple in Hhoare.
    apply Hhoare in He1.
    + destruct He1 as [st1 [Heq Hst1]].
        inversion Heq; subst.
        assumption.
    + split; assumption.
  -
     exfalso. clear IHHe.
     unfold hoare_triple in Hhoare.
     apply Hhoare in He.
     + destruct He as [st' [C _]]. inversion C.
     + split; assumption.
Qed.

Example assert_assume_example:
  {{True}}
  ASSUME (X = 1);;
  X ::= X + 1;;
  ASSERT (X = 2)
  {{True}}.
Proof.
 Admitted.

End HoareAssertAssume.


Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSets.
Require Import Coq.Lists.SetoidList.
Import ListNotations.

Require Import Shuffle.List.
Require Shuffle.Instruction.

Module Opcode <: UsualDecidableType.
  Inductive Opcode : Set :=
  | Up : Opcode
  | Down : Opcode.

  Definition t : Type := Opcode.

  Include HasUsualEq.
  Include UsualIsEq.

  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    decide equality.
  Qed.

  Lemma not_Up_iff_Down : forall opcode : t, Up <> opcode <-> Down = opcode.
  Proof.
    now intros [|].
  Defined.

  Lemma not_Down_iff_Up : forall opcode : t, Down <> opcode <-> Up = opcode.
  Proof.
    now intros [|].
  Defined.
End Opcode.

Module Make (Operand : DecidableTypeBoth).
  Module Instruction := Instruction.Make Opcode Operand.

  Definition t : Type :=
    list Instruction.t.

  Module Notations.
    Notation Up owner :=
      ((Opcode.Up, owner)).

    Notation Down owner :=
      ((Opcode.Down, owner)).

    Notation In instruction instructions :=
      (InA Instruction.eq instruction instructions).

    Notation Ahead owner instructions :=
      (In (Up owner) instructions).

    Notation Active owner instructions :=
      (~ In (Up owner) instructions /\
      In (Down owner) instructions).

    Notation Absent owner instructions :=
      (~ In (Down owner) instructions).
  End Notations.
  Import Notations.

  Inductive Ok : t -> Prop :=
  | nil :
    Ok []
  | cons_Up :
    forall
      (p₀ : Operand.t)
      (x₀ : t),
      Active p₀ x₀ ->
      Ok x₀ ->
      Ok (Up p₀ :: x₀)
  | cons_Down :
    forall
      (p₀ : Operand.t)
      (x₀ : t),
      Absent p₀ x₀ ->
      Ok x₀ ->
      Ok (Down p₀ :: x₀).

  Definition Closed
    (x : t) :
    Prop :=
      forall
        p : Operand.t,
        In (Down p) x -> Ahead p x.

  Lemma Closed_impl_not_Active :
    forall
      (p : Operand.t)
      (x : t),
      Closed x ->
      ~ Active p x.
  Proof.
    intros p x Closed_x (not_Ahead_p & H).
    now contradict not_Ahead_p; apply Closed_x.
  Qed.

  Module Orthogonal.
    Section Orthogonal.
      Variables
        (v : Operand.t)
        (x : t).

      Lemma Up_impl_Down :
        Ok x ->
        Ahead v x ->
        In (Down v) x.
      Proof.
        intros Ok_x.
        induction Ok_x as [| p₀ x₀ Active_p₀_x₀ Ok_x₀ IHx₀| p₀ x₀ Absent_p₀_x₀ Ok_x₀ IHx₀];
          intros Ahead_v_x; [easy| ..].
          1 - 2:
          apply InA_cons in Ahead_v_x as [(eq & v_eq_p₀)| Ahead_v_x₀];
          [change (Operand.eq v p₀) in v_eq_p₀| now right; apply IHx₀].
            now rewrite v_eq_p₀; right.
          now contradict eq; apply Opcode.not_Up_iff_Down.
      Qed.

      Lemma Ahead_Active :
        Ahead v x ->
        Active v x ->
        False.
      Proof.
        now intros Ahead_v_x Active_v_x.
      Qed.

      Lemma Active_Absent :
        Active v x ->
        Absent v x ->
        False.
      Proof.
        now intros Active_v_x Absent_v_x.
      Qed.

      Lemma Ahead_Absent :
        Ok x ->
        Ahead v x ->
        Absent v x ->
        False.
      Proof.
        intros Ok_x Ahead_v_x Absent_v_x.
        contradict Absent_v_x.
        now apply Up_impl_Down.
      Qed.

      Lemma Active_impl_not_Ahead :
        Active v x ->
        ~ Ahead v x.
      Proof.
        now intros Active_v_x Ahead_v_x; apply Ahead_Active.
      Qed.

      Lemma Absent_impl_not_Ahead :
        Ok x ->
        Absent v x ->
        ~ Ahead v x.
      Proof.
        now intros Ok_x Absent_v_x Ahead_v_x; apply Ahead_Absent.
      Qed.

      Lemma Ahead_impl_not_Active :
        Ahead v x ->
        ~ Active v x.
      Proof.
        now intros Ahead_v_x Active_v_x; apply Ahead_Active.
      Qed.

      Lemma Absent_impl_not_Active :
        Absent v x ->
        ~ Active v x.
      Proof.
        now intros Absent_v_x Active_v_x; apply Active_Absent.
      Qed.

      Lemma Ahead_impl_not_Absent :
        Ok x ->
        Ahead v x ->
        ~ Absent v x.
      Proof.
        now intros Ok_x Ahead_v_x Absent_v_x; apply Ahead_Absent.
      Qed.

      Lemma Active_impl_not_Absent :
        Active v x ->
        ~ Absent v x.
      Proof.
        now intros Active_v_x Absent_v_x; apply Active_Absent.
      Qed.
    End Orthogonal.

    Module Hints.
      #[export]
      Hint Resolve Active_impl_not_Ahead : instructions.
      #[export]
      Hint Resolve Absent_impl_not_Ahead : instructions.
      #[export]
      Hint Resolve Ahead_impl_not_Active : instructions.
      #[export]
      Hint Resolve Absent_impl_not_Active : instructions.
      #[export]
      Hint Resolve Ahead_impl_not_Absent : instructions.
      #[export]
      Hint Resolve Active_impl_not_Absent : instructions.
    End Hints.
  End Orthogonal.
  Import Orthogonal.Hints.

  Module Ok.
    Section Ok.
      Variables
        (p₀ v : Operand.t)
        (u₀ : Instruction.t)
        (x₀ x : t).

      Lemma cons_inv :
        Ok (u₀ :: x₀) ->
        Ok x₀.
      Proof.
        now inversion 1.
      Qed.

      Lemma cons_Up_inv :
        Ok (Up p₀ :: x₀) ->
        Active p₀ x₀.
      Proof.
        intros Ok_x₀.
        now inversion_clear Ok_x₀.
      Qed.

      Lemma cons_Down_inv :
        Ok (Down p₀ :: x₀) ->
        Absent p₀ x₀.
      Proof.
        intros Ok_x₀.
        now inversion_clear Ok_x₀.
      Qed.

      Lemma nil_iff :
        Ok [] <->
        True.
      Proof.
        now split; [| constructor].
      Qed.

      Lemma cons_Up_iff :
        Ok (Up p₀ :: x₀) <->
          Active p₀ x₀ /\
          Ok x₀.
      Proof.
        now split; [inversion_clear 1| constructor].
      Qed.

      Lemma cons_Down_iff :
        Ok (Down p₀ :: x₀) <->
          Absent p₀ x₀ /\
          Ok x₀.
      Proof.
        now split; [inversion_clear 1| constructor].
      Qed.
    End Ok.

    Lemma split :
      forall
      x y : t,
      Ok (x ++ y) ->
      Ok y.
    Proof.
      intros x y; move y after x.
      induction x as [| u₀ x₀ IHx₀]; intros Ok_z.
        exact Ok_z.
      apply IHx₀, cons_inv with (1 := Ok_z).
    Qed.

    Module Hints.
      #[export]
      Hint Constructors Ok : instructions.

      #[export]
      Hint Immediate cons_inv : instructions.
      #[export]
      Hint Immediate cons_Up_inv : instructions.
      #[export]
      Hint Immediate cons_Down_inv : instructions.
    End Hints.

    Add Parametric Morphism : Ok with signature
      (Tail (A := Instruction.t)) ++> impl as Ok_morphism.
    Proof.
      intros x y (u₀ & x₀) Ok_x.
      now apply Ok.cons_inv with u₀.
    Qed.
  End Ok.
  Import Ok.Hints.

  Ltac instructions_tac :=
    eauto with instructions.

  Module Ahead.
    Section Ahead.
      Variables
        (p₀ v : Operand.t)
        (u₀ : Instruction.t)
        (x₀ : t).

      Lemma nil :
        ~ Ahead v [].
      Proof.
        intros Ahead_v_x.
        apply InA_nil with (1 := Ahead_v_x).
      Qed.

      Lemma cons_Up_hd :
        Ahead p₀ (Up p₀ :: x₀).
      Proof.
        now left.
      Qed.

      Lemma cons_Down_hd :
        Ok (Down p₀ :: x₀) ->
        ~ Ahead p₀ (Down p₀ :: x₀).
      Proof with instructions_tac.
        intros Ok_x.
        enough (not_Ahead_p₀_x₀ : ~ Ahead p₀ x₀)...
        now apply not_InA_cons;
          enough (Opcode.Up <> Opcode.Down) by firstorder.
      Qed.

      Lemma cons_tl :
        Ahead v x₀ ->
        Ahead v (u₀ :: x₀).
      Proof.
        now right.
      Qed.

      Lemma nil_iff :
        Ahead v [] <->
        False.
      Proof.
        now split; [apply nil|].
      Qed.

      Lemma cons_Up_iff :
        Ahead v (Up p₀ :: x₀) <->
          Operand.eq p₀ v \/
          Ahead v x₀.
      Proof.
        split.
          intros Ahead_v_x.
          destruct (Operand.eq_dec p₀ v) as [p₀_eq_v| p₀_neq_v];
            [now left| right].
          now apply InA_cons in Ahead_v_x as [(_ & p₀_eq_v)| Ahead_v_x₀];
            [absurd (Operand.eq p₀ v)|].
        now intros [p₀_eq_v| Ahead_v_x₀]; [left| right].
      Qed.

      Lemma cons_Down_iff :
        Ahead v (Down p₀ :: x₀) <->
        Ahead v x₀.
      Proof.
        split.
          intros Ahead_v_x.
          now apply InA_cons in Ahead_v_x as [(Up_eq_Down & _)| Ahead_v_x₀];
            [contradict Up_eq_Down; apply Opcode.not_Up_iff_Down|].
        now intros Ahead_v_x₀; right.
      Qed.
    End Ahead.

    Module Hints.
      #[export]
      Hint Resolve nil : instructions.
      #[export]
      Hint Resolve cons_Up_hd : instructions.
      #[export]
      Hint Resolve cons_Down_hd : instructions.
      #[export]
      Hint Resolve cons_tl : instructions.
    End Hints.
  End Ahead.
  Import Ahead.Hints.

  Module Active.
    Section Active.
      Variables
        (p₀ v : Operand.t)
        (x₀ : t).

      Lemma nil : ~ Active v [].
      Proof.
        intros (_ & In_Down_v).
        apply InA_nil with (1 := In_Down_v).
      Qed.

      Lemma cons_Up_hd :
        ~ Active p₀ (Up p₀ :: x₀).
      Proof with instructions_tac.
        enough (Ahead p₀ (Up p₀ :: x₀))...
      Qed.

      Lemma cons_Up_tl :
        ~ Operand.eq p₀ v ->
        Active v x₀ ->
        Active v (Up p₀ :: x₀).
      Proof.
        intros p₀_neq_v Active_v_x₀.
        constructor; [| now right].
        rewrite Ahead.cons_Up_iff; tauto.
      Qed.

      Lemma cons_Down_hd :
        Ok (Down p₀ :: x₀) ->
        Active p₀ (Down p₀ :: x₀).
      Proof with instructions_tac.
        intros Ok_instructions.
        constructor; [| now left].
        rewrite Ahead.cons_Down_iff...
      Qed.

      Lemma cons_Down_tl :
        Active v x₀ ->
        Active v (Down p₀ :: x₀).
      Proof with instructions_tac.
        intros Active_v.
        constructor; [| now right].
        rewrite Ahead.cons_Down_iff...
      Qed.

      Lemma nil_iff :
        Active v [] <->
        False.
      Proof.
        now split; [apply nil|].
      Qed.

      Lemma cons_Up_iff :
        Active v (Up p₀ :: x₀) <->
          ~ Operand.eq p₀ v /\
          Active v x₀.
      Proof.
        split.
          intros (not_Ahead_v_x & In_Down_v_x).
          assert (~ Operand.eq p₀ v /\ ~ Ahead v x₀) as
            (p₀_neq_v & not_Ahead_v_x₀) by
            (rewrite Ahead.cons_Up_iff in not_Ahead_v_x; tauto).
          enough (In (Down v) x₀) by firstorder.
          now enough (Opcode.Down <> Opcode.Up);
            [apply InA_cons in In_Down_v_x; firstorder|].
        now intros (p₀_neq_v & Active_v_x₀); apply cons_Up_tl.
      Qed.

      Lemma cons_Down_iff :
        Ok (Down p₀ :: x₀) ->
          Active v (Down p₀ :: x₀) <->
            Operand.eq p₀ v \/
            Active v x₀.
      Proof.
        intros Ok_instructions.
        split.
          intros (not_Ahead_v_x & In_Down_v_x).
          destruct (Operand.eq_dec p₀ v) as [p₀_eq_v| p₀_neq_v];
            [now left| right].
          apply InA_cons in In_Down_v_x.
          enough (~ Operand.eq v p₀); firstorder.
        now intros [<-| Active_v];
          [apply cons_Down_hd| apply cons_Down_tl].
      Qed.
    End Active.

    Module Hints.
      #[export]
      Hint Resolve nil : instructions.
      #[export]
      Hint Resolve cons_Up_hd : instructions.
      #[export]
      Hint Resolve cons_Up_tl : instructions.
      #[export]
      Hint Resolve cons_Down_hd : instructions.
      #[export]
      Hint Resolve cons_Down_tl : instructions.
    End Hints.
    Import Hints.

    Module Sets (M : MSetInterface.WSetsOn Operand).
      Module M_Facts := MSetFacts.WFactsOn Operand M.
      Module M_Properties := MSetProperties.WPropertiesOn Operand M.

      Notation Ok x s :=
        (forall
          p : Operand.t,
          M.In p s <->
          Active p x).

      Fixpoint active
        (x : t) :
        M.t :=
        match x with
        | [] =>
          M.empty
        | Up p₀ :: x₀ =>
          M.remove p₀ (active x₀)
        | Down p₀ :: x₀ =>
          M.add p₀ (active x₀)
        end.

      Notation count x :=
        (M.cardinal (active x)).

      Section Iff.
        Variables
          (p₀ : Operand.t)
          (x₀ : t)
          (p : Operand.t).

        Lemma nil_iff :
          M.In p (active []) <-> False.
        Proof.
          apply M_Facts.empty_iff.
        Qed.

        Lemma cons_Up_iff :
          M.In p (active (Up p₀ :: x₀)) <->
            ~ Operand.eq p₀ p /\
            M.In p (active x₀).
        Proof.
          now simpl; rewrite M_Facts.remove_iff.
        Qed.

        Lemma cons_Down_iff :
          M.In p (active (Down p₀ :: x₀)) <->
            Operand.eq p₀ p \/
            M.In p (active x₀).
        Proof.
          apply M_Facts.add_iff.
        Qed.
      End Iff.

      Section Spec.
        Variables
          x : t.

        Lemma spec :
          Make.Ok x ->
          Ok x (active x).
        Proof.
          induction 1 as [| u₀ x₀ Active_u₀_x₀ Ok_x₀ IHx₀|
          u₀ x₀ Absent_u₀_x₀ Ok_x₀ IHx₀]; intros p.
              now rewrite nil_iff.
            now rewrite cons_Up_iff, IHx₀, Active.cons_Up_iff.
          now rewrite cons_Down_iff, IHx₀, Active.cons_Down_iff by
            now constructor.
        Qed.

        Lemma closed :
          Make.Ok x ->
          Make.Closed x ->
          M.Empty (active x).
        Proof.
          intros Ok_x Closed_x p.
          rewrite spec by assumption.
          now apply Closed_impl_not_Active.
        Qed.
      End Spec.

      Section Hints.
        Variables
          (p₀ : Operand.t)
          (x₀ : t).

        Lemma not_In_Up :
          ~ M.In p₀ (active (Up p₀ :: x₀)).
        Proof.
          simpl; auto with set.
        Qed.

        Lemma In_Down :
          M.In p₀ (active (Down p₀ :: x₀)).
        Proof.
          simpl; auto with set.
        Qed.

        Lemma Down_not_In :
          Make.Ok (Down p₀ :: x₀) ->
          ~ M.In p₀ (active x₀).
        Proof with eauto with instructions.
          intros Ok_x.
          enough (Active_p₀_x₀ : ~ Active p₀ x₀).
            contradict Active_p₀_x₀; apply spec...
          auto with instructions.
        Qed.

        Lemma Up_In :
          Make.Ok (Up p₀ :: x₀) ->
          M.In p₀ (active x₀).
        Proof with eauto with instructions.
          intros Ok_x.
          apply spec...
        Qed.
      End Hints.

      Section Count.
        Variables
          (p₀ : Operand.t)
          (x₀ x : t).

        Lemma count_closed :
          Make.Ok x ->
          Make.Closed x ->
          count x = O.
        Proof.
          intros Ok_x Closed_x.
          enough (M.Empty (active x)) by
            auto with set.
          now apply closed.
        Qed.

        Lemma count_Up :
          Make.Ok (Up p₀ :: x₀) ->
          S (count (Up p₀ :: x₀)) = count x₀.
        Proof.
          intros Ok_x.
          apply M_Properties.remove_cardinal_1...
          now apply Up_In.
        Qed.

        Lemma count_Down :
          Make.Ok (Down p₀ :: x₀) ->
          count (Down p₀ :: x₀) = S (count x₀).
        Proof with instructions_tac.
          intros Ok_x.
          apply M_Properties.add_cardinal_2.
          now apply Down_not_In.
        Qed.
      End Count.

      Definition IsChromaticNumber
        (instructions : t)
        (χ : nat) :
        Prop :=
        Skip.Forall
          (fun skip : t => count skip <= χ)
          instructions /\
        Skip.Exists
          (fun skip : t => count skip = χ)
          instructions.
    End Sets.
  End Active.

  Module Absent.
    Section Absent.
      Variables
        (p₀ v : Operand.t)
        (u₀ : Instruction.t)
        (x₀ : t).

      Lemma nil :
        Absent v [].
      Proof.
        unfold not; apply InA_nil.
      Qed.

      Lemma cons_Up_hd :
        Ok (Up p₀ :: x₀) ->
        ~ Absent p₀ (Up p₀ :: x₀).
      Proof.
        instructions_tac.
      Qed.

      Lemma cons_Up_tl :
        Absent v x₀ ->
        Absent v (Up p₀ :: x₀).
      Proof.
        intros Absent_v.
        now apply not_InA_cons; split;
          [apply Instruction.neq_opcode, Opcode.not_Down_iff_Up|].
      Qed.

      Lemma cons_Down_hd :
        ~ Absent p₀ (Down p₀ :: x₀).
      Proof.
        enough (In (Down p₀) (Down p₀ :: x₀)) by firstorder.
        now constructor.
      Qed.

      Lemma cons_Down_tl :
        ~ Operand.eq p₀ v ->
        Absent v x₀ ->
        Absent v (Down p₀ :: x₀).
      Proof.
        intros p₀_neq_v Absent_v.
        now apply not_InA_cons; split;
          [apply Instruction.neq_operand; contradict p₀_neq_v|].
      Qed.

      Lemma cons_inv :
        Absent v (u₀ :: x₀) ->
        Absent v x₀.
      Proof.
        intros Absent_v.
        now apply not_InA_cons in Absent_v.
      Qed.

      Lemma nil_iff :
        Absent v [] <->
        True.
      Proof.
        easy.
      Qed.

      Lemma cons_Down_iff :
        Absent v (Down p₀ :: x₀) <->
          ~ Operand.eq p₀ v /\
          Absent v x₀.
      Proof.
        split; intros Absent_v; [| now apply cons_Down_tl].
        apply not_InA_cons in Absent_v as (v_neq_p₀ & Absent_v).
        apply Instruction.neq_eq_opcode in v_neq_p₀; [| reflexivity].
        now split; [contradict v_neq_p₀|].
      Qed.

      Lemma cons_Up_iff :
        Absent v (Up p₀ :: x₀) <->
        Absent v x₀.
      Proof.
        split.
          intros Absent_v.
          now apply not_InA_cons with (Up p₀).
        now intros Absent_v; apply not_InA_cons; split;
          [apply Instruction.neq_opcode, Opcode.not_Down_iff_Up|].
      Qed.
    End Absent.

    Module Hints.
      #[export]
      Hint Resolve nil : instructions.
      #[export]
      Hint Resolve cons_Up_hd : instructions.
      #[export]
      Hint Resolve cons_Up_tl : instructions.
      #[export]
      Hint Resolve cons_Down_hd : instructions.
      #[export]
      Hint Resolve cons_Down_tl : instructions.

      #[export]
      Hint Immediate cons_inv : instructions.
    End Hints.
  End Absent.

  Module Hints.
    Create HintDb instructions.

    Export Ok.Hints.
    Export Orthogonal.Hints.
    Export Ahead.Hints.
    Export Active.Hints.
    Export Absent.Hints.
  End Hints.
End Make.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B Aprime P : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ O A /\ (wd_ A Aprime /\ (wd_ B O /\ (wd_ E Eprime /\ (wd_ Aprime P /\ (col_ O E B /\ (col_ A O E /\ col_ Aprime O E))))))))) -> col_ E A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Dynamic.
Require Import SyntaxProp.
Require Import MapProp.

Lemma step_preserves_this :
  forall id M M' H H' n n' e e' l L C Q,
    (exists e, heapLookup H id = Some (l, L, C, Q, e)) ->
    id / (M, H, n); e ==> (M', H', n'); e' ->
    exists L' C' Q' e'', heapLookup H' id = Some (l, L', C', Q', e'').
Proof with hauto.
  introv Hex Hstep.
  gen e'.
  inv Hex as [e' Hlookup].
  expr_cases (induction e) Case; intros;
    inv Hstep; try solve[inv_ctx]...
Qed.

Lemma monotonic_heap :
  forall id M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    length H <= length H'.
Proof with hauto.
  introv Hstep.
  gen Hstep. gen e'.
  expr_cases(induction e) Case; intros;
    inv Hstep; try solve[inv_ctx]...
Qed.

Lemma monotonic_local_heap :
  forall id id' M M' H H' n n' e e' L L' l,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H id' = Some L ->
    LH H' id' = Some L' ->
    In l L ->
    In l L'.
Proof with (hauto; eauto using in_cons).
  introv Hstep HLH1 HLH2 HIn.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert...
  + Case "ENew".
    destruct (heapLookup H id')...
    destruct_actor a...
Qed.

Lemma new_locs_in_local_heap :
  forall id M M' H H' n n' L L' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H id = Some L ->
    LH H' id = Some L' ->
    (forall l, In l (freeLocs e) -> In l L) ->
    (forall l, In l (freeLocs e') -> In l L').
Proof with eauto using in_or_app.
  introv Hstep HLH1 HLH2 HIn HIn'.
  assert (forall l, In l L -> In l L') as Hmono.
    intros; eapply monotonic_local_heap...
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try contradiction;
    simpls;
    try solve [
          first [apply in_app_or in HIn'|
                 apply freeLocs_subst_in in HIn'];
          inv HIn'; eauto using in_or_app]...
  + Case "ENew".
    inv HIn'; try contradiction.
    hauto.
    constructors...
Qed.

Lemma new_ids_in_heap :
  forall id M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    (forall id, In id (freeIds e) -> id < length H) ->
    (forall id', In id' (freeIds e') -> id' < length H').
Proof with (hauto; eauto using in_or_app, monotonic_heap).
  introv Hstep Hid HIn.
  assert (length H <= length H') as Hmono...
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert; simpls;
    try (first [apply in_app_or in HIn
               |apply freeIds_subst_in in HIn];
         inv HIn);
    try contradiction;
    try (assert (id' < length H) by eauto using in_or_app; omega)...
Qed.

Lemma bid_actors_in_heap :
  forall id id' M M' H H' n n' e e' l,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    id < length H ->
    (forall l id'', In (l, id'') (freeBIds e) -> id'' < length H) ->
    In (l, id') (freeBIds e') ->
    id' < length H.
Proof with eauto using in_or_app, monotonic_heap.
  introv Hstep Hlt HBId HIn.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; simpls;
    try contradiction;
    try solve[
          first[apply in_app_or in HIn
               |apply freeBIds_subst_in in HIn];
          inv HIn; eauto using in_or_app]...
  + Case "EBes". inv HIn... inv H. omega.
Qed.

Lemma bid_loc_in_local_heap :
  forall id id' M M' H H' n n' e e' l L L' L'',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    (forall l', In l' (freeLocs e) -> In l' L'') ->
    (forall l' id'',
        In (l', id'') (freeBIds e) ->
        id'' < length H /\
        LH H id'' = Some L -> In l' L) ->
    In (l, id') (freeBIds e') ->
    LH H id' = Some L ->
    LH H' id' = Some L' ->
    LH H id = Some L'' ->
    In l L'.
Proof with eauto using in_or_app.
  introv Hstep Hloc HBId HIn HLH HLH' HLH''.
  gen e'. gen L''.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; simpls;
    try contradiction;
    try rewrite_and_invert;
    try solve[apply in_app_or in HIn;
              inv HIn;
              try solve[eapply IHe1 with (L'' := L'');
                        eauto using in_or_app
                       |eapply IHe2 with (L'' := L'');
                        eauto using in_or_app];
              try eapply monotonic_local_heap;
              try eapply HBId;
              eauto using in_or_app]...
  + Case "EApp".
    eapply freeBIds_subst_in in HIn. inv HIn; eapply HBId...
  + Case "EBes".
    inv HIn; try contradiction.
    inv H...
    repeat rewrite_and_invert...
Qed.

Lemma step_footprint :
  forall id id' M M' H H' n n' e e' e'' l L C Q,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    heapLookup H' id' = Some (l, L, C, Q, e'') ->
    (exists L C Q, heapLookup H id' = Some (l, L, C, Q, e'')) \/
    e'' = EUnit /\ In l L.
Proof with hauto.
  introv Hstep Hlookup.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
  + Case "ENew".
    right. splits... constructors...
Qed.

Lemma step_local_heap_neq :
  forall id id' M M' H H' n n' e e' L,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H' id' = Some L ->
    id <> id' ->
    id' < length H ->
    LH H id' = Some L.
Proof with hauto.
  introv Hstep HLH Hneq Hlt.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    hauto;
    try contradiction;
    try omega...
Qed.

Lemma step_id_lt :
  forall id id' M M' H H' n n' e e' L,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H' id' = Some L ->
    id' < length H \/ id' = length H /\ L = n :: nil.
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen L.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_single_allocation :
  forall id id' M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    length H < length H' ->
    id' < length H ->
    LH H' id' = LH H id'.
Proof with (hauto; try omega).
  introv Hstep Hlt Hlt'.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_allocates_n :
  forall id id' M M' H H' n n' e e' L,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H id' = Some L ->
    LH H' id' = Some L \/ LH H' id' = Some (n :: L).
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep;
    try inv_ctx...
Qed.

Lemma monotonic_fresh :
  forall id M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    n <= n'.
Proof with eauto.
  introv Hstep.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_conversation_neq :
  forall id id' M M' H H' n n' e e' C,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    conv H' id' = Some C ->
    id <> id' ->
    id' < length H ->
    conv H id' = Some C.
Proof with hauto.
  introv Hstep Hconv Hneq Hlt.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    hauto;
    try contradiction;
    try omega...
Qed.

Lemma step_conv_lt :
  forall id id' M M' H H' n n' e e' C,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    conv H' id' = Some C ->
    id' < length H \/ id' = length H /\ forall id, C id = None.
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen C.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; hauto;
    try solve [left; eapply heapLookup_lt; destruct (heapLookup H id'); hauto
              |left; eapply heapLookup_lt; destruct (heapLookup H' id'); hauto]...
Qed.

Lemma step_conversation_effect :
  forall id M M' H H' n n' e e' C C',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    conv H id = Some C ->
    conv H' id = Some C' ->
    (forall id qid,
        C' id = Some qid ->
        C id = Some qid \/ qid = n /\ M' qid = Some (nil, id)).
Proof with eauto.
  introv Hstep Hconv Hconv'.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert;
    try solve[hauto
             |rewrite_and_invert].
  + Case "ENew".
    hauto. inv H0.
    rewrite_and_invert.
  + Case "EAtStart".
    hauto.
    - unfold extend in H0.
      cases_if... inv_eq...
    - unfold extend in H0.
      cases_if... inv_eq...
  + Case "EAtStart".
    hauto.
    - unfold extend in H0.
      cases_if... inv_eq...
    - unfold extend in H0.
      cases_if... inv_eq...
  + Case "EAtEnd".
    hauto.
    - unfold drop in H0.
      cases_if...
    - unfold drop in H0.
      cases_if...
  + Case "EAtEnd".
    hauto.
    - unfold drop in H0.
      cases_if...
    - unfold drop in H0.
      cases_if...
Qed.


From Undecidability.TM.Code Require Import ProgrammingTools.

(* * Constructor and Deconstructor Machines for Natural Numbers *)

Lemma tl_length (X : Type) (xs : list X) :
  length (tl xs) = pred (length xs).
Proof. destruct xs; auto. Qed.

Global Hint Rewrite tl_length : list.

Section CaseNat.

  (* ** Deconstructor *)

  Definition CaseNat_Rel : Rel (tapes sigNat^+ 1) (bool * tapes sigNat^+ 1) :=
    Mk_R_p
      (fun tin '(yout, tout) =>
         forall (n : nat) (sn : nat),
           tin ≃(;sn) n ->
           match yout, n with
           | false, O => tout ≃(;sn) 0
           | true, S n' => tout ≃(;S sn) n'
           | _, _ => False
           end).

  Definition CaseNat : pTM sigNat^+ bool 1 :=
    Move Rmove;;
    Switch (ReadChar)
          (fun o => match o with
                 | Some (inr sigNat_S) => Return (Write (inl START)) true (* S *)
                 | Some (inr sigNat_O) => Return (Move Lmove) false (* O *)
                 | _ => Return (Nop) default (* invalid input *)
                 end).

  Definition CaseNat_steps := 5.

  Lemma CaseNat_Sem : CaseNat ⊨c(CaseNat_steps) CaseNat_Rel.
  Proof.
    unfold CaseNat_steps. eapply RealiseIn_monotone.
    { unfold CaseNat. TM_Correct. }
    { Unshelve. 4,8: reflexivity. all: lia. }
    {
      intros tin (yout&tout) H. intros n s HEncN. TMSimp.
      destruct HEncN as (r1&HEncN&Hs). TMSimp.
      destruct n; cbn in *; TMSimp.
      - repeat econstructor; auto.
      - hnf. eexists. split. f_equal. cbn. lia.
    }
  Qed.

  (* ** Constructors *)
  Section NatConstructor.

    Definition S_Rel : Rel (tapes sigNat^+ 1) (unit * tapes sigNat^+ 1) :=
      Mk_R_p (ignoreParam (fun tin tout => forall n sn : nat, tin ≃(;sn) n -> tout ≃(;pred sn) S n)).

    Definition Constr_S : pTM sigNat^+ unit 1 :=
      WriteMove (inr sigNat_S) Lmove;; Write (inl START).

    Definition Constr_S_steps := 3.

    Lemma Constr_S_Sem : Constr_S ⊨c(Constr_S_steps) S_Rel.
    Proof.
      unfold Constr_S_steps. eapply RealiseIn_monotone.
      { unfold Constr_S. TM_Correct. }
      { cbn. lia. }
      {
        intros tin (yout, tout) H. intros n sn HEncN.
        TMSimp. clear all except HEncN.
        destruct HEncN as (r1&->&Hs). cbn. simpl_tape.
        hnf. eexists. split. f_equal. simpl_list. lia.
      }
    Qed.

    Definition Constr_O_size := pred >> pred.

    Definition O_Rel : Rel (tapes sigNat^+ 1) (unit * tapes sigNat^+ 1) :=
      fun tin '(_, tout) => forall sn, isVoid_size tin[@Fin0] sn -> tout[@Fin0] ≃(;Constr_O_size sn) O.

    Definition Constr_O : pTM sigNat^+ unit 1 := WriteValue 0.

    Goal Constr_O = WriteMove (inl STOP) Lmove;; WriteMove (inr sigNat_O) Lmove;; Write (inl START).
    Proof. unfold Constr_O, WriteValue, WriteString.WriteString, encode, Encode_map, map, rev, Encode_nat, encode, repeat, app. reflexivity. Qed.
    Definition Constr_O_steps := 5.

    Lemma Constr_O_Sem : Constr_O ⊨c(Constr_O_steps) O_Rel.
    Proof.
      unfold Constr_O_steps. eapply RealiseIn_monotone.
      { unfold Constr_O. TM_Correct. }
      { cbn. reflexivity. }
      { intros tin (yout, tout) H. intros s HRight. cbn in H. unfold Constr_O_size in *.
        specialize (H _ HRight). contains_ext. unfold WriteValue_size. cbn. lia.
      }
    Qed.

  End NatConstructor.

End CaseNat.

(* ** Tactic Support *)

Ltac smpl_TM_CaseNat :=
  once lazymatch goal with
  | [ |- CaseNat ⊨ _ ] => eapply RealiseIn_Realise; apply CaseNat_Sem
  | [ |- CaseNat ⊨c(_) _ ] => apply CaseNat_Sem
  | [ |- projT1 (CaseNat) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply CaseNat_Sem
  | [ |- Constr_O ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_O_Sem
  | [ |- Constr_O ⊨c(_) _ ] => apply Constr_O_Sem
  | [ |- projT1 (Constr_O) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_O_Sem
  | [ |- Constr_S ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_S_Sem
  | [ |- Constr_S ⊨c(_) _ ] => apply Constr_S_Sem
  | [ |- projT1 (Constr_S) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_S_Sem
  end.

Smpl Add smpl_TM_CaseNat : TM_Correct.

From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister HoareTactics.

Lemma Constr_O_SpecT_size (ss : Vector.t nat 1) :
  TripleT (≃≃(([], withSpace  [|Void |] ss))) Constr_O_steps Constr_O (fun _ => ≃≃(([], withSpace  [|Contains _ 0|] (appSize [|Constr_O_size|] ss)))).
Proof.  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply Constr_O_Sem.
  - intros tin [] tout H1 H2. cbn in *. specialize (H2 Fin0). simpl_vector in *; cbn in *. modpon H1. tspec_solve.
Qed.

Lemma Constr_S_SpecT_size :
  forall (y : nat) ss,
    TripleT (≃≃(([], withSpace  [|Contains _ y |] ss))) Constr_S_steps Constr_S
            (fun _ => ≃≃(([], withSpace  [|Contains _ (S y)|] (appSize [|S|] ss)))).
Proof.  unfold withSpace.
  intros y ss.
  eapply RealiseIn_TripleT.
  - apply Constr_S_Sem.
  - intros tin [] tout H HEnc. cbn in *.
    specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H. tspec_solve.
Qed.

Definition CaseNat_size (n : nat) : Vector.t (nat->nat) 1 :=
  match n with
  | O => [|id|]
  | S n' => [|S|]
  end.

Lemma CaseNat_SpecT_size (y : nat) (ss : Vector.t nat 1) :
  TripleT
    ≃≃([], withSpace  [|Contains _ y |] ss)
    CaseNat_steps
    CaseNat
    (fun yout =>
       ≃≃([if yout then y <> 0 else y = 0],withSpace ([|Contains _ (pred y)|])
            (appSize (CaseNat_size y) ss))).
Proof.  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply CaseNat_Sem.
  - intros tin yout tout H HEnc. specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H.
    destruct yout, y; cbn in *; auto.
    + tspec_solve. easy.
    + tspec_solve. easy.
Qed.

Ltac hstep_Nat :=
  lazymatch goal with
  | [ |- TripleT ?P ?k Constr_O ?Q ] => eapply Constr_O_SpecT_size
  | [ |- TripleT ?P ?k Constr_S ?Q ] => eapply Constr_S_SpecT_size
  | [ |- TripleT ?P ?k CaseNat ?Q ] => eapply CaseNat_SpecT_size
  end.

Smpl Add hstep_Nat : hstep_Spec.


Require Export Iron.Language.SystemF2Store.ExpBase.
Require Export Iron.Language.SystemF2Store.ExpAlt.

(********************************************************************)
(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx
  |  XLoc _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)  (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t)  (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1) (liftTX d x2)

  |  XCon dc ts xs
  => XCon dc (map (liftTT 1 d) ts) (map (liftTX d) xs)

  |  XCase xx alts
  => XCase (liftTX d xx) (map (liftTA d) alts)

  |  XUpdate c i ts x1 x2
  => XUpdate c i (map (liftTT 1 d) ts) (liftTX d x1) (liftTX d x2)

 end

 with liftTA (d: nat) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (liftTX d xx)
  end.

(********************************************************************)
(* Lift expression indices in expressions *)
Fixpoint liftXX (n:  nat) (d:  nat) (xx: exp) {struct xx} : exp :=
 match xx with
    |  XVar ix
    => if le_gt_dec d ix
        (* index was pointing into env, lift it across new elems *)
        then XVar (ix + n)
        (* index was locally bound, leave it be *)
        else xx

    |  XLoc l
    => XLoc l

    |  XLAM x
    => XLAM (liftXX n d x)

    |  XAPP x t
    => XAPP (liftXX n d x) t

    (* increase the depth as we move across a lambda *)
    |  XLam t1 x1
    => XLam t1 (liftXX n (S d) x1)

    |  XApp x1 x2
    => XApp   (liftXX n d x1) (liftXX n d x2)

    (* lift all the arguments of a data constructor *)
    |  XCon dc ts xs
    => XCon dc ts (map (liftXX n d) xs)

    (* lift all the alternatives in a case-expression *)
    |  XCase x alts
    => XCase (liftXX n d x) (map (liftXA n d) alts)

    |  XUpdate c i ts x1 x2
    => XUpdate c i ts (liftXX n d x1) (liftXX n d x2)
    end

 with liftXA (n: nat) (d: nat) (aa: alt) {struct aa}:=
  match aa with
  (* When we enter into the right of an alternative, a new type
     is pushed onto the environment for each of the arguments
     of the data constructor. We need to increase the current
     binding depth by the number of arguments. *)
  |  AAlt (DataCon tag arity) x
  => AAlt (DataCon tag arity) (liftXX n (d + arity) x)
  end.

(* The data constructor of an alternative is unchanged
   by lifting. *)
Lemma dcOfAlt_liftXA
 : forall n d a
 , dcOfAlt (liftXA n d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftXA : global.

Lemma dcOfAlt_liftTA
 : forall d a
 , dcOfAlt (liftTA d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftTA : global.

Lemma dcOfAlt_liftTA_map
 :  forall ix aa
 ,  map dcOfAlt (map (liftTA ix) aa)
 =  map dcOfAlt aa.
Proof.
 intros. induction aa; simpl; burn.
Qed.
Hint Rewrite dcOfAlt_liftTA_map : global.

(* When we lift an expression by zero places,
   then the expression is unchanged. *)
Lemma liftXX_zero
 : forall d x
 , liftXX 0 d x = x.
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA 0 d a = a)
  ; intros; simpl; try burn.

 Case "XVar".
  lift_cases; burn.

 Case "XCon".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto.

 Case "XCase".
  nforall.
  rewrite (map_ext_in (liftXA 0 d) id); auto.
  rewrite map_id. burn.

 Case "XAlt".
  destruct dc. burn.
Qed.
Hint Rewrite liftXX_zero : global.

(* Commutivity of lifting. *)
Lemma liftXX_comm
 : forall n m x d
 , liftXX n d (liftXX m d x)
 = liftXX m d (liftXX n d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA n d (liftXA m d a)
      =  liftXA m d (liftXA n d a))
  ; intros; simpl; try burn.

 Case "XVar".
  repeat (simple; lift_cases; intros); burn.

 Case "XCon".
  f_equal. lists.
  nforall.
  rewrite (map_ext_in
   (fun x0 => liftXX n d (liftXX m d x0))
   (fun x0 => liftXX m d (liftXX n d x0))); burn.

 Case "XCase".
  f_equal. eauto.
  lists.
  nforall.
  rewrite (map_ext_in
   (fun a1 => liftXA n d (liftXA m d a1))
   (fun a1 => liftXA m d (liftXA n d a1))); burn.

 Case "XAlt".
  destruct dc. burn.
Qed.

(* When consecutively lifting an expression, we can lift by one
   more place in the first lifting and but one less in the second. *)
Lemma liftXX_succ
 : forall n m d x
 , liftXX (S n) d (liftXX m     d x)
 = liftXX n     d (liftXX (S m) d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA (S n) d (liftXA  m    d a)
      =  liftXA n     d (liftXA (S m) d a))
  ; intros; simpl; try burn.

 Case "XVar".
  repeat (simple; lift_cases; intros); burn.

 Case "XCon".
  f_equal. lists. nforall.
  rewrite (map_ext_in
   (fun x0 => liftXX (S n) d (liftXX m d x0))
   (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

 Case "XCase".
  f_equal; auto. lists. nforall.
  rewrite (map_ext_in
   (fun x1 => liftXA (S n) d (liftXA m d x1))
   (fun x1 => liftXA n d (liftXA (S m) d x1))); burn.
  auto. auto.

 Case "XAlt".
  destruct dc; burn.
Qed.
Hint Rewrite liftXX_succ : global.

(* We can collapse two consecutive lifting expressions by lifting
   just onces by the sum of the places, provided the lifting
   occurs at depth zero.
   (TODO: we may be able to weaken this second requirement. *)
Lemma liftXX_plus
 : forall n m x
 , liftXX n 0 (liftXX m 0 x) = liftXX (n + m) 0 x.
Proof.
 intros. gen n.
 induction m; intros.
  burn.

  intros.
  rrwrite (n + S m = S n + m).
  rewrite liftXX_comm.
  rewrite <- IHm.
  rewrite liftXX_comm.
  burn.
Qed.


(*|
############################################
Tactic automation: simple decision procedure
############################################

:Link: https://stackoverflow.com/q/47126795
|*)

(*|
Question
********

I'm trying to automate a decision procedure for whether an ASCII
character is whitespace or not. Here is what I currently have.
|*)

Require Import Ascii String.

Scheme Equality for ascii.

Definition IsWhitespace (c : ascii) := (c = "009"%char) \/ (c = "032"%char).

Definition isWhitespace (c : ascii) : {IsWhitespace c} + {not (IsWhitespace c)}.
Proof.
  unfold IsWhitespace.
  pose proof (ascii_eq_dec c "009"%char) as [H1 | H1];
    pose proof (ascii_eq_dec c "032"%char) as [H2 | H2]; auto.
  right. intros [H3 | H3]; auto.
Qed.

(*|
What would be a good approach for making the proof more concise?
|*)

(*|
Answer (ejgallego)
******************

The proof is almost the most concise it can be! At most what you can
do is to call a more powerful tactic such as ``intuition``:
|*)

Reset isWhitespace. (* .none *)
Definition isWhitespace (c : ascii) : {IsWhitespace c} + {not (IsWhitespace c)}.
Proof.
  now unfold IsWhitespace;
    case (ascii_eq_dec c "009"%char);
    case (ascii_eq_dec c " "%char); intuition.
Qed.

(*|
----

**A:** Just a bit more concise reformulation of the above:
|*)

Reset isWhitespace. (* .none *)
Definition isWhitespace (c : ascii) : {IsWhitespace c} + {not (IsWhitespace c)}.
Proof.
  compute; case (ascii_eq_dec c "009"%char), (ascii_eq_dec c " "%char); tauto.
Qed.

(*| We use ``compute`` to unfold everything here. |*)

(*|
Answer (Jason Gross)
********************

Frequently, making a proof more automated involves writing a bit more
code than you started with, so that you can handle more cases. Taking
this approach, I adapted some boilerplate from `fiat-crypto
<https://github.com/mit-plv/fiat-crypto/blob/5da42750e1349ce761107902ef3039195adac62c/src/Util/Decidable.v>`__:
|*)

Reset Initial. (* .none *)
Require Import Coq.Strings.Ascii Coq.Strings.String.

Class Decidable (P : Prop) := dec : {P} + {~P}.
Arguments dec _ {_}.
Notation DecidableRel R := (forall x y, Decidable (R x y)).

Global Instance dec_or {A B} {HA : Decidable A} {HB : Decidable B} :
  Decidable (A \/ B).
Proof. hnf in *. tauto. Defined.
Global Instance dec_eq_ascii : DecidableRel (@eq ascii) := ascii_dec.

(*| With this boilerplate, your proof becomes |*)

Definition IsWhitespace (c : ascii) := (c = "009"%char) \/ (c = "032"%char).
Definition isWhitespace (c : ascii) : Decidable (IsWhitespace c) := _.

(*|
which is about as short as a proof can be. (Note that ``:= _`` is the
same as ``. Proof. exact _. Defined.``, which itself is the same as
``. Proof. typeclasses eauto. Defined.``.)

Note that this is fairly similar to ejgallego's proof, since ``tauto``
is the same as ``intuition fail``.

Note also that `the original boilerplate in fiat-crypto
<https://github.com/mit-plv/fiat-crypto/blob/5da42750e1349ce761107902ef3039195adac62c/src/Util/Decidable.v>`__
is much longer, but also more powerful than simply using ``hnf in *;
tauto``, and handles a few dozen different sorts of decidable
propositions.

----

**Q:** This is super interesting! Would you mind explaining the
``Arguments`` aspect? And why use ``Notation`` instead of
``Definition``?

**Q:** Also... This approach looks a lot like the
``Coq.Structures.Equalities`` part of the standard library, is there
any particular reason not to use it?

**A:** The ``Arguments`` bit lets you write ``dec (x = y)`` to mean
"find an instance of decidability of ``x = y`` by typeclass resolution
and use that here". Without it, ``dec (x = y)`` is a type error,
because ``dec`` means "find the first instance of decidability of any
proposition, by typeclass resolution, and use that here".
|*)

(*|
Answer (ejgallego)
******************

Following the spirit of Jason's answer, we can of course use some
libraries dealing with decidable equality to arrive at your result:

This will declare ``ascii`` as a type with decidable equality:
|*)

Reset Initial. (* .none *)
From Coq Require Import Ascii String ssreflect ssrfun ssrbool.
From mathcomp Require Import eqtype ssrnat.

Lemma ascii_NK : cancel N_of_ascii ascii_of_N.
Proof. exact: ascii_N_embedding. Qed.

Definition ascii_eqMixin := CanEqMixin ascii_NK.
Canonical ascii_eqType := EqType _ ascii_eqMixin.

(*|
In this style, usually you state your properties are decidable
propositions so there is nothing to prove:
|*)

Definition IsWhitespaceb (c : ascii) := [|| c == "009"%char | c == " "%char].

(*|
However if you want, you can of course recover the non-computational one:
|*)

Definition IsWhitespace (c : ascii) := (c = "009"%char) \/ (c = "032"%char).

Lemma whitespaceP c : reflect (IsWhitespace c) (IsWhitespaceb c).
Proof. exact: pred2P. Qed.

(*| Some more automation can be used of course. |*)


Inductive foo (V:Type):Type :=
  | Foo : list (bar V) -> foo V
with bar (V:Type): Type :=
  | bar1: bar V
  | bar2 : V -> bar V.

Module WithPoly.
Polymorphic Inductive foo (V:Type):Type :=
  | Foo : list (bar V) -> foo V
with bar (V:Type): Type :=
  | bar1: bar V
  | bar2 : V -> bar V.
End WithPoly.