(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Avi Shinnar
 *
 * 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 Arith QArith Bool.
Require Import Qcanon.
Opaque Qcplus. Opaque Qcopp.
Require Import Ynot.Axioms.

Set Implicit Arguments.
Unset Strict Implicit.

(* zeroth some general lemmas that are not specific to this particular development *)

Lemma Qcle_bool_iff (x y : Qc) : Qle_bool x y = true <-> (x <= y)%Qc.
Proof. unfold Qcle. intros. apply Qle_bool_iff. Qed.

Theorem Some_inj : forall T (x y : T),
  Some x = Some y
  -> x = y.
  intros; congruence.
Qed.

Theorem Dynq_inj_Someq : forall (T : Set) (x y : T) (q1 q2 : Qc),
     Some (Dyn x, q1) = Some (Dyn y, q2)
  -> q1 = q2.
Proof.
  intros. pose (fun (T : Type) (x : option (T * Qc)) =>
  match x with
    | Some (_,x) => x
    | None => q1
  end).
  assert (q _ (Some (Dyn x, q1)) = q _ (Some (Dyn y, q2))); auto.
  rewrite H. reflexivity.
Qed.

Lemma Dynq_inj_Somed' : forall (d1 d2 : dynamic) (q : Qc),
     Some (d1, q) = Some (d2, q)
  -> d1 = d2.
  congruence.
Qed.

Theorem Dynq_inj_Somed : forall (T : Set) (x y : T) (q1 q2 : Qc),
     Some (Dyn x, q1) = Some (Dyn y, q2)
  -> x = y.
  intros. inversion H. subst.
  apply Dyn_inj.
  apply Dynq_inj_Somed' with (q:=q2).
  try rewrite <- (Dynq_inj_Someq H) in *.
  trivial.
Qed.

(* first we define the underlying set of permissions and its partial additive function *)
Definition perm := Qc.

(* notations and basic lemmas *)
Definition Qc0 := (Q2Qc (Qmake Z0 xH)).
Notation "00" := Qc0.

Definition top : perm := 00.

(* The definition of compatibility (not in-compatible):
 *  two permissions are in-compatible if
 *     (p1 >= 0 /\ p2 >= 0)
 *  \/ (   (p1 >= 0 \/ p2 >= 0)
 *      /\ p1 + p2 < 0)
 *)

Definition compatibleb (p1 p2 : perm) : bool :=
let p1pos := Qle_bool 00 p1 in
  let p2pos := Qle_bool 00 p2 in
    negb (
         (p1pos && p2pos)
      || ((p1pos || p2pos) && (negb (Qle_bool 00 ((p1 + p2)%Qc)))))%Qc.

Theorem compatibleb_comm (p1 p2 : perm) : compatibleb p1 p2 = compatibleb p2 p1.
Proof.  intros. unfold compatibleb.
       rewrite Qcplus_comm.
       rewrite andb_comm. f_equal. f_equal. f_equal.
       rewrite orb_comm. f_equal.
Qed.

Theorem compatibleb_top (p : perm) : compatibleb p top = false.
Proof.
  unfold compatibleb, top. intros.
  rewrite andb_true_r. rewrite orb_true_r. simpl.
  rewrite <- (negb_involutive false). f_equal. simpl.
  rewrite Qcplus_0_r.
  destruct (Qle_bool 00 p); intuition.
Qed.

Definition compatible (p1 p2 : perm) := compatibleb p1 p2 = true.

Infix "|#|" := compatible (at level 60, no associativity).

Lemma compatible_sym (p1 p2 : perm) : compatible p1 p2 -> compatible p2 p1.
Proof. unfold compatible. intros. rewrite compatibleb_comm. trivial. Qed.

Hint Resolve compatible_sym : Ynot.

Theorem compatible_opp (p : perm) : p <> top -> compatible p (- p).
Proof.
  unfold compatible, compatibleb, top. intros.
  rewrite Qcplus_opp_r. simpl.
  rewrite andb_false_r. rewrite orb_false_r.
  generalize (Qle_bool_iff 0 p); intro; destruct (Qle_bool 00 p); simpl; trivial.
  generalize (Qle_bool_iff 0 (- p)%Qc); intro; destruct (Qle_bool 0 (- p)%Qc); simpl; trivial.
  generalize (((proj1 H0) (reflexivity true))); clear H0; intro H0.
  generalize (((proj1 H1) (reflexivity true))); clear H1; intro H1.
  generalize (proj2 (Qcle_minus_iff p 0)). simpl.
  rewrite Qcplus_0_l. intro.
  generalize (H2 H1). intro.
  elim H.
  generalize (Qle_antisym _ _ H0 H3).
  intro. apply Qc_is_canon. symmetry. auto.
Qed.

Theorem compatible_top (p:perm) : compatible p top -> False.
Proof.
  unfold compatible. rewrite (compatibleb_top p). discriminate.
Qed.

(* adding two permissions.  Addition is a partial function.
 * Only compatible permissions can be added.
 *)

Definition perm_plus (p1 p2 : perm) : option perm :=
  if compatibleb p1 p2 then Some (p1 + p2) else None.

Infix "+p" := perm_plus (at level 60, no associativity).

Definition perm_plus_compat (p1 p2 : perm) (pf:compatible p1 p2) : perm := p1 + p2.

Lemma perm_plus_is_compat (p1 p2 : perm) (pf:compatible p1 p2) : perm_plus p1 p2 = Some (perm_plus_compat pf).
Proof. unfold compatible, perm_plus, perm_plus_compat. intros. rewrite pf. trivial. Qed.

Lemma perm_plus_when_compat (p1 p2 : perm) (pf:compatible p1 p2) : perm_plus p1 p2 = Some (p1 + p2).
Proof. unfold compatible, perm_plus, perm_plus_compat. intros. rewrite pf. trivial. Qed.

(* We show it has some nice properties as in section 3 of Brookes *)
(* SYM *)
Theorem perm_plus_comm (p1 p2 : perm) : p1 +p p2 = p2 +p p1.
Proof.
  unfold perm_plus. intros. rewrite Qcplus_comm. rewrite compatibleb_comm. trivial.
Qed.

(* CANC *)
Theorem perm_plus_cancel (p p1 p2 : perm) : compatible p p1 -> (p +p p1) = (p +p p2) -> p1 = p2.
Proof.
  unfold perm_plus, compatible.  intros.
  rewrite H in H0. destruct (compatibleb p p2); try discriminate.
  generalize (Some_inj H0). intro.
  unfold perm in *.
  assert (C: -p + (p + p1) = -p + (p + p2)) by (rewrite H1; trivial).
  replace (-p + (p + p1)) with (p1) in C by ring.
  replace (-p + (p + p2)) with (p2) in C by ring.
  trivial.
Qed.

(* TOP *)
Theorem perm_plus_top (p : perm) : top +p p = None.
Proof.
  unfold perm_plus. intros. rewrite compatibleb_comm. rewrite compatibleb_top. trivial.
Qed.

(* NON-ZERO *)
Theorem perm_plus_nonzero (p p' : perm) : compatible p p' -> p +p p' <> Some p.
Proof.
  unfold compatible, perm_plus.
  intros.
  rewrite H. intro.
  generalize (Some_inj H0). clear H0; intro H0.
  generalize (f_equal (Qcplus (- p)) H0).
  intro. ring_simplify in H1.
  rewrite H1 in H.
  generalize (perm_plus_top p). rewrite perm_plus_comm.
  unfold perm_plus, top, Q2Qc. simpl; intro.
  rewrite H in H2. discriminate.
Qed.

(* COMP *)
Theorem perm_comp (p : perm) : p <> top -> p +p (- p) = Some top.
Proof.
  unfold perm_plus. intros. rewrite compatible_opp; auto.
  rewrite Qcplus_opp_r. auto.
Qed.

Ltac notHyp P :=
  match goal with
    | [ _ : P |- _ ] => fail 1
    | _ => idtac
  end.

Ltac extend pf :=
  let t := type of pf in
    notHyp t; generalize pf; intro.

Lemma Qle_bool_plus_pos (p0 p1:Qc) :
  Qle_bool (00) p0 = true
  -> Qle_bool (00) p1 = true
  -> Qle_bool (00) (p0 + p1)%Qc = true.
Proof.
  intros.

  generalize ((proj1 (Qcle_bool_iff 0 p0 )) H); clear H; intro H.
  generalize ((proj1 (Qcle_bool_iff 0 p1 )) H0); clear H0; intro H0.
  generalize (Qcplus_le_compat _ _ _ _ H H0).
  intro G.
  apply (proj2 (Qcle_bool_iff 0 (p0 + p1)%Qc)).
  auto.
Qed.

Lemma negb_inv b1 b2 : negb b1 = negb b2 -> b1 = b2.
Proof. destruct b1; destruct b2; auto. Qed.

Lemma Qle_bool_false (p1 p2 : Qc) : Qle_bool p1 p2 = false -> (p2 < p1).
Proof.
  intros.
  generalize ((proj2 (Qle_bool_iff p1 p2))). rewrite H.
  destruct (Qlt_le_dec p2 p1); intuition; try discriminate.
Qed.

Lemma neg_neg_npos p0 p1 :
   p0 < 0
-> p1 < 0
-> 0 <= p0 + p1
-> False.
Proof.
  intros.
  generalize (Qclt_le_trans _ _ _ H H1). intro.
  generalize ((proj1 (Qclt_minus_iff _ _)) H2). intro.
  ring_simplify in H3.
  elim (Qclt_not_le _ _ H3). apply Qclt_le_weak; auto.
Qed.

Hint Resolve neg_neg_npos.

Ltac desb :=
  repeat match goal with
           | [H: ?x = ?y |- _] => rewrite <- H in *
           | [|- context [compatibleb ?x ?y]] =>
             let HH := fresh "HH" in
               remember (compatibleb x y) as HH;
                 destruct HH
         end; simpl; trivial.

  Ltac btol := repeat match goal with
    | [H: ?x = ?x |- _] => clear H
    | [H: true = _ |- _] => symmetry in H
    | [H: false = _ |- _] => symmetry in H
    | [|- context [Qle_bool ?x ?y]] =>  generalize (Qle_bool_iff x y); intro; destruct (Qle_bool x y)
    | [|- context [Qeq_bool ?x ?y]] =>  generalize (Qeq_bool_iff x y); intro; destruct (Qeq_bool x y)
    | [H: Qle_bool 0 ?y = true |- _] =>  generalize ((proj1 (Qcle_bool_iff 00 _)) H); clear H; intro H
    | [H: Qeq_bool ?x ?y = true |- _] =>  generalize ((proj1 (Qeq_bool_iff x y)) H); clear H; intro H
    | [H: Qle_bool 0 ?y = false |- _] =>  generalize (@Qle_bool_false 00 _ H); clear H; intro H
  end; trivial.

  Ltac bool_to_logic :=
    repeat match goal with
    | [H: ?x = ?x |- _ ] => clear H
    | [H: true = _ |- _] => discriminate || symmetry in H
    | [H: false = _ |- _] => discriminate || symmetry in H
    | [H: ?x && ?y = true  |- _] => destruct (andb_true_eq  _ _ (sym_eq H)); clear H; try discriminate
    | [H: ?x || ?y = false |- _] => destruct (orb_false_elim  _ _ H); clear H; try discriminate
    | [H: ?x || ?y = true  |- _] => destruct (orb_true_elim   _ _ H); clear H
    | [H: ?x && ?y = false |- _] => destruct (andb_false_elim _ _ H); clear H
    | [H: negb ?x  = _  |- _] => generalize (f_equal negb H); clear H; intro H;
      rewrite negb_involutive in H; simpl in H
            | [H: ?x && ?y = true |- _] => destruct (andb_true_eq _ _ H); clear H
    | [|- ?x && ?y = true  ] => apply andb_true_intro
    | [|- ?x || ?y = false ] => apply orb_false_intro
    | [|- ?x || ?y = true  ] => apply orb_true_intro
(*    | [|- ?x && ?y = false ] => apply andb_false_intro *)
    | [H: ?x = ?y |- _] => rewrite H in *; simpl in *
    | _ =>   rewrite negb_andb in *; rewrite negb_involutive in *
  end.

  Ltac translelt :=
    match goal with
      | [H1:?x < ?y, H2: ?y <= ?z |- _] => extend (Qclt_le_trans _ _ _ H1 H2)
      | [H1:?x <= ?y, H2: ?y < ?z |- _] => extend (Qcle_lt_trans _ _ _ H1 H2)
      | [H1:?x <= ?y, H2: ?y <= ?z |- _] => extend (Qcle_trans _ _ _ H1 H2)
    end.

  Ltac toR := match goal with
    | [H: ?x < _ |- _] =>
      match x with
        | 0%Qc => fail 1
        | {| this := 0; canon := Qred_involutive 0 |} => fail 1
        | _ =>
          let newH := fresh "newH" in
            generalize ((proj1 (Qclt_minus_iff _ _)) H); intro newH
              ; ring_simplify in newH;
              let t := type of newH in revert newH;
                notHyp t; clear H; intro H
      end
  end.

  Ltac find_ltcontra1 :=
  match goal with
    | [H1: 0 < ?x, H2:0 < 0 + - ?x |- _] =>
      elim (Qclt_not_le _ _ H1);
        apply Qclt_le_weak; auto;
          apply ((proj2 (Qclt_minus_iff _ _))); auto
  end.

  Ltac find_ltcontra2 :=
    unfold Q2Qc in *
  ; simpl in *
  ; match goal with
      | [H: ?x < ?x |- _] => elim (Qclt_not_eq _ _ H); reflexivity
    end.

  Ltac ltcontra :=
    repeat translelt
  ; repeat toR
  ; change ({| this := 0; canon := Qred_involutive 0 |}) with  (Q2Qc (Qmake Z0 xH)) in * ;
    (find_ltcontra1 || find_ltcontra2).

Theorem compatibleb_assoc (p1 p2 p3 : perm) :
     compatibleb p1 p2 = true
  -> compatibleb (p1 + p2) p3 = true
  -> compatibleb (p3 + p1) p2 = true.
Proof.
  intros.
  desb;
  unfold compatibleb in *.
  remember (Qle_bool 0%Qc p1) as b; destruct b;
  remember (Qle_bool 0%Qc p2) as b; destruct b;
  remember (Qle_bool 0%Qc p3) as b; destruct b;
  simpl in *;
    try discriminate; repeat rewrite negb_involutive in *;
  repeat rewrite negb_orb in *;
  repeat progress (repeat match goal with
    [H: _ = _ |- _] => rewrite <- H in *
  end; simpl in *;
  try rewrite negb_involutive in *;
  try rewrite Qcplus_assoc in *;
  try rewrite andb_false_l in *; try rewrite andb_false_r in *;
  try rewrite andb_true_l in *;  try rewrite andb_true_r in *;
  try rewrite orb_false_l in *;  try rewrite orb_false_r in *;
  try rewrite orb_true_l in *;   try rewrite orb_true_r in *);
  try discriminate; bool_to_logic; btol;
    try (elimtype False; eauto); ltcontra.
Qed.

Lemma compatibleb_trans (p1 p2 p3 : perm) :
  compatibleb p1 p2 = true
  -> compatibleb (p1 + p2) p3 = true
  -> compatibleb p1 p3 = true.
Proof.
  intros.
  desb;
  unfold compatibleb in *.
  remember (Qle_bool 0%Qc p1) as b; destruct b;
  remember (Qle_bool 0%Qc p2) as b; destruct b;
  remember (Qle_bool 0%Qc p3) as b; destruct b;
(*  remember (Qlt_bool (p + p0) 0%Qc) as b; destruct b; simpl; trivial; *)
  simpl in *; try discriminate; repeat rewrite negb_involutive in *;
  repeat rewrite negb_orb in *;
  repeat progress (repeat match goal with
    [H: _ = _ |- _] => rewrite <- H in *
  end; simpl in *;
  try rewrite negb_involutive in *;
  try rewrite Qcplus_assoc in *;
  try rewrite andb_false_l in *; try rewrite andb_false_r in *;
  try rewrite andb_true_l in *;  try rewrite andb_true_r in *;
  try rewrite orb_false_l in *;  try rewrite orb_false_r in *;
  try rewrite orb_true_l in *;   try rewrite orb_true_r in *);
  try discriminate; bool_to_logic; btol;
    try (elimtype False; eauto); ltcontra.
Qed.

Theorem compatible_assoc (p1 p2 p3 : perm) :
     p1 |#| p2
  -> (p1 + p2) |#| p3
  -> (p3 + p1) |#| p2.
Proof.
  unfold compatible. intros.
  apply (compatibleb_assoc H H0).
Qed.

Lemma compatible_trans (p1 p2 p3 : perm) : compatible p1 p2 -> compatible (p1 + p2) p3 -> compatible p1 p3.
Proof.
  unfold compatible. intros.
  apply (compatibleb_trans H H0).
Qed.

Theorem perm_plus_ass (p p0 p1 : perm) :
  match p0 +p p1 with
    | None => None
    | Some p2p3 => p +p p2p3
  end =
  match p +p p0 with
    | None => None
    | Some p1p2 => p1p2 +p p1
  end.
Proof.
  unfold perm_plus.
  desb;
(*  remember (compatibleb p0 p1) as p0p1; destruct p0p1;
  remember (compatibleb p p0) as pp0; destruct pp0; trivial.
  rewrite Qcplus_assoc. desb; trivial. *)

  (* sub-goal 1:1 *)
  unfold compatibleb in *;
  remember (Qle_bool 0%Qc p) as b; destruct b;
  remember (Qle_bool 0%Qc p0) as b; destruct b;
  remember (Qle_bool 0%Qc p1) as b; destruct b;
(*  remember (Qlt_bool (p + p0) 0%Qc) as b; destruct b; simpl; trivial; *)
  simpl in *; try discriminate; repeat rewrite negb_involutive in *;
  repeat rewrite negb_orb in *;
  repeat progress (repeat match goal with
    [H: _ = _ |- _] => rewrite <- H in *
  end; simpl in *;
  try rewrite negb_involutive in *;
  try rewrite Qcplus_assoc in *;
  try rewrite andb_false_l in *; try rewrite andb_false_r in *;
  try rewrite andb_true_l in *;  try rewrite andb_true_r in *;
  try rewrite orb_false_l in *;  try rewrite orb_false_r in *;
  try rewrite orb_true_l in *;   try rewrite orb_true_r in *);
  try discriminate; bool_to_logic; btol;
    try (elimtype False; eauto). ltcontra. ltcontra.
Qed.

(* We now lift this to a set of optional permissions with total + *)
Definition permo := option perm.

Definition permo_valid (p:permo) := if p then True else False.

Definition permo_plus (p1 p2 : permo) : permo :=
  match p1 with
    | None => None
    | Some p1' =>
      match p2 with
        | None => None
        | Some p2' => p1' +p p2'
      end
  end.

Infix "+po" := permo_plus (at level 59, left associativity).

Definition compatiblep (p1 p2 : permo) := permo_valid (p1 +po p2).

Theorem permo_plus_comm (p1 p2 : permo) : p1 +po p2 = p2 +po p1.
Proof.
  destruct p1; destruct p2; simpl; trivial. apply perm_plus_comm.
Qed.

(* wow, does this need cleanup *)
Theorem permo_plus_ass (p1 p2 p3 : permo) : p1 +po (p2 +po p3) = (p1 +po p2) +po p3.
Proof.
  unfold permo_plus, perm_plus.
  destruct p1; trivial.
  destruct p2; trivial.

  destruct p3; trivial. 2: desb.
desb;
(*  remember (compatibleb p0 p1) as p0p1; destruct p0p1;
  remember (compatibleb p p0) as pp0; destruct pp0; trivial.
  rewrite Qcplus_assoc. desb; trivial. *)

  (* sub-goal 1:1 *)
  unfold compatibleb in *;
  remember (Qle_bool 0%Qc p) as b; destruct b;
  remember (Qle_bool 0%Qc p0) as b; destruct b;
  remember (Qle_bool 0%Qc p1) as b; destruct b;
(*  remember (Qlt_bool (p + p0) 0%Qc) as b; destruct b; simpl; trivial; *)
  simpl in *; try discriminate; repeat rewrite negb_involutive in *;
  repeat rewrite negb_orb in *;
  repeat progress (repeat match goal with
    [H: _ = _ |- _] => rewrite <- H in *
  end; simpl in *;
  try rewrite negb_involutive in *;
  try rewrite Qcplus_assoc in *;
  try rewrite andb_false_l in *; try rewrite andb_false_r in *;
  try rewrite andb_true_l in *;  try rewrite andb_true_r in *;
  try rewrite orb_false_l in *;  try rewrite orb_false_r in *;
  try rewrite orb_true_l in *;   try rewrite orb_true_r in *);
  try discriminate; bool_to_logic; btol;
    try (elimtype False; eauto); ltcontra.
Qed.

Definition compatiblep_alt (p1 p2 : permo) :=
  match p1 with
    | None => False
    | Some p1' =>
      match p2 with
        | None => False
        | Some p2' => compatible p1' p2'
      end
  end.

Lemma compatiblep_to_alt (p1 p2 : permo) : compatiblep p1 p2 -> compatiblep_alt p1 p2.
Proof.
  unfold compatiblep, compatiblep_alt, permo_valid, permo_plus, perm_plus, compatible.
  destruct p1; intuition.
  destruct p2; intuition.
  destruct (compatibleb p p0); intuition.
Qed.

Theorem permo_plus_cancel (p p1 p2 : permo) : compatiblep p p1 -> (p +po p1) = (p +po p2) -> p1 = p2.
Proof.
  intros.
  generalize (compatiblep_to_alt H). unfold compatiblep_alt. intro.
  destruct p; destruct p1; destruct p2; simpl in *; intuition.
  f_equal. eapply perm_plus_cancel; eauto.
  unfold perm_plus in H0.
  rewrite H1 in H0. discriminate.
Qed.

Definition topo : permo := Some top.

Theorem permo_plus_topo p : topo +po p = None.
Proof.
  intros. unfold permo_plus.
  destruct p; trivial.
  simpl. apply perm_plus_top.
Qed.

Theorem permo_plus_nonzero (p p' :permo) : compatiblep p p' -> p +po p' <> p.
Proof.
  intros. generalize (compatiblep_to_alt H).  unfold compatiblep_alt.
  destruct p; destruct p'; intuition.
  simpl in H1. eapply perm_plus_nonzero; eauto.
Qed.


Require Export MetaCoq.Template.All.
Require Export MetaCoq.Template.Checker.
Require Export List.
Export ListNotations MCMonadNotation.

Existing Instance config.default_checker_flags.
Existing Instance default_fuel.

Open Scope bs.

From MetaCoq.Template Require Import Checker.
Import MCMonadNotation ListNotations.

Definition try_infer `{config.checker_flags} `{Fuel} (Σ : global_env_ext) Γ t :=
  match infer' Σ Γ t with Checked res => res | TypeError _ => tApp (tVar "error") [t] end.

Fixpoint ford_arith
  (n : nat)            (* index for lifting *)
  (args : list term) (* the list of arguments *)
  (tys : list term)  (* the types of the arguments *)
  (t : term)         (* head of the return type *)
  : term
(*
   for args = [a_1, ..., a_n], tys = [ty_1, ..., ty_n]
   returns
   ```
   forall x_1 : ty_1, x_1 = ty_1 ->
   ... ->
   forall x_n : ty_n, x_n = ty_n ->
   t x_1 ... x_n
   ```
   properly lifted using n
*)
  :=
  match args, tys with
    a :: args, ty :: tys =>
      tProd (mkBindAnn nAnon Relevant)
        (lift n 0 ty)
        (tProd (mkBindAnn nAnon Relevant)
                 (tApp <% @eq %> [ty ; (tRel 0) ; (lift (1 + 2 * n) 0 a)])
                 (ford_arith (S n) args tys t))
  | nil, nil => tApp (lift (2 * n) 0 t) (map (fun i => tRel (2 * i + 1)) (rev (seq 0 n)))
  | _, _ => tVar "error"%bs
  end.

Fixpoint ford_forward
  (n : nat)            (* index for lifting "old" things *)
  (gen : list nat)     (* the new information generated, in this case the variables x_1 ... x_n for the result *)
  (args : list term) (* the list of arguments *)
  (tys : list term)  (* the types of the arguments *)
  (t : term)         (* head of the return type *)
  : term
(*
   for args = [a_1, ..., a_n], tys = [ty_1, ..., ty_n]
   returns
   ```
   forall x_1 : ty_1, x_1 = ty_1 ->
   ... ->
   forall x_n : ty_n, x_n = ty_n ->
   t x_1 ... x_n
   ```
   properly lifted using n
*)
  :=
  match args, tys with
    a :: args, ty :: tys =>
      tProd (mkBindAnn nAnon Relevant)
        (lift n 0 ty)
        (tProd (mkBindAnn nAnon Relevant)
                 (tApp <% @eq %> [ty ; (tRel 0) ; (lift (1 + n) 0 a)]) (* 1 + n because we introduced one binder *)
                 (ford_forward (S (S n)) (1 :: map (S ∘ S) gen) args tys (lift 2 0 t))) (* S (S n) because we introduced two binders, same for lift 2 0 t *)
  | nil, nil => tApp t (map tRel (rev gen)) (* we could also do lift n 0 t here, and not update t in recursive calls *)
  | _, _ => tVar "error"%bs
  end.

(** In the style of ford_forward
   it should be easy to write two functions ford_forward1 and ford_forward2 which if composed
   for args = [a_1, ..., a_n], tys = [ty_1, ..., ty_n]
   return
   ```
   forall x_1 : ty_1, ..., forall x_n : ty_n,
   x_1 = ty_1 -> ... -> x_n = ty_n ->
   t x_1 ... x_n
   ```
   ford_forward1 returns
   - the term t properly lifted
   - a list [ ty_1, .., ty_n ] properly lifted
   - and a list [x_1, ..., x_n ]
   then ford_forward2 does recursion on the first list and generates
   x_1 = ty_1 -> ... -> x_n = ty_n ->
   t x_1 ... x_n
   ( while always updating the second list and lifting t properly)
 *)

Fixpoint ford_type ford Σ Γ (t : term) :=
  match t with
  | tProd na A B =>
      tProd na A (ford_type ford Σ (Γ ,, vass na A) B)
  | tApp t args =>
      ford args (map (try_infer Σ Γ) args) t
  | _ => tVar "error"
  end.

Definition run_fording ford (A : Type) :=
  p <- tmQuoteRec A ;;
  let (Σ, sA) := (p : program) in
  r <- tmEval cbv (ford_type ford (Σ, Monomorphic_ctx) [] sA) ;;
  (* tmPrint r ;; ret r. *)
  res <- tmUnquote r ;;
  tmPrint res ;;
  ret res.

Inductive test : nat -> Type -> nat -> Prop := .

MetaCoq Run (run_fording (ford_arith 0) (forall n m, test n nat m)).
MetaCoq Run (run_fording (ford_arith 0) (forall (T : nat -> Type -> nat -> Prop) n m, T n nat m)).
MetaCoq Run (run_fording (ford_forward 0 []) (forall n m, test n nat m)).
MetaCoq Run (run_fording (ford_forward 0 []) (forall (T : nat -> Type -> nat -> Prop) n m, T n nat m)).

(** Version with general renamings, a bit more complicated but necessary in general  *)

Section map_predicate_shift.
  Context {T : Type}.
  Context (fn : (nat -> T) -> term -> term).
  Context (shift : nat -> (nat -> T) -> nat -> T).
  Context (finst : Instance.t -> Instance.t).
  Context (f : nat -> T).

  Definition map_predicate_shift (p : predicate term) :=
    {| pparams := map (fn f) p.(pparams);
        puinst := finst p.(puinst);
        pcontext := p.(pcontext);
        preturn := fn (shift #|p.(pcontext)| f) p.(preturn) |}.

  Lemma map_shift_pparams (p : predicate term) :
    map (fn f) (pparams p) = pparams (map_predicate_shift p).
  Proof using Type. reflexivity. Qed.

  Lemma map_shift_preturn (p : predicate term) :
    fn (shift #|p.(pcontext)| f) (preturn p) = preturn (map_predicate_shift p).
  Proof using Type. reflexivity. Qed.

  Lemma map_shift_pcontext (p : predicate term) :
    (pcontext p) =
    pcontext (map_predicate_shift p).
  Proof using Type. reflexivity. Qed.

  Lemma map_shift_puinst (p : predicate term) :
    finst (puinst p) = puinst (map_predicate_shift p).
  Proof using Type. reflexivity. Qed.

End map_predicate_shift.

Section map_branch_shift.
  Context {T : Type}.
  Context (fn : (nat -> T) -> term -> term).
  Context (shift : nat -> (nat -> T) -> nat -> T).
  Context (f : nat -> T).

  Definition map_branch_shift (b : branch term) :=
  {| bcontext := b.(bcontext);
      bbody := fn (shift #|b.(bcontext)| f) b.(bbody) |}.

  Lemma map_shift_bbody (b : branch term) :
    fn (shift #|b.(bcontext)| f) (bbody b) = bbody (map_branch_shift b).
  Proof using Type. reflexivity. Qed.

  Lemma map_shift_bcontext (b : branch term) :
    (bcontext b) = bcontext (map_branch_shift b).
  Proof using Type. reflexivity. Qed.
End map_branch_shift.

(** Shift a renaming [f] by [k]. *)
Definition shiftn k f :=
  fun n => if Nat.ltb n k then n else k + (f (n - k)).

Notation map_branches_shift ren f :=
  (map (map_branch_shift ren shiftn f)).

Fixpoint rename f t : term :=
  match t with
  | tRel i => tRel (f i)
  | tEvar ev args => tEvar ev (List.map (rename f) args)
  | tLambda na T M => tLambda na (rename f T) (rename (shiftn 1 f) M)
  | tApp u v => tApp (rename f u) (map (rename f) v)
  | tProd na A B => tProd na (rename f A) (rename (shiftn 1 f) B)
  | tLetIn na b t b' => tLetIn na (rename f b) (rename f t) (rename (shiftn 1 f) b')
  | tCase ind p c brs =>
    let p' := map_predicate_shift rename shiftn id f p in
    let brs' := map_branches_shift rename f brs in
    tCase ind p' (rename f c) brs'
  | tProj p c => tProj p (rename f c)
  | tFix mfix idx =>
    let mfix' := List.map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in
    tFix mfix' idx
  | tCoFix mfix idx =>
    let mfix' := List.map (map_def (rename f) (rename (shiftn (List.length mfix) f))) mfix in
    tCoFix mfix' idx
  | x => x
  end.

Fixpoint ford_ren
  (ren : nat -> nat)     (* the renamings to apply to "old" parts of the term *)
  (gen : list nat)    (* the new information generated, in this case the variables x_1 ... x_n for the result *)
  (args : list term) (* the list of arguments *)
  (tys : list term)  (* the types of the arguments *)
  (t : term)         (* head of the return type *)
  : term
(*
   for args = [a_1, ..., a_n], tys = [ty_1, ..., ty_n]
   returns
   ```
   forall x_1 : ty_1, x_1 = ty_1 ->
   ... ->
   forall x_n : ty_n, x_n = ty_n ->
   t x_1 ... x_n
   ```
   properly lifted using n
*)
  :=
  match args, tys with
    a :: args, ty :: tys =>
      tProd (mkBindAnn nAnon Relevant)
        (rename ren ty)
        (tProd (mkBindAnn nAnon Relevant)
                 (tApp <% @eq %> [ty ; (tRel 0) ; (rename (S ∘ ren) a)])
                 (ford_ren (S ∘ S ∘ ren) (1 :: map (S ∘ S) gen) args tys t))
  | nil, nil => tApp (rename ren t) (map tRel (rev gen))
  | _, _ => tVar "error"%bs
  end.

MetaCoq Run (run_fording (ford_ren (fun i => i) []) (forall n m, test n nat m)).
MetaCoq Run (run_fording (ford_ren (fun i => i) []) (forall (T : nat -> Type -> nat -> Prop) n m, T n nat m)).


(** Redefinition of [pcofix] and [pcofix] without using the [JMeq_eq] axiom.
Both tactics are now called [pcofix]. The same core is reused to define [ecofix]
in [Eq.UpToTaus]. *)

From Paco Require Import paco.

Ltac debug_goal :=
  match goal with
  | [ |- ?G ] => idtac G
  end.

(* A variant of [paco2_acc] that is more convenient to use in the [pcofix] tactic. *)
Lemma paco2_accF
  : forall {T0 : Type} {T1 : forall a : T0, Type}
      (gf : rel2 T0 T1 -> rel2 T0 T1) (r : rel2 T0 T1)
      (X : Type)
      (f0 : X -> T0) (f1 : forall x : X, T1 (f0 x)),
      (forall rr : rel2 T0 T1,
        (forall a0 a1, r a0 a1 -> rr a0 a1) ->
        (forall x, rr (f0 x) (f1 x)) ->
        forall x : X, paco2 gf rr (f0 x) (f1 x)) ->
      forall x : X, paco2 gf r (f0 x) (f1 x).
Proof.
  intros.
  apply paco2_acc with
    (l := fun a0 (a1 : T1 a0) => exists x, existT _ (f0 x) (f1 x) = existT _ a0 a1); [ | eauto ].
  intros. change (paco2 gf rr (projT1 (existT _ _ x1)) (projT2 (existT _ _ x1))).
  destruct PR as [? <-].
  eauto.
Qed.

Lemma gpaco2_accF
  : forall {T0 : Type} {T1 : forall a : T0, Type}
      (gf : rel2 T0 T1 -> rel2 T0 T1),
      monotone2 gf ->
    forall (clo : rel2 T0 T1 -> rel2 T0 T1) (r rg : rel2 T0 T1)
      (X : Type)
      (f0 : X -> T0) (f1 : forall x : X, T1 (f0 x))
      (OBG : forall rr : rel2 T0 T1,
        (forall x y, rg x y -> rr x y) ->
        (forall x, rr (f0 x) (f1 x)) ->
        forall x : X, gpaco2 gf clo r rr (f0 x) (f1 x)),
      forall x : X, gpaco2 gf clo r rg (f0 x) (f1 x).
Proof.
  intros.
  apply gpaco2_cofix with
    (l := fun a0 (a1 : T1 a0) => exists x, existT _ (f0 x) (f1 x) = existT _ a0 a1); [ eauto | | eauto ].
  intros. change (gpaco2 gf clo r rr (projT1 (existT _ _ x1)) (projT2 (existT _ _ x1))).
  destruct PR as [? <-].
  eauto.
Qed.

Ltac apply_paco_acc self unpack_goal unpack_hyp :=
  let unpack _tt :=
    let r := fresh "r" in
    let self_ := fresh "_tmp_" self in
    let self := fresh self in
    intros r self_ self;
    let self1 := fresh self in
    rename self_ into self1;
    unpack_goal tt;
    unpack_hyp self in
  lazymatch goal with
  | [ |- forall _, paco2 ?gf ?r0 _ _ ] => apply paco2_accF; unpack tt
  | [ |- forall _, gpaco2 ?gf ?clo _ _ _ _ ] => apply gpaco2_accF; [ eauto with paco | unpack tt ]
  (* TODO: other arities *)
  | _ => fail "paco not found at the head of the goal"
  end.

Lemma curry_sig {A : Type} {P : A -> Type} {Q : forall (a : A) (b : P a), Prop}
  : (forall x : sigT P, Q (projT1 x) (projT2 x)) -> forall (a : A) (p : P a), Q a p.
Proof.
  exact (fun H a p => H (existT _ a p)).
Qed.

(* [pcofix self]: Apply coinduction to a goal with [paco] at the head of the conclusion
   (possibly after unfolding definitions).
   The parameter [self] is the name of the coinduction hypothesis. *)

(* Internal definition of [pcofix_]:
Example initial goal:
<<
===========
forall (x : X) (y : Y), hyp x y -> paco2 gf bot2 (f0 x y) (f1 x y)
>>
   1. [pcofix_] first recursively introduces all hypotheses [H], being careful to
      preserve existing names, and at the same time builds up continuations
      to process the goal once we reach the conclusion. This technique has the
      benefit that the name of each hypothesis is available, so it does
      not need to be guessed repeatedly.
Goal after step 1:
<<
x : X
y : Y
H : hyp x y
===========
paco2 gf bot2 (f0 x y) (f1 x y)
>>
   2. Having reached the conclusion, we use the [pack_goal0] continuation to
      regeneralize the hypotheses we introduced into a single sigma type
      (a chain of [{_ & _}]/[sigT]),
Goal after step 2:
<<
===========
forall (u : {x : X & {y : Y & {_ : hyp x y & unit}}}),
  paco2 gf bot2 (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u))
>>
   3. We can now apply [paco2_accF] (depending on the arity of paco)
Goal after step 3:
<<
r : rel2 T0 T1
_pacotmp_SELF: forall (u : _), r (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u))
==========
forall (u : {x : X & {y : Y & {_ : hyp x y & unit}}}),
  paco2 gf r (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u))
>>
   4. We decompose the tuple in the goal using the [unpack_goal0] continuation
      (basically the reverse of [pack_goal0]) and [revert_tmp0].
Goal after step 4:
<<
r : rel2 T0 T1
_pacotmp_SELF: forall (u : _), r (f0 (projT1 u) (projT2 u)) (f1 (projT1 u) (projT2 u))
==========
forall x y, hyp x y -> paco2 gf r (f0 x y) (f1 x y)
>>
   5. We decompose the tuple in the coinduction hypothesis
Goal after step 5:
<<
r : rel2 T0 T1
SELF: forall x y, hyp x y -> r (f0 x y) (f1 x y)
==========
forall x y, hyp x y -> paco2 gf r (f0 x y) (f1 x y)
>>
tODO: Currently this step does not preserve variable names,
so the actual hypothesis looks more like this:
<<
SELF: forall x0 x1, hyp x0 x1 -> r (f0 x0 x1) (f1 x0 x1)
>>
*)
Ltac pcofix_ apply_paco_acc0 pack_goal0 unpack_goal0 revert_tmp0 unpack_hyp0 :=
  hnf;
  lazymatch goal with
  | [ |- forall H : ?X, _ ] =>
    (* 1. *)
    let H := fresh H in
    intros H;
    let pack_goal := (revert H; apply curry_sig; pack_goal0) in
    let unpack_goal H0 := ltac:(unpack_goal0 H0; destruct H0 as [H H0]; cbn [projT1 projT2]) in
    let revert_tmp := revert H; revert_tmp0 in
    let unpack_hyp tmp_self :=
      intros H;
      let tmp := fresh tmp_self in
      rename tmp_self into tmp;
      assert (tmp_self := fun TMP => tmp (existT _ H TMP));
      clear tmp;
      unpack_hyp0 tmp_self in
    pcofix_ apply_paco_acc0 pack_goal unpack_goal revert_tmp unpack_hyp
  | _ =>
    let (* 4 *) unpack_goal _tt :=
      let tmp_H0 := fresh "_pacotmp_" in
      intros tmp_H0; unpack_goal0 tmp_H0; clear tmp_H0;
      revert_tmp0 in
    let (* 5 *) unpack_hyp HYP :=
      let tmp_prop := fresh HYP "_prop_" in
      let tmp_hyp := fresh HYP "_v_" in
      evar (tmp_prop : Prop); assert (tmp_hyp : tmp_prop); subst tmp_prop;
        [ unpack_hyp0 HYP; cbn in HYP; exact (HYP tt)
        | clear HYP ];
      try rename tmp_hyp into HYP in
    (* 2. pack_goal *) assert (tmp_H0 := tt); revert tmp_H0; pack_goal0;
    (* 3. paco_acc *) apply_paco_acc0 unpack_goal unpack_hyp
  end.

Ltac pcofix_with apply_paco_acc0 :=
  let pack_goal0 := idtac in
  let unpack_goal0 _ := idtac in
  let revert_tmp0 := idtac in
  let unpack_hyp0 _ := idtac in
  pcofix_ apply_paco_acc0 pack_goal0 unpack_goal0 revert_tmp0 unpack_hyp0.

Tactic Notation "pcofix" ident(self) :=
  pcofix_with ltac:(apply_paco_acc self).


From Coq Require Import Arith Psatz List String.
From DanTrick Require Import DanLogSubst DanTrickLanguage DanLogProp DanLogicHelpers StackLangTheorems.
From DanTrick Require Import LogicPropTheorems LogicProp DanTrickTactics.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope nat_scope.

Lemma dan_aexp_update_adequate_forward :
  forall (aexp aexp': aexp_Dan) (x: ident) (a: aexp_Dan),
    aexp' = dan_aexp_update x a aexp ->
    dan_aexp_update_rel x a aexp aexp'.
Proof.
  apply (aexp_Dan_ind2
           (fun aexp =>
              forall (aexp': aexp_Dan) (x: ident) (a: aexp_Dan),
                aexp' = dan_aexp_update x a aexp ->
                dan_aexp_update_rel x a aexp aexp'));
    intros; simpl in H; subst.
  - econstructor.
  - destruct_discrim_r (x =? x0)%string eqn:EQ;
      econstructor;
      try symmetry in EQ; try eassumption; try exclude_ridiculous.
  - econstructor.
  - simpl. econstructor; first [ eapply H | eapply H0]; eauto.
  - simpl. econstructor; first [ eapply H | eapply H0]; eauto.
  - revert x a. revert f. induction H; intros.
    + simpl. econstructor. econstructor.
    + simpl. econstructor. econstructor. eapply H. reflexivity.
      specialize (IHForall f x0 a).
      invs IHForall.
      assumption.
Defined.

Local Definition adequate_P (x: ident) (a: aexp_Dan) (aexp aexp': aexp_Dan): Prop :=
  aexp' = dan_aexp_update x a aexp.

Local Definition adequate_P0 (x: ident) (a: aexp_Dan) (aexps aexps': list aexp_Dan): Prop :=
  aexps' = List.map (fun exp => dan_aexp_update x a exp) aexps.

Lemma dan_aexp_args_update_adequate_backward :
  dan_aexp_args_update_rel_theorem adequate_P adequate_P0.
Proof.
  dan_aexp_args_update_mutual_induction P P0 adequate_P adequate_P0; intros.
  - simpl. reflexivity.
  - reflexivity.
  - rewrite e. simpl. destruct_discrim_r (x =? x)%string eqn:EQ. reflexivity.
  - simpl. destruct_discrim_r (x =? x')%string eqn:EQ.
    reflexivity.
  - simpl. f_equal; eassumption.
  - simpl. f_equal; eassumption.
  - simpl. f_equal; try reflexivity.
    eassumption.
  - reflexivity.
  - simpl. rewrite H0. rewrite H. reflexivity.
Defined.

Lemma dan_aexp_update_adequate_backward :
  forall (x : ident) (a aexp aexp' : aexp_Dan),
    dan_aexp_update_rel x a aexp aexp' -> aexp' = dan_aexp_update x a aexp.
Proof.
  pose proof (H:= dan_aexp_args_update_adequate_backward).
  unfold dan_aexp_args_update_rel_theorem,
    DanLogProp.dan_aexp_args_update_rel_theorem_P,
    DanLogProp.dan_aexp_args_update_rel_theorem_P0 in H.
  unfold adequate_P, adequate_P0 in H.
  destruct H as (AEXP & _).
  eapply AEXP.
Defined.

Lemma dan_args_update_adequate_backward :
  forall (x : ident) (a : aexp_Dan) (aexps aexps' : list aexp_Dan),
    dan_args_update_rel x a aexps aexps' ->
    aexps' = map (fun exp : aexp_Dan => dan_aexp_update x a exp) aexps.
Proof.
  pose proof (H:= dan_aexp_args_update_adequate_backward).
  unfold dan_aexp_args_update_rel_theorem,
    DanLogProp.dan_aexp_args_update_rel_theorem_P,
    DanLogProp.dan_aexp_args_update_rel_theorem_P0 in H.
  unfold adequate_P, adequate_P0 in H.
  destruct H as (_ & ARGS).
  eapply ARGS.
Defined.

Theorem dan_aexp_update_adequacy :
  forall (x: ident) (a: aexp_Dan) (aexp aexp': aexp_Dan),
    aexp' = dan_aexp_update x a aexp <->
      dan_aexp_update_rel x a aexp aexp'.
Proof.
  split; intros;
    first [ eapply dan_aexp_update_adequate_forward
          | eapply dan_aexp_update_adequate_backward];
    eassumption.
Defined.

Lemma dan_args_update_adequate_forward :
  forall (aexps aexps': list aexp_Dan) (x: ident) (a: aexp_Dan),
    aexps' = map (fun exp : aexp_Dan => dan_aexp_update x a exp) aexps ->
    dan_args_update_rel x a aexps aexps'.
Proof.
  induction aexps; intros; simpl in H; subst; econstructor.
  - eapply dan_aexp_update_adequacy. reflexivity.
  - eapply IHaexps. reflexivity.
Defined.

Theorem dan_args_update_adequacy :
  forall (x: ident) (a: aexp_Dan) (aexps aexps': list aexp_Dan),
    aexps' = map (fun exp : aexp_Dan => dan_aexp_update x a exp) aexps <->
      dan_args_update_rel x a aexps aexps'.
Proof.
  split;
    intros;
    first [ eapply dan_args_update_adequate_backward
          | eapply dan_args_update_adequate_forward];
    eauto.
Defined.

Lemma dan_bexp_update_adequate_forward :
  forall (bexp bexp': bexp_Dan) (x: ident) (a: aexp_Dan),
    bexp' = dan_bexp_update x a bexp ->
    dan_bexp_update_rel x a bexp bexp'.
Proof.
  induction bexp; intros; simpl in H; subst; econstructor;
    first [ eapply IHbexp
          | eapply IHbexp1
          | eapply IHbexp2
          | eapply dan_aexp_update_adequacy];
    eauto.
Defined.

Lemma dan_bexp_update_adequate_backward :
  forall (bexp bexp': bexp_Dan) (x: ident) (a: aexp_Dan),
    dan_bexp_update_rel x a bexp bexp' ->
    bexp' = dan_bexp_update x a bexp.
Proof.
  induction bexp; intros; invs H; simpl; try eauto; f_equal;
    first [ eapply IHbexp
          | eapply IHbexp1
          | eapply IHbexp2
          | eapply dan_aexp_update_adequacy];
    eauto.
Defined.

Theorem dan_bexp_update_adequacy :
  forall (bexp bexp': bexp_Dan) (x: ident) (a: aexp_Dan),
    bexp' = dan_bexp_update x a bexp <->
      dan_bexp_update_rel x a bexp bexp'.
Proof.
  split; intros;
    first [ eapply dan_bexp_update_adequate_forward
          | eapply dan_bexp_update_adequate_backward];
    eassumption.
Defined.

Lemma dan_lp_subst_adequate_forward :
  forall (d d': Dan_lp) (x: ident) (a: aexp_Dan),
    d' = subst_Dan_lp x a d ->
    subst_Dan_lp_rel x a d d'.
Proof.
  induction d'; intros.
  - destruct d; [ | simpl in H; invs H ].
    econstructor.
    simpl in H. inversion H.
    eapply transform_prop_exprs_adequacy_forward.
    eapply dan_aexp_update_adequacy.
    reflexivity.
  - destruct d; [simpl in H; invs H | ].
    econstructor. simpl in H. inversion H.
    eapply transform_prop_exprs_adequacy_forward.
    intros.
    eapply dan_bexp_update_adequacy.
    reflexivity.
Defined.

Lemma dan_log_subst_adequate_forward :
  forall (d d': AbsEnv) (x: ident) (a: aexp_Dan),
    d' = subst_AbsEnv x a d ->
    subst_AbsEnv_rel x a d d'.
Proof.
  induction d; intros; simpl in H; rewrite H.
  - econstructor.
    eapply dan_lp_subst_adequate_forward.
    reflexivity.
  - econstructor; first [ eapply IHd1 | eapply IHd2 ]; eauto.
  - econstructor; first [ eapply IHd1 | eapply IHd2 ]; eauto.
Defined.

Lemma dan_lp_subst_adequate_backward :
  forall (d d': Dan_lp) (x: ident) (a: aexp_Dan),
    subst_Dan_lp_rel x a d d' ->
    d' = subst_Dan_lp x a d.
Proof.
  induction d; intros; invs H; simpl.
  - eapply transform_prop_exprs_adequacy_backward in H3.
    + f_equal. rewrite H3. eauto.
    + intros; split; intros; eapply dan_aexp_update_adequacy; eauto.
  - eapply transform_prop_exprs_adequacy_backward in H3.
    + f_equal. rewrite H3. eauto.
    + intros; split; intros; eapply dan_bexp_update_adequacy; eauto.
Defined.

Lemma dan_log_subst_adequate_backward :
  forall (d d': AbsEnv) (x: ident) (a: aexp_Dan),
    subst_AbsEnv_rel x a d d' ->
    d' = subst_AbsEnv x a d.
Proof.
  induction d; intros; invs H; simpl.
  - eapply dan_lp_subst_adequate_backward in H3. subst. eauto.
  - eapply IHd1 in H4. eapply IHd2 in H6. subst. eauto.
  - eapply IHd1 in H4. eapply IHd2 in H6. subst. eauto.
Defined.

Theorem dan_lp_subst_adequacy :
  forall (d d': Dan_lp) (x: ident) (a: aexp_Dan),
    d' = subst_Dan_lp x a d <->
      subst_Dan_lp_rel x a d d'.
Proof.
  split; intros;
    first [ eapply dan_lp_subst_adequate_forward
          | eapply dan_lp_subst_adequate_backward ];
    eauto.
Defined.

Theorem dan_log_subst_adequacy :
  forall (d d': AbsEnv) (x: ident) (a: aexp_Dan),
    d' = subst_AbsEnv x a d <->
      subst_AbsEnv_rel x a d d'.
Proof.
  split; intros;
    first [ eapply dan_log_subst_adequate_forward
          | eapply dan_log_subst_adequate_backward ];
    eauto.
Defined.


Require Import Category.Lib.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Coq.Functor.Proofs.
Require Import Category.Theory.Coq.Applicative.Proofs.
Require Import Category.Theory.Coq.Monad.Proofs.
Require Import Category.Theory.Coq.Maybe.

Generalizable All Variables.

Import MonadNotations.

Lemma Maybe_choose_spec {a} {x y : Maybe a} :
  isJust (x <|> y) = (isJust x || isJust y)%bool.
Proof.
  destruct x; auto.
Qed.

Lemma fmap_endo_just {c} (f : c → c) (m : Maybe c) (x : c) :
  f <$> m = Just x <-> exists y, x = f y /\ m = Just y.
Proof.
  induction m; simpl; split; intros.
  - inversion_clear H.
    eexists; eauto.
  - destruct H, H; subst.
    now inversion_clear H0.
  - discriminate.
  - destruct H, H; discriminate.
Qed.

Lemma fmap_endo_nothing {c} (f : c → c) (m : Maybe c) :
  f <$> m = Nothing <-> m = Nothing.
Proof. induction m; simpl; intuition auto; discriminate. Qed.

Lemma ap_endo_just {c} (f : c → c → c) (m n : Maybe c) (x : c) :
  f <$> m <*> n = Just x
    <-> exists y z, x = f y z /\ m = Just y /\ n = Just z.
Proof.
  induction m, n; simpl; split; intros.
  - inversion_clear H.
    eexists; eauto.
  - destruct H, H, H, H0; subst.
    inversion_clear H0.
    now inversion_clear H1.
  - discriminate.
  - destruct H, H, H, H0; discriminate.
  - discriminate.
  - destruct H, H, H, H0; discriminate.
  - discriminate.
  - destruct H, H, H, H0; discriminate.
Qed.

Lemma ap_endo_nothing {c} (f : c → c → c) (m n : Maybe c) :
  f <$> m <*> n = Nothing <-> m = Nothing \/ n = Nothing.
Proof. induction m, n; simpl; intuition auto; discriminate. Qed.

Lemma bind_endo_just {c} (f : c → Maybe c) (m : Maybe c) (x : c) :
  m >>= f = Just x <-> exists y, f y = Just x /\ m = Just y.
Proof.
  induction m; simpl; split; intros.
  - destruct (f a) eqn:?.
    + inversion H; subst.
      now eexists; eauto.
    + unfold bind in H.
      simpl in H.
      congruence.
  - destruct H, H.
    inversion H0; subst.
    now unfold bind; simpl.
  - discriminate.
  - destruct H, H.
    discriminate.
Qed.

Lemma bind_endo_nothing {c} (f : c → Maybe c) (m : Maybe c) :
  m >>= f = Nothing <-> m = Nothing \/ exists y, f y = Nothing /\ m = Just y.
Proof.
  induction m; simpl; split; intros.
  - destruct (f a) eqn:?.
    + unfold bind in H; simpl in H.
      congruence.
    + right.
      now eexists; eauto.
  - destruct H.
    + discriminate.
    + firstorder eauto.
      inversion_clear H0.
      now unfold bind; simpl.
  - now left.
  - reflexivity.
Qed.

Lemma alt_endo_just {c} (m n : Maybe c) (x : c) :
  m <|> n = Just x <-> m = Just x \/ (m = Nothing /\ n = Just x).
Proof. induction m; simpl; intuition auto; discriminate. Qed.

Lemma alt_endo_nothing {c} (m n : Maybe c) :
  m <|> n = Nothing <-> m = Nothing /\ n = Nothing.
Proof. induction m, n; simpl; intuition auto; discriminate. Qed.

Program Definition Maybe_Functor : IsFunctor Maybe_Functor := {|
  a_fmap := Maybe_Functor;
|}.
Next Obligation.
  proper.
  destruct x1; simpl; auto.
  now rewrite H.
Qed.
Next Obligation.
  now destruct x0.
Qed.
Next Obligation.
  now destruct x0.
Qed.


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*		                                 			     *)
(*	     The Special Adjoint Functor Theorem (Freyd's Theorem)	     *)
(*                  ( The suficient condition : First Proof )                *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export FSC_inc.
Require Export Comma_proj.
Require Export FAFT_SSC2.
Require Export Th_Adjoint.
Require Export Pres_Limits.
Require Export Pullbacks1.

Set Implicit Arguments.
Unset Strict Implicit.

(****************************************)
(*  CONDITION SUFFISANTE                *)
(*  1ere METHODE                        *)
(****************************************)

Section freyd_th_2.

Variables (A X : Category) (G : Functor A X) (A_c : Complete A)
  (G_c : Continuous G) (s : forall x : X, SSC2 G x).

 Section uaxG.

 Variable x : X.

 (* construction de la cate'gorie (x|G)I *)

 Definition FT_I := SSC2_I (s x).

 Definition FT_f (i : FT_I) := SSC2_f i.

 Definition FT_a (i : FT_I) := SSC2_a i.

 Canonical Structure FamI (i : FT_I) := Build_Com_ob (FT_f i).

 Definition CommaI := FullSubCat FamI.

 (* inclusion E : (x|G)I -> (x|G) *)

 Definition FT_E := FSC_inc FamI.

 (* projection Q : (x|G) -> A *)

 Definition FT_Q := Comma_proj G x.

 (* Soit une limite <lim EoQ, eps> de E o Q *)

 Definition L_A := A_c (FT_E o_F FT_Q).

 Definition Lim_EoQ := Lim L_A.

 Definition FT_eps := Limiting_cone L_A.

 (* G preserve cette Limite *)

 Definition L_X := G_c L_A.

 (* construisons tau : Diag(x) -> (FT_E o FT_Q) o G *)

 Definition FT_tau_i (i : FT_I) := FT_f i.

 Lemma FT_tau_cone_law : Cone_law (F:=(FT_E o_F FT_Q) o_F G) FT_tau_i.
 Proof.
 unfold Cone_law in |- *; simpl in |- *; unfold FT_tau_i, FMor in |- *;
  simpl in |- *.
 intros i j h.
 elim h; intros g H; exact H.
 Qed.

 Definition FT_tau := Build_Cone FT_tau_cone_law.

 (* tau# *)

 Definition FT_tau_d := Lim_diese L_X FT_tau.

 Definition FT_Apeps (i : FT_I) : Lim_EoQ --> FT_a i := FT_eps i.

 Lemma FT_eq_tau :
  forall i : FT_I, FT_tau i =_S FT_tau_d o FMor G (FT_Apeps i).
 Proof.
 intro i; apply Sym; apply (Prf_limit1 L_X FT_tau i).
 Qed.

 (* dem que <Lim(EoQ),tau#> est un UA de x vers G *)

  Section uaxG_verif.

  Variables (a' : A) (h : x --> G a').

  Definition FT_i0 := SSC2_i (s x) h.

  Definition FT_t := SSC2_t (s x) h.

  (* construction de h# : Lim(EoQ) -> a' *)

  Definition FT_h_diese : Lim_EoQ --> a' := FT_Apeps FT_i0 o FT_t.

  Lemma FT_UA_law1 : UA_eq FT_tau_d h FT_h_diese.
  Proof.
  unfold UA_eq, FT_h_diese in |- *.
  (* *) apply Trans with (FT_tau_d o FMor G (FT_Apeps FT_i0) o FMor G FT_t).
  apply Comp_l; apply FComp.
  (* *) apply Trans with ((FT_tau_d o FMor G (FT_Apeps FT_i0)) o FMor G FT_t).
  apply Ass.
  (* *) apply Trans with (FT_tau FT_i0 o FMor G FT_t).
  apply Comp_r.
  apply Sym; apply (FT_eq_tau FT_i0).
  apply Sym; apply (Prf_SSC2_law (s x) h).
  Qed.

  (* unicite' de h# *)

  Variable FT_h' : Lim_EoQ --> a'.

  (* h = tau# o G(h#') *)

  Hypothesis H : UA_eq FT_tau_d h FT_h'.

  Definition FT_j0 := SSC2_i (s x) FT_tau_d.

  Definition FT_t' := SSC2_t (s x) FT_tau_d.

  (* pullback P pour t et (t' o h#') *)

  Definition FT_P : Pullback1 FT_t (FT_t' o FT_h') :=
    A_c (Fpulb FT_t (FT_t' o FT_h')).

  Definition FT_b := Fibred1_prod FT_P.

  Definition FT_p := Fibred1_p FT_P.

  Definition FT_q := Fibred1_q FT_P.

  (* P is preserved by G *)

  Definition FT_GP' := G_c FT_P.

  Definition FT_GP : Fpullback1 (Fpulb FT_t (FT_t' o FT_h') o_F G) :=
    Build_Limit FT_GP'.

  (* Le grand diagramme commute *)

  Lemma FT_diag1 :
   Pullback_eq1 (FMor G FT_t) (FMor G (FT_t' o FT_h'))
     (FT_f FT_i0) (FT_f FT_j0).
  Proof.
  unfold Pullback_eq1 in |- *.
  (* *) apply Trans with (FT_f FT_j0 o FMor G FT_t' o FMor G FT_h').
  (* *) apply Trans with ((FT_f FT_j0 o FMor G FT_t') o FMor G FT_h').
  (* *) apply Trans with h.
  apply Sym; apply (Prf_SSC2_law (s x) h).
  (* *) apply Trans with (FT_tau_d o FMor G FT_h').
  apply Sym; exact H.
  apply Comp_r.
  apply (Prf_SSC2_law (s x) FT_tau_d).
  apply Ass1.
  apply Comp_l.
  apply FComp1.
  Qed.

  (* donc E! k : x -> G(b), par universalite' de FT_GP *)

  Definition FT_k : x --> G FT_b := Pb1_diese FT_GP FT_diag1.

  Definition FT_m0 := SSC2_i (s x) FT_k.

  Definition FT_t'' : FT_a FT_m0 --> FT_b := SSC2_t (s x) FT_k.

  (* Revenons au diagramme P *)

  (* t'' o p est une fleche de m0 -> FT_i0 dans (x|G)I *)

  Lemma FT_eq1 :
   Com_law (axf:=Build_Com_ob (FT_f FT_m0)) (bxg:=Build_Com_ob (FT_f FT_i0))
     (FT_t'' o FT_p).
  Proof.
  unfold Com_law in |- *; simpl in |- *.
  (* *) apply Trans with (FT_f FT_m0 o FMor G FT_t'' o FMor G FT_p).
  (* *) apply Trans with ((FT_f FT_m0 o FMor G FT_t'') o FMor G FT_p).
  (* *) apply Trans with (FT_k o FMor G FT_p).
  apply (Prf_pb1_law2 FT_GP FT_diag1).
  apply Comp_r; apply (Prf_SSC2_law (s x) FT_k).
  apply Ass1.
  apply Comp_l; apply FComp1.
  Qed.

  Canonical Structure FT_c1 := Build_Com_arrow FT_eq1.

  (* t'' o q est une fleche de FT_m0 -> FT_i0 dans (x|G)I *)

  Lemma FT_eq2 :
   Com_law (axf:=Build_Com_ob (FT_f FT_m0)) (bxg:=Build_Com_ob (FT_f FT_j0))
     (FT_t'' o FT_q).
  Proof.
  unfold Com_law in |- *.
  (* *) apply Trans with (FT_f FT_m0 o FMor G FT_t'' o FMor G FT_q).
  (* *) apply Trans with ((FT_f FT_m0 o FMor G FT_t'') o FMor G FT_q).
  (* *) apply Trans with (FT_k o FMor G FT_q).
  apply (Prf_pb1_law3 FT_GP FT_diag1).
  apply Comp_r; apply (Prf_SSC2_law (s x) FT_k).
  apply Ass1.
  apply Comp_l; apply FComp1.
  Qed.

  Canonical Structure FT_c2 := Build_Com_arrow FT_eq2.

  (* Diagramme 2 commute *)

  Lemma FT_diag2 : FT_Apeps FT_i0 =_S (FT_Apeps FT_m0 o FT_t'') o FT_p.
  Proof.
  (* *) apply Trans with (FT_Apeps FT_m0 o FT_t'' o FT_p).
  apply (Eq_cone FT_eps FT_c1).
  apply Ass.
  Qed.

  (* Diagramme 3 commute *)

  Lemma FT_diag3 : FT_Apeps FT_j0 =_S (FT_Apeps FT_m0 o FT_t'') o FT_q.
  Proof.
  (* *) apply Trans with (FT_Apeps FT_m0 o FT_t'' o FT_q).
  apply (Eq_cone FT_eps FT_c2).
  apply Ass.
  Qed.

  (* le grand diagramme commute : FT_eps(i) o FT_t = FT_eps(j) o FT_t' o h#' *)

  Lemma FT_diag4 : FT_Apeps FT_i0 o FT_t =_S FT_Apeps FT_j0 o FT_t' o FT_h'.
  Proof.
  (* *) apply Trans with (((FT_Apeps FT_m0 o FT_t'') o FT_p) o FT_t).
  apply Comp_r; apply FT_diag2.
  (* *) apply Trans with (((FT_Apeps FT_m0 o FT_t'') o FT_q) o FT_t' o FT_h').
  (* *) apply Trans with ((FT_Apeps FT_m0 o FT_t'') o FT_p o FT_t).
  apply Ass1.
  (* *) apply Trans with ((FT_Apeps FT_m0 o FT_t'') o FT_q o FT_t' o FT_h').
  apply Comp_l; apply (Prf_pb1_law1 FT_P).
  apply Ass.
  apply Comp_r; apply Sym; apply FT_diag3.
  Qed.

  (* qq i. t' o (pes i) est fleche de FT_j0 -> i dans (x|G)I *)

  Lemma FT_eq3 :
   forall i : FT_I,
   Com_law (axf:=Build_Com_ob (FT_f FT_j0)) (bxg:=Build_Com_ob (FT_f i))
     (FT_t' o FT_Apeps i).
  Proof.
  unfold Com_law in |- *; simpl in |- *; intro i.
  (* *) apply Trans with (FT_f FT_j0 o FMor G FT_t' o FMor G (FT_Apeps i)).
  (* *) apply Trans with ((FT_f FT_j0 o FMor G FT_t') o FMor G (FT_Apeps i)).
  (* *) apply Trans with (FT_tau_d o FMor G (FT_Apeps i)).
  apply (FT_eq_tau i).
  apply Comp_r.
  apply (Prf_SSC2_law (s x) FT_tau_d).
  apply Ass1.
  apply Comp_l; apply FComp1.
  Qed.

  Canonical Structure FT_c3 (i : FT_I) := Build_Com_arrow (FT_eq3 i).

  (* FT_eps(j) o t' = Id(LimEoQ) *)
  (* ide'e : par initialite' de FT_eps,
     FT_eps(j) o t' = FT_eps# = Id(LimEoQ) *)

  Lemma FT_eq4 : FT_Apeps FT_j0 o FT_t' =_S Id Lim_EoQ.
  Proof.
  (* *) apply Trans with (Lim_diese L_A FT_eps).
  apply (Prf_limit2 L_A).
  unfold Limit_eq in |- *; intro i.
  (* *) apply Trans with (FT_Apeps FT_j0 o FT_t' o FT_Apeps i).
  apply Ass1.
  apply Sym; apply (Eq_cone FT_eps (j:=i) (FT_c3 i)).
  (* *)
  apply Sym; apply (Prf_limit2 L_A).
  unfold Limit_eq in |- *; intro i.
  apply Idl.
  Qed.

  Lemma FT_h_diese_unique : FT_h' =_S FT_h_diese.
  Proof.
  unfold FT_h_diese in |- *.
  (* *) apply Trans with (Id Lim_EoQ o FT_h').
  apply Idl1.
  (* *) apply Trans with (FT_Apeps FT_j0 o FT_t' o FT_h').
  (* *) apply Trans with ((FT_Apeps FT_j0 o FT_t') o FT_h').
  apply Comp_r.
  apply Sym; apply FT_eq4.
  apply Ass1.
  apply Sym; apply FT_diag4.
  Qed.

  End uaxG_verif.

 Canonical Structure FT_UA :=
   Build_UA (Build_IsUA FT_UA_law1 FT_h_diese_unique).

 End uaxG.

Definition AFT1 : LeftAdj G := LeftAdjUA FT_UA.

End freyd_th_2.


(* This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at https://mozilla.org/MPL/2.0/. *)

(* Copyright (C) 2018–2020 ANSSI *)

From FreeSpec.Core Require Export Impure.

(** * Equivalence *)

(** Due to the definition of [impure] and [impure_bind], we could decide to rely
    on Coq built-in [eq] to reason about impure computations equivalence, but we
    would have to use the functional extensionality axiom to handle the
    continuation of the [request_then] constructor. In order to keep FreeSpec
    axiom-free, we rather provide a custom equivalence for [impure] terms. *)

(** ** Definition *)

(** The definition of [impure_equiv] is two-fold. *)

Inductive impure_eq {i α} : impure i α -> impure i α -> Prop  :=

(** - Two impure computations are equivalent if and only if they compute the
      exact same term (wrt. Coq [eq] function). *)

| local_eq (x : α) : impure_eq (local x) (local x)

(** - Two computations which consist in requesting the interpretation of an
      primitive and passing the result to a monadic continuation are equivalent
      if and only if they use the exact same primitive in the first place, and
      given any result the interpretation of this primitive may produce, their
      continuation returns equivalent impure computations. *)

| request_eq {β} (e : i β) (f g : β -> impure i α)
    (equ : function_eq impure_eq f g)
  : impure_eq (request_then e f) (request_then e g).

Infix "===" := impure_eq : impure_scope.

(** The definition of [impure_equiv] is very similar to [eq], with the exception
    of the treatment of the continuation. There is no much effort to put into
    proving this is indeed a proper equivalence. *)

#[program]
Instance impure_Equivalence i α : @Equivalence (impure i α) impure_eq := {}.

Next Obligation.
  intros p.
  induction p; constructor.
  intros x.
  apply H.
Qed.

Next Obligation.
  intros p q equ.
  induction equ; constructor.
  intros x.
  apply H.
Qed.

Next Obligation.
  intros p q r pq qr.
  revert p r pq qr.
  induction q; intros p r pq qr.
  + inversion pq; ssubst; inversion qr; ssubst.
    constructor.
  + inversion pq; ssubst; inversion qr; ssubst.
    constructor.
    intros x.
    cbv in H.
    now apply H with (β := x).
Qed.

(** ** Proper Instances *)

#[local]
Ltac change_request_then :=
  match goal with
  | |- (request_then ?e ?f === request_then ?e ?g)%impure =>
    let R := fresh "R" in
    assert (R: function_eq impure_eq f g); [ intros ?x | rewrite R; clear R ]
  end.

#[local]
Ltac change_impure_bind :=
  match goal with
  | |- (impure_bind ?e ?f === impure_bind ?e ?g)%impure =>
    let R := fresh "R" in
    assert (R: function_eq impure_eq f g); [ intros ?x | now rewrite R ]
  end.

#[program]
Instance request_then_Proper i α β
  : Proper (eq ==> function_eq impure_eq ==> impure_eq) (@request_then i α β).

Next Obligation.
  add_morphism_tactic.
  intros e f g equ.
  constructor.
  intros y.
  specialize (equ y).
  now rewrite equ.
Qed.

#[program]
Instance impure_bind_Proper i α β
  : Proper (impure_eq ==> function_eq impure_eq ==> impure_eq) (@impure_bind i α β).

Next Obligation.
  add_morphism_tactic.
  intros x y equ1 f g equ2.
  induction equ1.
  + cbn.
    now rewrite (equ2 x).
  + cbn.
    constructor.
    intros x.
    apply H.
Qed.

Instance impure_map_Proper i α β
  : Proper (function_eq eq ==> impure_eq ==> impure_eq) (@impure_map i α β).

Proof.
  add_morphism_tactic.
  intros f g equf p q equp.
  unfold impure_map.
  rewrite equp.
  change_impure_bind.
  now rewrite equf.
Qed.

#[program]
Instance impure_apply_Proper i α β
  : Proper (impure_eq ==> impure_eq ==> impure_eq) (@impure_apply i α β).

Next Obligation.
  add_morphism_tactic.
  intros p q equ1 r s equ2.
  unfold impure_apply.
  rewrite equ1.
  change_impure_bind.
  cbn.
  now rewrite equ2.
Qed.

(** * Equations *)

(** Monadic laws as defined in [ExtLib.Structures.MonadLaws] an related are
    expressed against [eq], which is too strong in the general case, and in
    [impure]’s case in particular. We could prove them using the functional
    extensionality axiom, but we’d rather provide an alternative implementaiton
    of these laws defined against [impure_eq] instead. *)

Lemma impure_bind_local {i α} (p : impure i α)
  : (impure_bind p (fun x => local x) === p)%impure.

Proof.
  induction p.
  + reflexivity.
  + cbn.
    change_request_then; [| reflexivity].
    now rewrite H.
Qed.

Lemma impure_bind_assoc {i α β δ}
  (p : impure i α) (f : α -> impure i β) (g : β -> impure i δ)
  : (impure_bind (impure_bind p f) g
     === impure_bind p (fun x => impure_bind (f x) g))%impure.

Proof.
  induction p; [reflexivity |].
  cbn.
  change_request_then; auto.
  reflexivity.
Qed.

Lemma bind_request_then_assoc `(e : i a) `(f : a -> impure i b) `(g : b -> impure i c)
  : request_then e f >>= g = request_then e (fun x => f x >>= g).

Proof.
  reflexivity.
Qed.


Require Import Refinement.
Require Import While.
Require Import Bool.
Require Import Heap.
Import While.Language.
Import While.Semantics.

(* refineRefl equiv *)
Lemma stop {w} :
  isExecutable w ->
  { c : WhileL | (w ⊑ c) /\ isExecutable c }.
Proof.
  exists w; split; [apply refineRefl | assumption].
Defined.

Ltac stop := try apply stop; unfold isExecutable; try auto.

(* refineTrans equiv *)
Lemma step {SPEC} (R : WhileL) :
  SPEC ⊑ R ->
  {C : WhileL | ((R ⊑ C) /\ isExecutable C)} ->
  {C : WhileL | ((SPEC ⊑ C) /\ isExecutable C)}.
Proof.
  intros H1 H2.
  inversion H2 as [w [H3 H4]].
  exists w.
  split; try apply (refineTrans R); assumption.
Defined.

Lemma stepSplit {w1 w2} :
  {c : WhileL | (w1 ⊑ c) /\ isExecutable c} ->
  {c : WhileL | (w2 ⊑ c) /\ isExecutable c} ->
  {c : WhileL | ((w1 ; w2) ⊑ c) /\ isExecutable c}.
Proof.
  intros [c1 [H1 H2]] [c2 [H3 H4]].
  exists (c1 ; c2).
  split.
  apply refineSplit; assumption.
  simpl; split; assumption.
Defined.

Lemma stepSplitIf {w1 w2 cond} :
  {c : WhileL | (w1 ⊑ c) /\ isExecutable c} ->
  {c : WhileL | (w2 ⊑ c) /\ isExecutable c} ->
  {c : WhileL | (If cond w1 w2 ⊑ c) /\ isExecutable c}.
Proof.
  intros [c1 [H1 H2]] [c2 [H3 H4]].
  exists (If cond c1 c2).
  split.
  apply refineSplitIf; assumption.
  simpl; split; assumption.
Defined.

Lemma stepAssign {w} (id : Identifier) (exp : Expr)
  (h : forall (s : S) (pre : pre (semantics w) s), post (semantics w) s pre ((setIdent id (evalExpr exp s)) s)) (h' : pre (semantics w) ⊂ (fun h => M.In id h)) :
  { c : WhileL | (w ⊑ c) /\ isExecutable c}.
Proof.
  exists (Assign id exp).
  split.
  apply refineAssign; assumption.
  simpl; trivial.
Defined.

Lemma stepFollowAssign {P : Pow S} {Q} (id : Identifier) (expr : Expr)
(Q' : forall (s : S), P s -> Pow S) :
  let w  := Spec ([P,Q]) in
  let w' := Spec ([P,Q']) in
  (forall s pres s', Q' s pres s' -> prod (Q s pres (subst id expr s')) (M.In id s')) ->
  {c : WhileL | (w' ⊑ c) /\ isExecutable c } ->
  {c : WhileL | (w ⊑ c) /\ isExecutable c }.
Proof.
  intros w w' HQ [c [H2 H3]].
  apply refineFollowAssign in HQ.
  apply (step (w' ; id ::= expr)).
  assumption.
  apply stepSplit.
  exists c.
  simpl; split; [assumption | trivial].
  exists (id ::= expr).
  split.
  apply refineRefl.
  simpl.
  trivial.
Defined.

Lemma stepSeqPT {Pre Post} (Mid : Pow S) :
  (Spec ([Pre , (fun _ _ s' => Post s')]) ⊑
    (Spec ([Pre , (fun _ _ s' => Mid s')])) ; (Spec ([Mid , (fun _ _ s' => Post s')]))) ->
  { c : WhileL | (Spec ([Pre , (fun _ _ s' => Mid s')]) ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (Spec ([Mid , (fun _ _ s' => Post s')]) ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (Spec ([Pre , (fun _ _ s' => Post s')]) ⊑ c) /\ isExecutable c }.
Proof.
  intros H1 [c1 [H2 H3]] [c2 [H4 H5]].
  apply (step (Spec ([Pre, fun (s : S) (_ : Pre s) (s' : S) => Mid s']);
               Spec ([Mid, fun (s : S) (_ : Mid s) (s' : S) => Post s']))).
  assumption.
  exists (c1 ; c2).
  split.
  apply refineSplit; assumption.
  simpl; split; assumption.
Defined.

Lemma stepIf (cond : BExpr) (pt : PT) :
  let branchPre (P : S -> Prop) := fun s => prod (pre pt s) (P s) in
  let thenBranch := Spec ([branchPre (fun s => Is_true (evalBExpr cond s)),
                           fun s pre s' => post pt s (fst pre) s' ]) in
  let elseBranch := Spec ([branchPre (fun s => Is_false (evalBExpr cond s)),
                           fun s pre s' => post pt s (fst pre) s' ]) in
  { c : WhileL | (thenBranch ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (elseBranch ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (Spec pt ⊑ c) /\ isExecutable c }.
Proof.
  intros branchPre thenBranch elseBranch [cThen [H1 H2]] [cElse [H3 H4]].
  exists (If cond cThen cElse).
  split.
  apply (refineTrans (If cond thenBranch elseBranch)).
  apply refineIf.
  apply refineSplitIf; assumption.
  simpl; split; assumption.
Defined.

Lemma stepBody {inv cond bodyL} :
  { c : WhileL | (bodyL ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (While inv cond bodyL ⊑ c) /\ isExecutable c }.
Proof.
  intros [c [H2 H3]].
  exists (While inv cond c).
  split.
  apply refineBody with (inv := inv) (cond := cond) in H2; assumption.
  simpl; assumption.
Defined.

Lemma stepWhile {inv Q} (cond : BExpr) :
  let pt := [inv , fun _ _ s' => inv s' /\ Q s'] in
  let body := [fun s => inv s /\ Is_true (evalBExpr cond s), (fun _ _ s => inv s)] in
  (forall s, Is_false (evalBExpr cond s) -> Q s) ->
  { c : WhileL | (Spec body ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (Spec pt ⊑ c) /\ isExecutable c }.
Proof.
  intros pt body H1 [c [H2 H3]].
  apply (step (While inv cond (Spec body))).
  apply refineWhile; assumption.
  apply stepBody.
  exists c; split; assumption.
Defined.

Lemma stepStrengthenPost {P : Pow S} {Q2} (Q1 : forall s, P s -> Pow S) :
  (forall (s : S) (p : P s), Q1 s p ⊂ Q2 s p) ->
  { c : WhileL | (Spec ([P , Q1]) ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (Spec ([P , Q2]) ⊑ c) /\ isExecutable c }.
Proof.
  intros H1 [c [H2 H3]].
  exists c.
  split; [ | assumption].
  apply (refineTrans (Spec ([P , Q1]))); [ | assumption].
  apply strengthenPost; assumption.
Defined.

Lemma stepWeakenPre {P1} {Q} (P2 : Pow S) (f : P1 ⊂ P2) :
  let Q'  := (fun s _ => Q s) in
  let Q'' := (fun s _ => Q s) in
  { c : WhileL | (Spec ([ P2 , Q'' ]) ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (Spec ([ P1 , Q' ]) ⊑ c) /\
                 isExecutable c }.
Proof.
  intros Q' Q'' [c [H1 H2]].
  exists c.
  split; [ | assumption ].
  apply (refineTrans (Spec ([ P2 , Q'' ]))); [ | assumption ].
  unfold Q',Q''; apply weakenPre; exact f.
Defined.

Lemma stepSeqAssocL : forall (w1 w2 w3 : WhileL),
  { c : WhileL | ((w1 ; w2) ; w3 ⊑ c) /\ isExecutable c } ->
  { c : WhileL | (w1 ; w2 ; w3 ⊑ c) /\ isExecutable c }.
Proof.
  intros w1 w2 w3 [c [H1 H2]].
  exists c.
  split; [ | assumption].
  apply (refineTrans ((w1; w2); w3)); [ | assumption ].
  apply refineSeqAssocL; apply refineRefl.
Defined.

Lemma stepSeqAssocR : forall (w1 w2 w3 : WhileL),
  { c : WhileL | (w1 ; w2 ; w3 ⊑ c) /\ isExecutable c } ->
  { c : WhileL | ((w1 ; w2) ; w3 ⊑ c) /\ isExecutable c }.
Proof.
  intros w1 w2 w3 [c [H1 H2]].
  exists c.
  split; [ | assumption].
  apply (refineTrans (w1; w2; w3)); [ | assumption ].
  apply refineSeqAssocR; apply refineRefl.
Defined.