(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of
   the License, or (at your option) any later version.
*)

Require Import Tacs.
Require Import List.
Require Import ZArith.
Require Export Psatz.
Require Coqlib.
Require Import Bits.
Export Word.

Local Open Scope Z_scope.

(** * Data structures *)
Require Coq.Sets.Ensembles.
Definition Int32Ensemble := Ensembles.Ensemble int32.
Definition w32add := @Word.add 31.
Definition w32sub := @Word.sub 31.
Definition w32neg := @Word.neg 31.
Notation w32modulus := (modulus 31).

(** * Abbreviations *)
Infix "+32" := w32add (at level 50, left associativity).
Notation "i +32_z z" := (i +32 (repr z))
  (at level 50, left associativity).
Notation "i +32_p p" := (i +32 (repr (Zpos p)))
  (at level 50, left associativity).
Notation "i +32_n n" := (i +32 (repr (Z_of_nat n)))
  (at level 50, left associativity).

Infix "-32" := w32sub (at level 50, left associativity).
Notation "i -32_z z" := (i -32 (repr z))
  (at level 50, left associativity).
Notation "i -32_p p" := (i -32 (repr (Zpos p)))
  (at level 50, left associativity).
Notation "i -32_n n" := (i -32 (repr (Z_of_nat n)))
  (at level 50, left associativity).

Notation "-32" := w32neg (at level 35, right associativity).

Notation int32_zero := (@Word.zero 31).
(*Notation int32_max := (@repr 31 (Word.max_unsigned 31))*)
Notation int32_max := (@Word.mone 31).
Notation int32_of_nat n := (@repr 31 (Z_of_nat n)).

Definition int32_ltu_bool := @Word.ltu 31.
Definition int32_eq_bool := @Word.eq 31.
Definition int32_lequ_bool := @Word.lequ 31.
Definition int32_gtu_bool i1 i2 := (int32_ltu_bool i2 i1).
Definition int32_gequ_bool i1 i2 := (int32_lequ_bool i2 i1).

Notation "i1 =32 i2" := (int32_eq_bool i1 i2 = true) (at level 70).
Notation "i1 <>32 i2" := (int32_eq_bool i1 i2 = false) (at level 70).
Notation "i1 <32 i2" := (int32_ltu_bool i1 i2 = true) (at level 70).
Notation "i1 <=32 i2" := (int32_lequ_bool i1 i2 = true) (at level 70).
Notation "i1 >32 i2" := (int32_gtu_bool i1 i2 = true) (at level 70).
Notation "i1 >=32 i2" := (int32_gequ_bool i1 i2 = true) (at level 70).

(** * Basic lemmas *)

Lemma add32_zero_r : forall i, i +32_n 0 = i.
Proof. simpl. apply add_zero. Qed.

Lemma int32_modulus_constant:
  w32modulus = 4294967296.
Proof. unfold modulus. unfold Word.wordsize.
  trivial.
Qed.

Lemma int32_eq_rewrite :
  forall i1 i2, i1 = i2 -> i1 =32 i2.
Proof. apply int_eq_true_iff2. Qed.

Lemma int32_neq_rewrite :
  forall i1 i2, i1 <> i2 -> i1 <>32 i2.
Proof. apply int_eq_false_iff2. Qed.

Lemma int32_minus_rewrite : forall x y,
  unsigned x >= unsigned y -> unsigned (x -32 y) = unsigned x - unsigned y.
Proof. intros. unfold w32sub, sub. rewrite unsigned_repr2. trivial.
  generalize (unsigned_range x), (unsigned_range y). lia.
Qed.

Remark Zmod_plus_eq_self : forall a b c, (a + b) mod c = a mod c -> b mod c = 0.
Proof. intros.
  assert (b = (a+b-a)) as H2 by ring.
  rewrite H2. rewrite Zminus_mod. rewrite H. rewrite Zminus_diag.
  apply Zmod_0_l.
Qed.

Lemma int32_plus_eq_zero : forall x y, x = x +32 y -> y = int32_zero.
Proof. intros x y Hc.
  destruct x as [xv Hx]. destruct y as [yv Hy].
  unfold Word.add, repr in Hc. simpl in Hc.
  injection Hc. intro H4.
  apply mkint_eq.
  assert (xv = xv mod w32modulus) as H6.
    apply eq_sym. apply Zmod_small. assumption.
  rewrite H6 in H4 at 1.
  apply eq_sym in H4. apply Zmod_plus_eq_self in H4.
  rewrite Zmod_small in H4 by assumption. rewrite H4.
  rewrite Zmod_0_l. trivial.
Qed.

(** ** Tactics for int32 *)

(** Convert operations on int32 to operations on Z *)

(* converting x=y to unsigned x = unsigned y, when x and y are of type int32 *)
Ltac elim_int32_eq :=
  repeat match goal with
    | [H: ?X = ?Y |- _] =>
      match type of X with
        | wint 31 => assert (unsigned X = unsigned Y) by congruence; clear H
        | _ => idtac
      end
  end.

Ltac int32_to_Z_tac :=
  unfold int32_gtu_bool, int32_gequ_bool,
    int32_lequ_bool, int32_ltu_bool, int32_eq_bool in *;
  autorewrite with int_to_Z in *;
  elim_int32_eq.

(** convert nat to Z *)
Hint Rewrite inj_plus inj_mult : nat_to_Z.
Hint Rewrite inj_minus1 using omega : nat_to_Z.
Hint Rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P : nat_to_Z.

Lemma Z_of_nat_0 : Z_of_nat 0%nat = 0. trivial. Qed.
Lemma Z_of_nat_1 : Z_of_nat 1%nat = 1. trivial. Qed.
Hint Rewrite Z_of_nat_0 Z_of_nat_1 : nat_to_Z.

Lemma inj_S2 : forall n, (Z_of_nat (S n) = Z_of_nat n + 1).
Proof. intros. apply inj_S. Qed.
Hint Rewrite inj_S2 : nat_to_Z.

Hint Rewrite inj_Zabs_nat : nat_to_Z.
Hint Rewrite Zabs_eq using lia : nat_to_Z.

(* Converting hypothesis about nats to Z:
     * n1 = n2 ===> Z_of_nat n1 = Z_of_nat n2
     * n1 > n2 ===> Z_of_nat n1 > Z_of_nat n2
     * ...
   This would not be necessary if we used omega instead of lia.
   Since lia cannot mix facts of Z and nat, we have to
   convert every equality and inquality between nat to Z;
   we also have to add hypothesis (Z_of_nat n >=0) for every
   nat n.
*)
Ltac nat_hyp_to_Z_tac :=
  repeat match goal with
           | [H : ?X = ?Y |- _] =>
             match type of X with
               | nat => apply inj_eq in H
               | _ => fail 1
             end
           | [H: le ?X ?Y |- _] =>  apply inj_le in H
           | [H: Peano.gt ?X ?Y |- _] =>  apply inj_gt in H
           | [H: ge ?X ?Y |- _] =>  apply inj_ge in H
           | [H: Peano.lt ?X ?Y |- _] =>  apply inj_lt in H
           | [n: nat |- _] => extend (Zle_0_nat n)
         end.

(* need to repeat autorewrite below because rewritng rules such as inj_minus1 might
   depend on the results of other rewriting rules so that omega will succeed *)
Ltac nat_to_Z_tac :=  nat_hyp_to_Z_tac; repeat autorewrite with nat_to_Z in *.
Ltac nat_to_Z_in_goal :=  autorewrite with nat_to_Z.
Ltac nat_to_Z_in H :=  autorewrite with nat_to_Z in H.

(** convert Z to nat *)
Hint Rewrite <- inj_plus inj_mult: Z_to_nat.
Hint Rewrite <- inj_minus1 using omega : Z_to_nat.
Hint Rewrite <- Z_of_nat_0 Z_of_nat_1 : Z_to_nat.

Ltac Z_to_nat_in_goal := autorewrite with Z_to_nat.
Ltac Z_to_nat_in H := autorewrite with Z_to_nat in H.

(** * Definition and properties of noOverflow *)
Definition addZ_list (l:list int32) : Z :=
  List.fold_right (fun (a:int32) (z:Z) => unsigned a + z) 0 l.

(** A semantic definition that adding a list of int32s does not overflow *)
Definition noOverflow (l:list int32) : Prop := addZ_list l < w32modulus.

Ltac noOverflow_simpl :=
  unfold noOverflow; cbv [addZ_list List.fold_right].
Ltac noOverflow_simpl_in H :=
  unfold noOverflow in H; cbv [addZ_list List.fold_right] in H.

(** Check a +32 b does not overflow; it is equivalent to a + b < 2^32
    and also equivalent to a +32 b = a + b; this formulation is easy to
    convert to checks in real programs. *)
Definition checkNoOverflow (a b:int32) : bool :=
  int32_lequ_bool a (a +32 b).

(** ** Properties of noOverflow *)
Lemma checkNoOverflow_equiv_noOverflow : forall a b,
  checkNoOverflow a b = true <-> noOverflow (a :: b :: nil).
Proof. intros; generalize (unsigned_range a), (unsigned_range b);
  intros Ha Hb; unfold checkNoOverflow, noOverflow; split.
  intros. int32_to_Z_tac. simpl. rewrite Zplus_0_r.
    apply Znot_ge_lt; intro Hc.
    unfold "+32", repr in H. simpl in H.
    assert ((unsigned a + unsigned b) mod w32modulus =
              unsigned a + unsigned b - w32modulus) as H5.
      apply Coqlib.Zmod_unique with (a:=1) ; lia.
    rewrite H5 in H. lia.
  intros. simpl in H. rewrite Zplus_0_r in H.
    int32_to_Z_tac. unfold "+32", repr. simpl.
    assert (0 <= unsigned a + unsigned b < w32modulus) by lia.
    rewrite (Zmod_small _ _ H0). lia.
Qed.

Lemma noOverflow_2_iff : forall a b,
  noOverflow (a::b::nil) <-> unsigned (a +32 b) = unsigned a + unsigned b.
Proof. intros; generalize (unsigned_range a), (unsigned_range b);
  intros Ha Hb; unfold noOverflow; split; unfold "+32", repr; simpl.
  intros. apply Zmod_small. simpl in H.
    lia.
  intros.
    assert (0 <= unsigned a + unsigned b < w32modulus).
      rewrite <- H; apply Z_mod_lt. apply Word.modulus_pos.
    lia.
Qed.

Lemma int32_add_rewrite : forall (a b:int32),
  unsigned a + unsigned b < w32modulus
    -> unsigned (a +32 b) = unsigned a + unsigned b.
Proof. intros. unfold "+32", repr. simpl.
  generalize (unsigned_range a) (unsigned_range b); intros.
  rewrite Zmod_small by lia. trivial.
Qed.

(** ** Tactics for noOverflow *)

(** Eliminate checkNoOverflow *)
Ltac checkNoOverflow_elim :=
  repeat match goal with
           | [H: checkNoOverflow _ _ = true |- _] =>
             apply checkNoOverflow_equiv_noOverflow in H
           | [ |- checkNoOverflow _ _ = true] =>
             apply checkNoOverflow_equiv_noOverflow
         end.

(* For any occurence of "unsigned x" in the context, add the
   assumption (0 <= unsigned x < 2^32)*)
Ltac add_unsigned_rng_tac :=
  repeat match goal with
           | [H:context[unsigned ?X] |- _] =>
             extend (unsigned_range X)
         end.

(* converting everything to Z so that lia can be used. *)

Require RTL.

Ltac pos_to_Z_tac := autorewrite with pos_to_Z_db in *.

Hint Rewrite Zpos_plus_distr : pos_to_Z_db.

Ltac all_to_Z_tac :=
  unfold noOverflow in *; cbv [addZ_list List.fold_right] in *;
  int32_to_Z_tac; add_unsigned_rng_tac; nat_to_Z_tac; pos_to_Z_tac;
  unfold RTL.size32 in *.

Ltac int32_simplify := all_to_Z_tac; repeat autorewrite with int32_simpl_db in *.
Ltac int32_prover := int32_simplify; lia.

Ltac int32_simplify_in_goal :=
  nat_to_Z_in_goal; autorewrite with int32_simpl_db.
Ltac int32_simplify_in H :=
  nat_to_Z_in H; autorewrite with int32_simpl_db in H.

(** A rewrite tactic that
    (1) rewrites to (unsigned a + unsigned b) when
        (unsigned a + unsigned b < 2^32 holds
    (3) rewrites unsigned (repr z) to z when 0 <= z < 2^32 *)
Hint Rewrite int32_add_rewrite using (lia || (int32_simplify_in_goal; lia))
  : int32_simpl_db.
Hint Rewrite int32_minus_rewrite using lia : int32_simpl_db.
Hint Rewrite Word.unsigned_repr2 using lia : int32_simpl_db.

(** ** More lemmas about noOverflow *)
Lemma checkNoOverflow_3_sound : forall (a b c:int32),
  checkNoOverflow a b = true -> checkNoOverflow (a +32 b) c = true
    -> noOverflow (a::b::c::nil).
Proof. intros. checkNoOverflow_elim. int32_prover. Qed.

(** * addrRegion *)

Definition addrRegion (start limit:int32):Int32Ensemble :=
  fun x:int32 => exists i:int32, x = start +32 i /\ i <=32 limit.

Lemma addrRegion_start_in : forall start limit,
  Ensembles.In _ (addrRegion start limit) start.
Proof. autounfold with sets. intros.
  unfold addrRegion.
  exists int32_zero.
  split. rewrite add32_zero_r. trivial.
  apply Word.int_lequ_zero.
Qed.

(** * disjointRegions *)
(** Check region [start1, start1+limit1] is disjoint from
    [start2, start2+limit2]; For simplicity, neither region can wrap
    around the 32-bit address space. *)
Definition disjointRegions (start1 limit1 start2 limit2:int32) : bool :=
  (int32_ltu_bool (start1 +32 limit1) start2 ||
   int32_ltu_bool (start2 +32 limit2) start1)%bool.

Lemma disjointRegions_sound :
  forall (s1 l1 s2 l2:int32),
    checkNoOverflow s1 l1 = true
      -> checkNoOverflow s2 l2 = true
      -> disjointRegions s1 l1 s2 l2 = true
      -> Ensembles.Disjoint _ (addrRegion s1 l1) (addrRegion s2 l2).
Proof. intros. split; intros. autounfold with sets. intro Hc.
  destruct Hc as [x [i1 [H10 H11]] [i2 [H12 H13]]].
  unfold disjointRegions in H1.
  checkNoOverflow_elim.
  rewrite H10 in H12; clear H10.
  bool_elim_tac; int32_prover.
Qed.

(** * Some properties about ensembles *)
(* not sure where to put these lemmas *)
Lemma included_disjoint : forall A r1 r2 r3,
  Ensembles.Included A r1 r2 -> Ensembles.Disjoint A r2 r3
    -> Ensembles.Disjoint A r1 r3.
Proof. intros. destruct H0. split.
  autounfold with sets in *. intros. intro Hc.
  apply (H0 x).
  destruct Hc. split; auto with sets.
Qed.

Lemma included_trans : forall A r1 r2 r3,
  Ensembles.Included A r1 r2 -> Ensembles.Included A r2 r3
    -> Ensembles.Included A r1 r3.
Proof. auto with sets. Qed.


Require Import LogicMain.
Import ListNotations.

Obligation Tactic := congruence.

Inductive modelPortsType :=
	A | Y | B | X | I | J  | L | K | M | N | C.
Program Instance modelPortsEqDec : EqDec modelPortsType eq :=
	{equiv_dec x y :=
		 match x, y with
		| A , A => in_left
		| A , Y => in_right
		| A , B => in_right
		| A , X => in_right
		| A , I => in_right
		| A , J  => in_right
		| A , L => in_right
		| A , K => in_right
		| A , M => in_right
		| A , N => in_right
		| A , C => in_right
		| Y , A => in_right
		| Y , Y => in_left
		| Y , B => in_right
		| Y , X => in_right
		| Y , I => in_right
		| Y , J  => in_right
		| Y , L => in_right
		| Y , K => in_right
		| Y , M => in_right
		| Y , N => in_right
		| Y , C => in_right
		| B , A => in_right
		| B , Y => in_right
		| B , B => in_left
		| B , X => in_right
		| B , I => in_right
		| B , J  => in_right
		| B , L => in_right
		| B , K => in_right
		| B , M => in_right
		| B , N => in_right
		| B , C => in_right
		| X , A => in_right
		| X , Y => in_right
		| X , B => in_right
		| X , X => in_left
		| X , I => in_right
		| X , J  => in_right
		| X , L => in_right
		| X , K => in_right
		| X , M => in_right
		| X , N => in_right
		| X , C => in_right
		| I , A => in_right
		| I , Y => in_right
		| I , B => in_right
		| I , X => in_right
		| I , I => in_left
		| I , J  => in_right
		| I , L => in_right
		| I , K => in_right
		| I , M => in_right
		| I , N => in_right
		| I , C => in_right
		| J  , A => in_right
		| J  , Y => in_right
		| J  , B => in_right
		| J  , X => in_right
		| J  , I => in_right
		| J  , J  => in_left
		| J  , L => in_right
		| J  , K => in_right
		| J  , M => in_right
		| J  , N => in_right
		| J  , C => in_right
		| L , A => in_right
		| L , Y => in_right
		| L , B => in_right
		| L , X => in_right
		| L , I => in_right
		| L , J  => in_right
		| L , L => in_left
		| L , K => in_right
		| L , M => in_right
		| L , N => in_right
		| L , C => in_right
		| K , A => in_right
		| K , Y => in_right
		| K , B => in_right
		| K , X => in_right
		| K , I => in_right
		| K , J  => in_right
		| K , L => in_right
		| K , K => in_left
		| K , M => in_right
		| K , N => in_right
		| K , C => in_right
		| M , A => in_right
		| M , Y => in_right
		| M , B => in_right
		| M , X => in_right
		| M , I => in_right
		| M , J  => in_right
		| M , L => in_right
		| M , K => in_right
		| M , M => in_left
		| M , N => in_right
		| M , C => in_right
		| N , A => in_right
		| N , Y => in_right
		| N , B => in_right
		| N , X => in_right
		| N , I => in_right
		| N , J  => in_right
		| N , L => in_right
		| N , K => in_right
		| N , M => in_right
		| N , N => in_left
		| N , C => in_right
		| C , A => in_right
		| C , Y => in_right
		| C , B => in_right
		| C , X => in_right
		| C , I => in_right
		| C , J  => in_right
		| C , L => in_right
		| C , K => in_right
		| C , M => in_right
		| C , N => in_right
		| C , C => in_left
	end
	}.
Close Scope Q_scope.

Program Instance dataProp_eqdec3 {name data : Type} `{EqDec name eq} `{EqDec data eq} : EqDec (dataProp name data) eq :=
    {
      equiv_dec x y :=
        match x, y with
          | dataInPorts a x, dataInPorts b y => if a == b then if x == y then in_left else in_right else in_right
          | dataInFifo a x b, dataInFifo c y d => if a == c then if b == d then if x == y then in_left else in_right else in_right else in_right
          | dataBothPorts _ a b, dataBothPorts _ c d => if a == c then if b == d then in_left else in_right else in_right
          | dataInPorts a x , dataInFifo b y c => in_right
          | dataInPorts a x , dataBothPorts _ b y => in_right
          | dataInFifo a x b , dataInPorts c y => in_right
          | dataInFifo a x b , dataBothPorts _ c y => in_right
          | dataBothPorts _ a b , dataInPorts c y => in_right
          | dataBothPorts _ a b , dataInFifo c y d  => in_right
        end
     }.

Definition swap01 (n:nat) : nat :=
  match n with
  | 0 => 1
  | 1 => 0
  | Datatypes.S o => (Datatypes.S o)
  end.

Definition SmartCitiesModelProg := [flowMerger nat A B Y; flowSync nat Y X; flowSync nat X I; flowSync nat X J;
    flowTransform swap01 J L; flowSync nat I K; flowSync nat L M; flowFifo nat K N; flowMerger nat M N C].

Definition t := [dataPorts A 1].

Definition piStar := star (reoProg SmartCitiesModelProg []).

Definition SmartCitiesEx1 := constructModel [A ; Y ; B ; X ; I ; J ; L ; K ; M ; N ; C] [t]
  (imp ((((proposition (dataInPorts A 1)))))
        (and (box t piStar (((proposition (dataInPorts C 0)))))
             (box t piStar (((proposition (dataInPorts C 1))))))) (length(SmartCitiesModelProg) * 3).

Eval compute in SmartCitiesEx1.

Eval compute in singleFormulaVerify SmartCitiesEx1
        (imp ((((proposition (dataInPorts A 1)))))
        (and (box t piStar (((proposition (dataInPorts C 0)))))
             (box t piStar (((proposition (dataInPorts C 1))))))) t.


Definition Rel (A:Type) := A -> A -> Prop.

Inductive trans {A} (red: Rel A) : Rel A :=
| singl: forall a b,  red a b -> trans red a b
| transit: forall b a c,  red a b -> trans red b c -> trans red a c
.

Inductive refltrans {A} (red: Rel A) : Rel A :=
| refl: forall a, (refltrans red) a a
| rtrans: forall a b c, red a b -> refltrans red b c -> refltrans red a c
.

Lemma ttrans {A}: forall a b c (red: Rel A), refltrans red a b ->  refltrans red b c -> refltrans red a c.
Proof.
  Admitted.

Inductive refltrans' {A} (red: Rel A) : Rel A :=
| refl': forall a, (refltrans' red) a a
| rtrans': forall a b c, refltrans' red a b -> red b c -> refltrans' red a c
.

Variable A:Type.
Variable R : Rel A.
Notation "a --> b" := (R a b) (at level 60).
Notation "a -->* b" := ((refltrans R) a b) (at level 60).
Notation "a -->** b" := ((refltrans' R) a b) (at level 60).

Lemma strip_lemma: forall t t1 t2, t --> t1 /\ t -->* t2 -> exists t3, t1 -->* t3 /\ t2 -->* t3.
Proof.
  Admitted.

Theorem confl: forall t t1 t2, t -->* t1 /\ t -->* t2 -> exists t3, t1 -->* t3 /\ t2 -->* t3.
Proof.
  intros t t1 t2 H.
  destruct H as [H1 H2].
  generalize dependent t2.
  induction H1.
  - intros t2 H2.
    exists t2. split.
    + assumption.
    + apply refl.
  - intros t2 H2.
    assert (Hstrip: a --> b /\ a -->* t2 -> exists t3, b -->* t3 /\ t2 -->* t3).
    {
      apply strip_lemma.
    }
    assert (Hand: a --> b /\ a -->* t2).
    {
      split.
      - assumption.
      - assumption.
    }
    apply Hstrip in Hand.
    destruct Hand as [t3' [Hb Ht2]].
    apply IHrefltrans in Hb.
    destruct Hb  as[t3 [Hc Ht3']].
    exists t3. split.
    + assumption.
    + apply ttrans with t3'.
      * assumption.
      * assumption.
Qed.

Theorem confl': forall t t1 t2, t -->** t1 /\ t -->** t2 -> exists t3, t1 -->** t3 /\ t2 -->** t3.
Proof.
  Admitted.

Theorem id_p: forall P, P -> P.
Proof.
  intros P.
  intros P1.
  assumption.
Qed.

Lemma id_PP: forall P, (P -> P) -> (P -> P).
Proof.
  intros P p1 p2.
  assumption.
Qed.

Lemma imp_trans: forall P Q R, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P.
  intros Q.
  intros R.
  intros func1.
  intros func2.
  intros Papp.
  pose (Qapp := func1 Papp).
  pose (Rapp := func2 Qapp).
  assumption.
Qed.

Lemma imp_trans_ref: forall P Q R, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P.
  intros Q.
  intros R.
  intros func1.
  intros func2.
  intros Papp.
  refine (func2 _).
  refine (func1 _).
  assumption.
Qed.

Lemma imp_perm : forall P Q R, (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros P Q R.
  intros func1.
  intros Qapp.
  intros Papp.
  pose (QRapp := func1 Papp).
  pose (Rapp := QRapp Qapp).
  assumption.
Qed.

Lemma ignore_Q : forall P Q R, (P -> R) -> P -> Q -> R.
Proof.
  intros P Q R.
  intros func1.
  intros Papp.
  intros Qapp.
  pose (Rapp := func1 Papp).
  assumption.
Qed.

Lemma ignore_Q_without_parenthesis : forall P Q R, P -> R -> P -> Q -> R.
Proof.
  intros P Q R.
  intros Papp Rapp Papp2 Qapp1.
  assumption.
Qed.

Lemma delta_imp : forall P Q, (P -> P -> Q) -> P -> Q.
Proof.
  intros P Q.
  intros func1.
  intros Papp.
  pose (PQapp := func1 Papp).
  pose (Qapp := PQapp Papp).
  assumption.
Qed.

Lemma delta_impR : forall P Q, (P->Q)->(P->P->Q).
Proof.
  intros P Q.
  intros func1.
  intros Papp.
  intros Papp2.
  pose (Qapp := func1 Papp).
  assumption.
Qed.

Lemma diamond : forall P Q R T, (P->Q)->(P->R)->(Q->R->T)->P->T.
Proof.
  intros P Q R T.
  intros func1.
  intros func2.
  intros func3.
  intros Papp.
  pose (Qapp := func1 Papp).
  pose (Rapp := func2 Papp).
  pose (RTapp := func3 Qapp).
  pose (Tapp := RTapp Rapp).
  assumption.
Qed.

Lemma weak_peirce : forall P Q, ((((P->Q)->P)->P)->Q)->Q.
Proof.
  intros P Q.
  intros func1.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the static semantics of typing in the heap, pg 64.

*)

Set Implicit Arguments.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects Cyclone_LN_Tactics.
Require Export Cyclone_Test_Utilities.
Import ListNotations.
Open Scope env_scope.
Import LVPE.LibVarPathEnvNotations.

Function tgti u v p t p' t' :=
  gettype u v p t p' t'.

Lemma test_gettype_induction:
  forall u v p t p' t',
    gettype u v p t p' t' ->
    tgti    u v p t p' t'.
Proof.
  introv GT.
  induction GT.
Abort.

Example gettype_empty_test2:
  gettype udot varx nil tau nil tau.
Proof.
  auto.
Qed.

Example binding:
  forall (E F : Upsilon) x t,
    E &p x ~p t &p F = E &p (x ~p t) &p F.
Abort.

Example gettype_etype_test2:
  gettype ((varx, pdot) ~p cint &p udot) varx pdot
          (etype aliases k cint) (cons u_pe nil) cint.
Proof.
  applys~ gettype_etype;
  simpl_get.
  case_varpath*.
Qed.

Example gettype_left_test2:
  gettype udot varx nil (cross cint cint) (cons (i_pe zero_pe) nil) cint.
Proof.
  apply gettype_pair_zero.
  auto.
Qed.

Example gettype_right_test2:
  gettype udot varx nil (cross cint cint) (cons (i_pe one_pe) nil) cint.
Proof.
  auto.
Qed.


Require Import Reals Psatz Omega.
From Coq Require Export Sorted.
From iris.program_logic Require Export weakestpre prob_adequacy.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang adequacy.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac_auth auth gset.
From iris.heap_lang Require Import proofmode notation par spin_lock.
From mathcomp Require Import seq fintype.

From iris.tests.skiplist Require Import code misc.

From discprob.idxval Require Import pival
     pival_dist fin_ival_dist irrel_equiv pidist_pair extrema pidist_post_cond.
From discprob.idxval Require Import fin_ival_pair pidist_fin_singleton.

Lemma list_exist {A: Type} (l: list A) (P: A → Prop) (Hall: ∀ x, List.In x l → P x) :
  list { x : A |  P x }.
Proof.
  induction l as [| a l IHl].
  - exact [::].
  - refine (exist _ a _ :: (IHl _)).
    * apply Hall. by left.
    * intros; apply Hall. by right.
Defined.

Lemma list_exist_spec1 {A: Type} (l: list A) P H:
  map (proj1_sig) (list_exist l P H) = l.
Proof.
  induction l; rewrite //=.
  f_equal; eauto.
Qed.

Lemma list_In {A: Type} (l: list A) : list { x : A | List.In x l}.
Proof. apply (list_exist l); trivial. Defined.

Require ProofIrrelevance.

Definition select_from_list_P {A: Type} (a: A) (l: seq A) (P : A → Prop)
           (HP: ∀ x, List.In x (a :: l) → P x) :
  pidist { x : A | P x }.
  apply (@pidist_join {x : A | List.In x (a :: l) }).
  { exists a; by left. }
  { intros (x&Hin). refine (mret (exist _ x (HP _ Hin))). }
Defined.

Definition select_from_list {A: Type} (a: A) (l: seq A) : pidist A.
  apply (@pidist_join {x : A | List.In x (a :: l) }).
  { exists a; by left. }
  { intros (x&Hin). exact (mret x). }
Defined.

Lemma select_from_list_P_non_dep_eq {A: Type} (a : A) l P HP:
  eq_pidist (x ← select_from_list_P a l P HP; mret (`x))
            (select_from_list a l).
Proof.
  rewrite /select_from_list_P/select_from_list. setoid_rewrite pidist_join_bind.
  etransitivity.
  { eapply (pidist_join_ext _ ((a ↾ or_introl eq_refl)) _
                            (λ x, z ← mret (exist _ (proj1_sig x) (HP (proj1_sig x) (proj2_sig x)));
                             mret (`z))).
    intros (?&?). rewrite //=.
  }
  setoid_rewrite pidist_left_id => //=.
  eapply pidist_join_ext.
  intros (?&?) => //=.
Qed.

Definition select_from_list_dep {A: Type} (a: A) (l: seq A) : pidist { x : A | List.In x (a :: l) }.
  apply (select_from_list_P a l); trivial.
Defined.

Lemma select_from_list_dep_eq {A: Type} (a : A) l:
  eq_pidist (x ← select_from_list_dep a l; mret (`x))
            (select_from_list a l).
Proof. eapply select_from_list_P_non_dep_eq. Qed.

From Coq Require Import Program.Wf.

Lemma flip12: (0 <= 1 / 2)%R ∧ (1 / 2 <= 1)%R.
Proof. nra. Qed.

Import List seq.

(* Main pidist that we prove a coupling with; not structurally recursive
   (because you select any element from the list)
*)

Definition skiplist (add_list top_list bottom_list: list Z) :
  pidist (list Z * list Z).
Proof.
  refine (Fix (measure_wf lt_wf length) (fun _ => list Z → list Z → pidist (list Z * list Z))
              (fun (l: list Z) skiplist =>
                λ tl bl,
                match l as l' return (l = l' → pidist (list Z * list Z)) with
                | [::] => λ eq, mret (sort tl, sort bl)
                | (a :: l) =>
                  λ eq,
                  kchoice ← select_from_list_dep a l;
                  tl' ← pidist_plus (1/2) flip12 (mret tl) (mret (proj1_sig kchoice :: tl));
                  skiplist (remove Z_eq_dec (proj1_sig kchoice) (a :: l)) _ tl'
                           (proj1_sig kchoice :: bl)
                end (Init.Logic.eq_refl)) add_list top_list bottom_list).
  rewrite /MR eq.
  apply length_remove_lt. destruct kchoice; auto.
Defined.

Lemma skiplist_unfold_aux (l: list Z) tl bl:
  skiplist l tl bl =
    match l as l' return (l = l' → pidist (list Z * list Z)) with
    | [::] => λ eq, mret (sort tl, sort bl)
    | (a :: l) =>
      λ eq,
      kchoice ← select_from_list_dep a l;
      tl' ← pidist_plus (1/2) flip12 (mret tl) (mret (proj1_sig kchoice :: tl));
      skiplist (remove Z_eq_dec (proj1_sig kchoice) (a :: l)) tl'
               (proj1_sig kchoice :: bl)
    end (Init.Logic.eq_refl).
Proof. rewrite /skiplist pival_dist.easy_fix_eq; done. Qed.

Lemma skiplist_unfold l tl bl:
  skiplist l tl bl =
    match l with
    | [::] => mret (sort tl, sort bl)
    | (a :: l) =>
      kchoice ← select_from_list_dep a l;
      tl' ← pidist_plus (1/2) flip12 (mret tl) (mret (proj1_sig kchoice :: tl));
      skiplist (remove Z_eq_dec (proj1_sig kchoice) (a :: l)) tl'
               (proj1_sig kchoice :: bl)
    end.
Proof. rewrite skiplist_unfold_aux //=. destruct l; auto. Qed.

Lemma skiplist_unfold_non_dep l tl bl:
  eq_pidist (skiplist l tl bl)
            match l with
            | [::] => mret (sort tl, sort bl)
            | (a :: l) =>
              kchoice ← select_from_list a l;
                tl' ← pidist_plus (1/2) flip12 (mret tl) (mret (kchoice :: tl));
                skiplist (remove Z_eq_dec kchoice (a :: l)) tl'
                         (kchoice :: bl)
            end.
Proof.
  rewrite skiplist_unfold.
  destruct l.
  * reflexivity.
  * setoid_rewrite <-select_from_list_dep_eq.
    setoid_rewrite pidist_assoc.
    eapply pidist_bind_congr; first reflexivity.
    intros (x&Hin).
    rewrite pidist_left_id. reflexivity.
Qed.

Lemma select_from_list_perm_eq {A: Type} (a a' : A) l l':
  Permutation (a :: l) (a' :: l') →
  eq_pidist (select_from_list a l) (select_from_list a' l').
Proof.
  intros Hperm.
  split.
  - intros I ((x&Hinl)&Hin).
    exists I; split; auto.
    unshelve (eexists).
    { exists x.
      abstract (apply elem_of_list_In; rewrite -Hperm; apply elem_of_list_In; done).
    }
    rewrite //=.
  - intros I ((x&Hinl)&Hin).
    exists I; split; auto.
    unshelve (eexists).
    { exists x.
      abstract (apply elem_of_list_In; rewrite Hperm; apply elem_of_list_In; done).
    }
    rewrite //=.
Qed.

Lemma skiplist_perm_eq l tl bl l' tl' bl':
  Permutation l l' →
  Permutation tl tl' →
  Permutation bl bl' →
  eq_pidist (skiplist l tl bl) (skiplist l' tl' bl').
Proof.
  remember (length l) as n eqn:Heq.
  revert l Heq l' tl bl tl' bl'.
  induction n as [n IHn] using lt_wf_ind  => l Heq_length l' tl bl tl' bl' Hperm1 Hperm2 Hperm3.
  destruct l as [|a l].
  - apply Permutation.Permutation_nil in Hperm1. subst.
    rewrite ?skiplist_unfold //=.
    assert (sort tl = sort tl') as ->.
    { apply Sorted_Zle_uniq.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * rewrite -?Permuted_sort. done.
    }
    assert (sort bl = sort bl') as ->.
    { apply Sorted_Zle_uniq.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * rewrite -?Permuted_sort. done.
    }
    reflexivity.
  - destruct l' as [| a' l'].
    { exfalso. symmetry in Hperm1. apply Permutation.Permutation_nil in Hperm1. congruence. }
    apply pidist_coupling_eq.
    eapply pidist_coupling_ext.
    { rewrite skiplist_unfold_non_dep. reflexivity. }
    { rewrite skiplist_unfold_non_dep. reflexivity. }
    { reflexivity. }
    eapply (pidist_coupling_bind _ _ _ _ (λ x y, x = y ∧ List.In x (a :: l) ∧ List.In y (a :: l))).
    {
      unshelve (econstructor).
      { refine (x ← select_from_list_dep a l; mret _).
        destruct x as (x&Hin). exists (x, x); split_and! => //=. }
      * rewrite -select_from_list_dep_eq.
        setoid_rewrite pidist_assoc. apply pidist_bind_congr; first reflexivity.
        intros (?&?). setoid_rewrite pidist_left_id => //=.
      * rewrite -select_from_list_perm_eq; last eauto.
        rewrite -select_from_list_dep_eq.
        setoid_rewrite pidist_assoc. apply pidist_bind_congr; first reflexivity.
        intros (?&?). setoid_rewrite pidist_left_id => //=.
    }
    intros ?? (<-&?&?).
    apply pidist_coupling_eq_inv.
    setoid_rewrite pidist_plus_bind.
    apply pidist_plus_proper; setoid_rewrite pidist_left_id.
    * eapply IHn; eauto.
      ** rewrite Heq_length. apply length_remove_lt; auto.
      ** apply remove_perm_proper; eauto.
    * eapply IHn; eauto.
      ** rewrite Heq_length. apply length_remove_lt; auto.
      ** apply remove_perm_proper; eauto.
Qed.

Global Instance skiplist_perm_eq_Proper:
  Proper (Permutation ==> Permutation ==> Permutation ==> eq_pidist) skiplist.
Proof.
  intros ?? Hperm ?? Hperm' ?? Hperm''.
  eapply skiplist_perm_eq; eauto.
Qed.

Lemma select_from_list_hd {A: Type} (a: A) tl :
  le_pidist (mret a) (select_from_list a tl).
Proof.
  rewrite /select_from_list.
  intros I Hin. exists I; split; first reflexivity.
  exists (exist _ a (or_introl eq_refl)). done.
Qed.

Lemma skiplist_unfold_choice a l tl bl:
  ¬ (a ∈ l) →
  le_pidist
    (tl' ← pidist_plus (1/2) flip12 (mret tl) (mret (a :: tl));
       skiplist l tl' (a :: bl))
    (skiplist (a :: l) tl bl).
Proof.
  intros Hnin.
  rewrite skiplist_unfold_non_dep.
  transitivity
    (x ← mret a;
     tl' ← pidist_plus (1/2) flip12 (mret tl) (mret (x :: tl));
     skiplist l tl' (x :: bl)).
  { setoid_rewrite pidist_left_id. reflexivity. }
  apply pidist_bind_congr_le_supp.
  { apply select_from_list_hd. }
  { intros ? ?%In_psupport_mret_inv. subst.
    apply pidist_bind_congr_le; first reflexivity.
    intros.
    rewrite //= remove_not_in //=.
    destruct Z_eq_dec => //=.
  }
Qed.

(* We prove that the skiplist is equivalent to a singleton indexed valuation
   which simply adds the items in the list in the order they occur... the result is
   structurally recursive and much easier to reason about *)

Fixpoint single_skiplist (al tl bl: list Z) : ivdist (list Z * list Z) :=
  match al with
  | [::] => mret (sort tl, sort bl)
  | (a :: l) =>
    tl' ← ivdplus (1/2) flip12 (mret tl) (mret (a :: tl));
      single_skiplist l tl' (a :: bl)
  end.

Fixpoint single_skiplist_alt (al tl bl: list Z) : ivdist (list Z * list Z) :=
  match al with
  | [::] => mret (sort tl, sort bl)
  | (a :: l) =>
    hd ← ivdplus (1/2) flip12 (mret [::]) (mret [::a]);
    single_skiplist_alt l (hd ++ tl) (a :: bl)
  end.

Lemma single_skiplist_alt_equiv al tl bl:
  eq_ivd (single_skiplist al tl bl) (single_skiplist_alt al tl bl).
Proof.
  revert tl bl.
  induction al => tl bl.
  - rewrite //=.
  - apply ival_coupling_eq.
    rewrite /single_skiplist -/single_skiplist.
    rewrite /single_skiplist_alt -/single_skiplist_alt.
    apply ival_coupling_bind with (P := λ tl' hd, hd ++ tl = tl').
    { apply ival_coupling_plus.
      * apply ival_coupling_mret. rewrite //=.
      * apply ival_coupling_mret. rewrite //=.
    }
    intros x y ->.
    eapply ival_coupling_proper.
    { reflexivity. }
    { eapply IHal. }
    apply ival_coupling_refl.
Qed.

Lemma single_skiplist_alt_perm_aux l tl bl tl' bl':
  Permutation tl tl' →
  Permutation bl bl' →
  eq_ivd (single_skiplist_alt l tl bl) (single_skiplist_alt l tl' bl').
Proof.
  revert tl bl tl' bl'.
  induction l as [| a l] => tl bl tl' bl' Hperm2 Hperm3.
  - rewrite //=.
    assert (sort tl = sort tl') as ->.
    { apply Sorted_Zle_uniq.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * rewrite -?Permuted_sort. done.
    }
    assert (sort bl = sort bl') as ->.
    { apply Sorted_Zle_uniq.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * apply Sorted_Zorder_Zle, Sorted_sort_folded.
      * rewrite -?Permuted_sort. done.
    }
    reflexivity.
  - eapply ivd_bind_congr; first reflexivity.
    intros; eapply IHl; rewrite ?Hperm2 ?Hperm3 //=.
Qed.

Import monad.

Lemma single_skiplist_alt_perm l tl bl l' tl' bl':
  Permutation l l' →
  Permutation tl tl' →
  Permutation bl bl' →
  eq_ivd (single_skiplist_alt l tl bl) (single_skiplist_alt l' tl' bl').
Proof.
  intros Hperm1.
  revert tl bl tl' bl'.
  induction Hperm1 => tl bl tl' bl' Hperm2 Hperm3;
                        try eapply single_skiplist_alt_perm_aux; eauto.
  - apply ivd_bind_congr; first reflexivity.
    intros. eapply IHHperm1; rewrite ?Hperm2 ?Hperm3 //=.
  - rewrite {1}/single_skiplist_alt -/single_skiplist_alt.
    rewrite /eq_ivd. setoid_rewrite fin_ival.ival_bind_comm at 1.
    rewrite {2}/single_skiplist_alt -/single_skiplist_alt.
    eapply fin_ival.ival_bind_congr; first reflexivity.
    intros l1.
    eapply fin_ival.ival_bind_congr; first reflexivity.
    intros l2.
    apply single_skiplist_alt_perm_aux; rewrite ?Hperm2 ?Hperm3 //=; last by econstructor.
    rewrite ?app_cat.
    rewrite ?app_assoc (Permutation_app_comm l1) //=.
  - setoid_rewrite IHHperm1_1; eauto.
Qed.

Lemma single_skiplist_perm l tl bl l' tl' bl':
  Permutation l l' →
  Permutation tl tl' →
  Permutation bl bl' →
  eq_ivd (single_skiplist l tl bl) (single_skiplist l' tl' bl').
Proof.
  intros.
  setoid_rewrite single_skiplist_alt_equiv.
  apply single_skiplist_alt_perm; auto.
Qed.

Global Instance single_skiplist_Perm_proper:
  Proper (Permutation ==> Permutation ==> Permutation ==> eq_ivd) single_skiplist.
Proof.
  intros ?? Hperm1 ?? Hperm2 ?? Hperm3.
  apply single_skiplist_perm; eauto.
Qed.

Lemma skiplist_equiv_single l tl bl:
  NoDup l →
  eq_pidist (skiplist l tl bl) (singleton (single_skiplist l tl bl)).
Proof.
  remember (length l) as n eqn:Heq.
  revert l Heq tl bl.
  induction n as [n IHn] using lt_wf_ind  => l Heq tl bl HNoDup.
  destruct l as [| a l].
  - rewrite skiplist_unfold //= singleton_mret //=.
  - rewrite skiplist_unfold.
    rewrite -[a in eq_pidist _ a](pidist_left_id tt (λ _, singleton _)).
    apply pidist_coupling_eq.
    eapply (pidist_coupling_bind) with (P := λ x y, True).
    {  apply pidist_coupling_join.
       intros (x&Hin) => //=.
       apply pidist_coupling_mret => //=.
    }
    intros (a'&Hin) _ _.
    feed pose proof (in_split a' (a :: l)) as Hex; auto.
    apply ClassicalEpsilon.constructive_indefinite_description in Hex as (l1&Hex).
    apply ClassicalEpsilon.constructive_indefinite_description in Hex as (l2&Hex).
    assert (Permutation (a :: l) (a' :: (l1 ++ l2))) as Hperm.
    { rewrite Hex.
      rewrite Permutation_app_comm.
      rewrite -app_comm_cons.
      rewrite Permutation_app_comm.
      rewrite -?app_cat //=.
    }
    eapply pidist_coupling_ext.
    { reflexivity. }
    { setoid_rewrite Hperm. reflexivity. }
    { reflexivity. }
    apply pidist_coupling_eq_inv.
    rewrite /single_skiplist -/single_skiplist.
    setoid_rewrite singleton_bind.
    apply pidist_bind_congr.
    { rewrite singleton_plus ?singleton_mret //=. }
    intros l'.
    rewrite /proj1_sig.
    assert (Permutation (remove Z_eq_dec a' (a :: l)) (l1 ++ l2)) as ->.
    { rewrite remove_perm_proper; last eassumption.
      rewrite //=; destruct Z_eq_dec; last omega.
      rewrite remove_not_in; first reflexivity.
      rewrite Hperm in HNoDup * => HND.
      inversion HND; subst. rewrite elem_of_list_In; eauto.
    }
    eapply IHn; eauto.
    * rewrite Heq.
      rewrite (Permutation_length Hperm) => //=.
      omega.
    * rewrite Hperm in HNoDup *. inversion 1; subst; eauto.
Qed.


(**
Coq-Elpi によるタクティクの作成（その2）
=====================

@suharahiromichi

2023/01/01
*)

(**
定理証明系Coqには、Embeddable Lambda Prolog Interpreter (ELPI) によってタクティク（証明戦略）を
作成するためのパッケージ ``Coq-Elpi``が用意されています。

(その1)[1]で説明しなかった、いくつかのトピックスについて説明します。参考文献は[1]を参照してください。

この記事のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/tree/master/elpi/coq_elpi_tactic_sample_2.v
*)

From elpi Require Import elpi.

(**
# 証明エンジン　(``coq.ltac.collect-goals``)

[1]では、solveの第1引数の``goal Ctx Trigger Type Proof Args``の
Triggerに値を代入することで証明が進み、そここにHole(``_``)があると、
それが新たな（サブ）ゴールになると説明しました。

これはCoqの証明エンジンの機能ですが、それを明示的に呼び出して
処理をおこなうのは、組込述語``coq.ltac.collect-goals``です(注1)。
[2]では、Triggerへの代入と、これの呼び出しをまとめて``refine``として定義されています。
（変数名を変更しました。）

```
pred refine i:term, i:goal, o:list sealed-goal.
refine T (goal _ Trigger _ Proof _) GL :-
  Trigger = T, coq.ltac.collect-goals Proof GL _.
```

(注1)
- ``coq.ltac.collect-goals``　は、``src/coq_elpi_builtins.ml``
- ``refine`` は。``src/elpi/elpi-ltac.elpi``

以下では、Triggerへの代入はおこなわず、組込述語``refine``を使うようにします。

なお、Elpiのタクティクに引数を渡す箇所(``[trm S]``)は、後述します。
*)
Elpi Tactic refine0.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger Type Proof [trm S] as G) GL :-
    Trigger = S,
    coq.ltac.collect-goals Proof GL _,
    coq.say "goal : " G,
    coq.say "new goal : " GL.
  solve (goal _ _ _ _ [trm S] as G) GL :-
    Msg is {coq.term->string S} ^ " cannot refine",
    coq.ltac.fail _ Msg.
}}.
Elpi Typecheck.

Lemma test_refine0 : forall (P Q : Prop), P -> (P -> Q) -> Q.
Proof.
  intros P Q HP HPQ.
  elpi refine0 (HPQ _).
  elpi refine0 (HP).
Qed.

(**
# エラボレーション (``coq.elaborate-skeleton``)

Holeが埋められるかを事前にチェックしてから、Triggerに
セットします（実際に、穴を埋めるわけではない）。
*)
Elpi Tactic refine1.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger Type Proof [trm S] as G) GL :-
    coq.elaborate-skeleton S Ty T ok, !,
    coq.say "coq.elaborate-skeleton",
    coq.say "S  = " {coq.term->string S},
    coq.say "Ty = " {coq.term->string Ty},
    coq.say "T  = " {coq.term->string T},
    refine T G GL.    % Trigger = T.
  solve (goal _ _ _ _ [trm S]) _ :-
  Msg is {coq.term->string S} ^ " does not fit",
    coq.ltac.fail _ Msg.
}}.
Elpi Typecheck.

Lemma test_refine1 : forall (P Q : Prop), P -> (P -> Q) -> Q.
Proof.
  intros P Q HP HPQ.
  Fail elpi refine1 (HPQ).
  elpi refine1 (HPQ _).
  elpi refine1 (HP).
Qed.

(**
# α等価からの拡張 (``coq.unify-leq``)

``refine``は、λ式におけるα等価（束縛変数の名前の違いをのぞいて同じ）
である場合だけ同じ項と判断します。
この制限を緩和して、ゴールが``id Q`` のとき、これを ``Q``とみなして証明できるようにします。

``coq.unify-leq Ty' Ty`` は、cumulativityに``Ty' ≦ Ty``であることを
チェックするだけなので、値がきまっていないといけません。

そこで、``std.mem``が、バックトラックで、Ctxから取り出す、``Ty'``の値を使い、
``coq.unify-leq {{Q}} {{id Q}}`` すなわち``{{Q}} ≦ {{id Q}}``
から、``Ty' = Q``、``H = HQ``を見つけ出し、
結果として、``Trigger = {{HQ}}``を実行できることになります。
*)

Elpi Tactic assumption2.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger Ty Proof [] as G) GL :-
    std.mem Ctx (decl H _ Ty'),
    coq.unify-leq Ty' Ty ok,
    % ↑これを ``Ty' = Ty`` にると、うまくいかない。
    coq.say "coq.unify-leq",
    coq.say "Ty'= " {coq.term->string Ty'},
    coq.say "Ty = " {coq.term->string Ty},
    coq.say "H  = " {coq.term->string H},
    refine H G GL.    % Trigger = H.
  solve _ _ :-
    coq.ltac.fail _ "no such hypothesis".
}}.
Elpi Typecheck.

Lemma test_assumption2 : forall (P Q : Prop), P -> Q -> P /\ (id Q).
Proof.
  intros P Q HP HQ.
  split.
  - elpi assumption2.
  - elpi assumption2.
Qed.

(**
# タクティクのエラー (``coq.ltac.fail``)

Elpiで書いたタクティクが、Elpiとしして
「失敗」した場合は、以下のfatalエラーになります。
"The elpi tactic/command XXXXX failed without giving a specific error message.
Please report this inconvenience to the authors of the program."

Coqのタクティカルの``repeat``は、タクティクが「実行できる限り実行する」ものですから、
途中で、このようなfatalエラーが発生することは、避けなければなりません。

そこで、Elpiで書いたタクティクのエラーでタクティクを終了する場合は、
組込述語``coq.ltac.fail``を呼び出して、Elpiのコード自体は「成功」させるようにします
（``coq.ltac.fail``自体は、呼び出されると、Elpiとしては「成功」します）。

``coq.ltac.fail``が発生するエラーは、``repeat``がキャッチできるので、
``repeat``の中で使うなら、``repeat``が正常に終了し、
``repeat``の外で使うなら、faitalエラーとなり、引数のエラーメッセージが表示される、
という動きになります。
*)

Elpi Tactic split.        (* split_ll_bis *)
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger {{ _ /\ _ }} Proof Args as G) GL :-
    refine {{ conj _ _ }} G GL.
  solve _ _ :-  % この節を外すと ``repat elpi split`` が動かない。
   coq.ltac.fail _ "not a conjunction".
}}.
Elpi Typecheck.

(**
[1]で定義したsplitは、これを守っているため、repeatの中で意図通りに動きます。
*)
Lemma test22 : forall (P1 P2 P3 P4 P5 : Prop),
  P1 -> P2 -> P3 -> P4 -> P5 -> P1 /\ P2 /\ P3 /\ P4 /\ P5.
Proof.
  intros P1 P2 P3 P4 P5 HP1 HP2 HP3 HP4 HP5.

  (* Goal : P1 /\ P2 /\ P3 /\ P4 /\ P5 *)
  repeat elpi split.
  (* repeat の中から呼び出すと、可能な限りsplitを繰り返し、エラーにならない。 *)

  Undo 1.
  (* Goal : P1 /\ P2 /\ P3 /\ P4 /\ P5 *)
  elpi split.
  (* Goal : P1 *)
    Fail elpi split.     (* Tactic failure: not a conjunction. *)
    assumption.
    elpi split.
      assumption.
      elpi split.
        assumption.
        elpi split.
        assumption.
        assumption.
Qed.

(**
# 引数の授受

タクティクの引数は solveの第1引数の``goal Ctx Trigger Type Proof Args``のArgsに渡されます。
Args の型は``list argument``で、
さらに、argumentは、[2]の``elpi/coq-HOAS.elpi``で、次のように定義されています。

```
kind argument type.
type int       int    -> argument.
type str       string -> argument.
type trm       term   -> argument.
```
*)

(**
## 引数の受け取り

Elpiの項として必要なのは、int型、string型、term型ですから、Elpiから使うためには、
コンストラクタ``int``、``str``、``trm``は取り去らないといけません。
*)

Elpi Tactic print_arg_int_string_term.
Elpi Accumulate lp:{{
  solve (goal _ _ _ _ [int A1, str A2, trm A3]) GL :-
    coq.say A1 ": int",
    coq.say A2 ": string",
    coq.say A3 ": term",
    coq.say {coq.term->string A3} ": term".
  solve _ _ :-
    coq.ltac.fail _ "wrong args".
}}.
Elpi Typecheck.

(**
## 引数の受け渡し

Elpiのコードの中から、他のタクティクを呼び出す場合は、
``coq.ltac.call`` を使います。引数の渡し方は、前節の説明と同じです。

ここではCoqの節``I``を渡していますが、``{{}}``で囲んで書けるので、
以下のように渡すことができます。
*)

Ltac test t := refine t.
Elpi Tactic refine_I.
Elpi Accumulate lp:{{
  solve G GL :-
    coq.ltac.call "test" [trm {{I}}] G GL.
}}.
Elpi Typecheck.

Lemma test_print_args : True.
Proof.
  elpi print_arg_int_string_term 1 x (1 = 0).
  elpi print_arg_int_string_term -1 "x y" (1).
  elpi refine_I.
Qed.

(**
# Coq項の表示 (``coq.term->string``)

Coqの項を渡す場合は、Coq側で``()``で囲む必要があります。

また、Coqの項は、内部表現で表示しても判らないので、
組込述語``coq.term->string``が用意されています。
述語としては2引数ですが``{}``で囲むことで、関数のように使っています。
[1]の[3]のSpillingの節を参照してください。

前節の例を参照してください。
*)

(**
# 参考文献

[1] Coq-Elpi によるタクティクの作成（その1の2）

<https://qiita.com/suharahiromichi/items/31096ff47ab69f4ba4ea>

<https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_tactic_sample_1_2.v>

[2] coq-ELPI

<https://github.com/LPCIC/coq-elpi>
*)

(* END *)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2008-10-14

REN(CAP(_)) operation used in the DP framework.

Like ACap.capa except that variables are considered as aliens too.
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil ACalls ATrs VecUtil ListUtil NatUtil
     RelUtil.

Section S.

Variable Sig : Signature.

Notation term := (term Sig). Notation terms := (vector term).

(***********************************************************************)
(** we first defined a generic cap as a triple (k,f,v) where
- k is the number of aliens
- f is a function which, given a vector v of k terms, returns the cap
with the ith alien replaced by the ith term of v
- v is the vector of the k aliens

the generic cap of a term is computed by the function capa below
its property is: if capa(t) = (k,f,v) then f(v)=t

f acts as an abstract context with k holes *)

Definition Cap := sigT (fun k => ((terms k -> term) * terms k)%type).

Notation Caps := (vector Cap).

Definition mkCap := @existT nat (fun k => ((terms k -> term) * terms k)%type).

Definition fcap (c : Cap) := fst (projT2 c).
Definition aliens (c : Cap) := snd (projT2 c).

(* total number of aliens of a vector of caps *)

Fixpoint sum n (cs : Caps n) : nat :=
  match cs with
    | Vnil => 0
    | Vcons c cs' => projT1 c + sum cs'
  end.

(* concatenation of all the aliens of a vector of caps *)

Fixpoint conc n (cs : Caps n) : terms (sum cs) :=
  match cs as cs return terms (sum cs) with
    | Vnil => Vnil
    | Vcons c cs' => Vapp (aliens c) (conc cs')
  end.

Lemma in_conc : forall u n (cs : Caps n), Vin u (conc cs) ->
  exists c, Vin c cs /\ Vin u (aliens c).

Proof.
induction cs; simpl; intros. contr.
assert (Vin u (aliens h) \/ Vin u (conc cs)). apply Vin_app. hyp.
destruct H0. exists h. auto.
assert (exists c, Vin c cs /\ Vin u (aliens c)). apply IHcs. hyp.
destruct H1 as [c]. exists c. intuition.
Qed.

Arguments in_conc [u n cs] _.

(* given a vector cs of caps and a vector ts of (sum cs) terms, this
function breaks ts in vectors of size the number of aliens of every
cap of cs, apply every fcap to the corresponding vector, and
concatenate all the results *)

Fixpoint Vmap_sum n (cs : Caps n) : terms (sum cs) -> terms n :=
  match cs as cs in vector _ n return terms (sum cs) -> terms n with
    | Vnil => fun _ => Vnil
    | Vcons c cs' => fun ts =>
      let (hd,tl) := Vbreak ts in Vcons (fcap c hd) (Vmap_sum cs' tl)
  end.

(***********************************************************************)
(** function computing the generic cap of a term *)

Notation rule := (@rule Sig). Notation rules := (list rule).

Variable R : rules.

Fixpoint capa (t : term) : Cap :=
  match t with
    | Var x => mkCap (fun v => Vnth v (lt_O_Sn 0), Vcons t Vnil)
    | Fun f ts =>
      if defined f R
	then mkCap (fun v => Vnth v (lt_O_Sn 0), Vcons t Vnil)
	else let cs := Vmap capa ts in
	  mkCap (fun v => Fun f (Vmap_sum cs v), conc cs)
end.

(***********************************************************************)
(** number of aliens of a term *)

Definition nb_aliens t := projT1 (capa t).

Definition nb_aliens_vec n (ts : terms n) := sum (Vmap capa ts).

Lemma nb_aliens_cons : forall t n (ts : terms n),
  nb_aliens_vec (Vcons t ts) = nb_aliens t + nb_aliens_vec ts.

Proof.
refl.
Qed.

Lemma nb_aliens_fun : forall f ts,
  nb_aliens (Fun f ts) = if defined f R then 1 else nb_aliens_vec ts.

Proof.
intros. unfold nb_aliens, nb_aliens_vec. simpl.
case (defined f R); refl.
Qed.

(***********************************************************************)
(** concrete cap: it is obtained by applying fcap to a sequence of fresh
variables *)

Definition ren_cap k t := fcap (capa t) (fresh k (nb_aliens t)).

Fixpoint ren_caps k n (ts : terms n) : terms n :=
  match ts in vector _ n return terms n with
  | Vnil => Vnil
  | Vcons t ts =>
    Vcons (ren_cap k t) (ren_caps (k + nb_aliens t) ts)
  end.

Lemma ren_caps_eq : forall n (ts : terms n) k,
  Vmap_sum (Vmap capa ts) (fresh k (sum (Vmap capa ts)))
  =  ren_caps k ts.

Proof.
induction ts; simpl; intros. refl. rewrite Vbreak_fresh. apply Vcons_eq_intro.
refl. rewrite IHts. refl.
Qed.

Lemma ren_cap_fun : forall f ts k,
  ren_cap k (Fun f ts) = if defined f R then Var k else Fun f (ren_caps k ts).

Proof.
intros. unfold ren_cap, nb_aliens. simpl. case (defined f R). refl.
unfold fcap. simpl. apply args_eq. apply ren_caps_eq.
Qed.

(***********************************************************************)
(** relation wrt variables *)

Lemma vars_ren_cap : forall x t k,
  In x (vars (ren_cap k t)) -> k <= x /\ x < k + nb_aliens t.

Proof.
intros x t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  forall k, In x (vars_vec (ren_caps k ts)) ->
  k <= x /\ x < k + nb_aliens_vec ts); clear t.
(* Var *)
unfold nb_aliens. simpl. intuition.
(* Fun *)
intros f ts H k0. rewrite ren_cap_fun. unfold nb_aliens. simpl.
case (defined f R). simpl. intuition. rewrite vars_fun. simpl. exact (H k0).
(* Vnil *)
simpl. intuition.
(* Vcons *)
intros t n ts h1 h2 k0. rewrite nb_aliens_cons. simpl. rewrite in_app.
intro. destruct H. ded (h1 _ H). lia. ded (h2 _ H). lia.
Qed.

Arguments vars_ren_cap [x t k] _.

Lemma vars_ren_caps : forall x n (ts : terms n) k,
  In x (vars_vec (ren_caps k ts)) -> k <= x /\ x < k + nb_aliens_vec ts.

Proof.
induction ts.
(* Vnil *)
simpl. intuition.
(* Vcons *)
simpl. intro. rewrite in_app, nb_aliens_cons. intro. destruct H.
ded (vars_ren_cap H). lia. ded (IHts _ H). lia.
Qed.

Arguments vars_ren_caps [x n ts k] _.

(***********************************************************************)
(** relation wrt substitution *)

Ltac single_tac x t :=
  exists (single x t); split; [single
  | unfold single, nb_aliens; simpl;
    let y := fresh "y" in intro y; intro;
    case_beq_nat x y; [lia | refl]].

Notation In_dec := (In_dec eq_nat_dec).

Lemma ren_cap_intro : forall t k, exists s, t = sub s (ren_cap k t)
  /\ forall x, x < k \/ x >= k + nb_aliens t -> s x = Var x.

Proof.
intro t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  forall k, exists s, ts = Vmap (sub s) (ren_caps k ts)
  /\ forall x, x < k \/ x >= k + nb_aliens_vec ts -> s x = Var x);
  clear t; intros.
(* Var *)
simpl. single_tac k (@Var Sig x).
(* Fun *)
rewrite nb_aliens_fun, ren_cap_fun. case (defined f R).
single_tac k (Fun f v). destruct (H k) as [s]. exists s. rewrite sub_fun.
intuition. rewrite <- H1. refl.
(* Vnil *)
exists (fun x => Var x). intuition.
(* Vcons *)
simpl. destruct (H k) as [s1]. destruct H1 as [H1 H1'].
destruct (H0 (k + nb_aliens t)) as [s2]. destruct H2 as [H2 H2'].
set (s := fun x => match In_dec x (vars (ren_cap k t)) with
  | left _ => s1 x | right _ => s2 x end). exists s.
assert (sub s (ren_cap k t) = sub s1 (ren_cap k t)). apply sub_eq. intros.
unfold s. case (In_dec x (vars (ren_cap k t))); intro. refl.
intuition. rewrite H3, <- H1.
assert (Vmap (sub s) (ren_caps (k + nb_aliens t) v)
  = Vmap (sub s2) (ren_caps (k + nb_aliens t) v)). apply Vmap_sub_eq. intros.
ded (vars_ren_caps H4). unfold s. case (In_dec x (vars (ren_cap k t))); intro.
ded (vars_ren_cap i). lia. refl. rewrite H4, <- H2.
split. refl. rewrite nb_aliens_cons. intros. unfold s.
case (In_dec x (vars (ren_cap k t))); intro. ded (vars_ren_cap i).
lia. apply H2'. lia.
Qed.

Lemma ren_caps_intro : forall n (ts : terms n) k,
  exists s, ts = Vmap (sub s) (ren_caps k ts)
  /\ forall x, x < k \/ x >= k + nb_aliens_vec ts -> s x = Var x.

Proof.
induction ts; intro.
(* Vnil *)
exists (fun x => Var x). intuition.
(* Vcons *)
simpl. destruct (ren_cap_intro h k) as [s1]. destruct H as [H1 H1'].
destruct (IHts (k + nb_aliens h)) as [s2]. destruct H as [H2 H2'].
set (s := fun x => match In_dec x (vars (ren_cap k h)) with
  | left _ => s1 x | right _ => s2 x end). exists s.
assert (sub s (ren_cap k h) = sub s1 (ren_cap k h)). apply sub_eq. intros.
unfold s. case (In_dec x (vars (ren_cap k h))); intro. refl.
intuition. rewrite H, <- H1.
assert (Vmap (sub s) (ren_caps (k + nb_aliens h) ts)
  = Vmap (sub s2) (ren_caps (k + nb_aliens h) ts)). apply Vmap_sub_eq. intros.
ded (vars_ren_caps H0). unfold s. case (In_dec x (vars (ren_cap k h))); intro.
ded (vars_ren_cap i). lia. refl. rewrite H0, <- H2.
split. refl. rewrite nb_aliens_cons. intros. unfold s.
case (In_dec x (vars (ren_cap k h))); intro. ded (vars_ren_cap i).
lia. apply H2'. lia.
Qed.

Lemma ren_cap_sub_aux : forall s t k l,
  exists s', ren_cap k (sub s t) = sub s' (ren_cap l t)
          /\ forall x, x < l \/ x >= l + nb_aliens t -> s' x = Var x.

Proof.
intros s t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  forall k l, exists s',
  ren_caps k (Vmap (sub s) ts) = Vmap (sub s') (ren_caps l ts)
  /\ forall x, x < l \/ x >= l + nb_aliens_vec ts -> s' x = Var x);
  clear t; intros.
(* Var *)
simpl. single_tac l (ren_cap k (s x)).
(* Fun *)
rewrite sub_fun, !ren_cap_fun, nb_aliens_fun.
case (defined f R). simpl. single_tac l (@Var Sig k).
destruct (H k l) as [s']. destruct H0. exists s'. rewrite H0, sub_fun.
intuition.
(* Vnil *)
simpl. exists (fun x => Var x). auto.
(* Vcons *)
simpl. destruct (H k l) as [s1]. destruct H1 as [H1 H1']. rewrite H1.
destruct (H0 (k + nb_aliens (sub s t)) (l + nb_aliens t)) as [s2].
destruct H2 as [H2 H2']. rewrite H2.
set (s' := fun x => match In_dec x (vars (ren_cap l t)) with
  left _ => s1 x | right _ => s2 x end). exists s'. split.
apply Vcons_eq_intro. apply sub_eq. intros. unfold s'.
case (In_dec x (vars (ren_cap l t))); intro. refl. intuition.
apply Vmap_sub_eq. intros. ded (vars_ren_caps H3). unfold s'.
case (In_dec x (vars (ren_cap l t))); intro. ded (vars_ren_cap i).
lia. refl.
(* domain *)
rewrite nb_aliens_cons. intros. unfold s'.
case (In_dec x (vars (ren_cap l t))); intro. ded (vars_ren_cap i).
lia. apply H2'. lia.
Qed.

Lemma ren_cap_sub : forall s t k,
  exists s', ren_cap k (sub s t) = sub s' (ren_cap k t)
          /\ forall x, x < k \/ x >= k + nb_aliens t -> s' x = Var x.

Proof.
intros. apply ren_cap_sub_aux with (l := k).
Qed.

Lemma ren_caps_sub_aux : forall s n (ts : terms n) k l,
  exists s', ren_caps k (Vmap (sub s) ts) = Vmap (sub s') (ren_caps l ts)
  /\ forall x, x < l \/ x >= l + nb_aliens_vec ts -> s' x = Var x.

Proof.
induction ts; intros.
(* Vnil *)
simpl. exists (fun x => Var x). auto.
(* Vcons *)
simpl. destruct (ren_cap_sub_aux s h k l) as [s1]. destruct H as [H1 H1'].
rewrite H1.
destruct (IHts (k + nb_aliens (sub s h)) (l + nb_aliens h)) as [s2].
destruct H as [H2 H2']. rewrite H2.
set (s' := fun x => match In_dec x (vars (ren_cap l h)) with
  left _ => s1 x | right _ => s2 x end). exists s'. split.
apply Vcons_eq_intro. apply sub_eq. intros. unfold s'.
case (In_dec x (vars (ren_cap l h))); intro. refl. intuition.
apply Vmap_sub_eq. intros. ded (vars_ren_caps H). unfold s'.
case (In_dec x (vars (ren_cap l h))); intro. ded (vars_ren_cap i).
lia. refl.
(* domain *)
rewrite nb_aliens_cons. intros. unfold s'.
case (In_dec x (vars (ren_cap l h))); intro. ded (vars_ren_cap i).
lia. apply H2'. lia.
Qed.

Lemma ren_caps_sub : forall s n (ts : terms n) k,
  exists s', ren_caps k (Vmap (sub s) ts) = Vmap (sub s') (ren_caps k ts)
  /\ forall x, x < k \/ x >= k + nb_aliens_vec ts -> s' x = Var x.

Proof.
intros. apply ren_caps_sub_aux with (l := k).
Qed.

(***********************************************************************)
(** idempotence *)

Lemma nb_aliens_ren_cap : forall t k, nb_aliens (ren_cap k t) = nb_aliens t.

Proof.
intro t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  forall k, nb_aliens_vec (ren_caps k ts) = nb_aliens_vec ts);
  clear t; intros; auto.
(* Fun *)
rewrite ren_cap_fun, nb_aliens_fun. case_eq (defined f R); intro H0. refl.
rewrite nb_aliens_fun, H0. auto.
(* Vcons *)
simpl. rewrite !nb_aliens_cons. auto.
Qed.

Lemma ren_cap_idem : forall t k l, ren_cap k (ren_cap l t) = ren_cap k t.

Proof.
intro t; pattern t; apply term_ind with (Q := fun n (ts : terms n) =>
  forall k l, ren_caps k (ren_caps l ts) = ren_caps k ts);
  clear t; intros; auto.
(* Fun *)
rewrite !ren_cap_fun. case_eq (defined f R); intro H0. refl.
rewrite ren_cap_fun, H0, H. refl.
(* Vcons *)
simpl. rewrite H, H0, nb_aliens_ren_cap. refl.
Qed.

(***********************************************************************)
(** relation with vector operations *)

Lemma ren_caps_cast : forall n1 (ts : terms n1) n2 (e : n1=n2) k,
  ren_caps k (Vcast ts e) = Vcast (ren_caps k ts) e.

Proof.
  induction ts; intros; destruct n2; try discr.
  rewrite !Vcast_refl. refl.
  simpl. rewrite !Vcast_cons. simpl. rewrite IHts. refl.
Qed.

Lemma ren_caps_app : forall n2 (v2 : terms n2) n1 (v1 : terms n1) k,
  ren_caps k (Vapp v1 v2)
  = Vapp (ren_caps k v1) (ren_caps (k + nb_aliens_vec v1) v2).

Proof.
induction v1; simpl; intros. unfold nb_aliens_vec. simpl. rewrite plus_0_r.
refl. rewrite nb_aliens_cons, plus_assoc, <- IHv1. refl.
Qed.

(***********************************************************************)
(** relation with reduction *)

Variable hyp : forallb (@is_notvar_lhs Sig) R = true.

Lemma red_sub_ren_cap : forall u v,
  red R u v -> forall k, exists s, v = sub s (ren_cap k u).

Proof.
intros u v H. redtac. subst. elim c; clear c; simpl; intros.
(* Hole *)
destruct l. is_var_lhs. assert (defined f R = true).
eapply lhs_fun_defined. apply lr. rewrite sub_fun, ren_cap_fun, H.
exists_single k (sub s r).
(* Cont *)
rewrite ren_cap_fun. case (defined f R). simpl.
exists_single k (Fun f (Vcast (Vapp t (Vcons (fill c (sub s r)) t0)) e)).
rewrite ren_caps_cast, ren_caps_app. simpl ren_caps.
destruct (ren_caps_intro t k) as [s1]. destruct H0 as [H0 H0'].
destruct (H (k + nb_aliens_vec t)) as [s2].
destruct (ren_caps_intro t0
  (k + nb_aliens_vec t + nb_aliens (fill c (sub s l)))) as [s3].
destruct H2 as [H2 H2'].
set (s' := fun x => match In_dec x (vars_vec (ren_caps k t)) with
  | left _ => s1 x | right _ => match
  In_dec x (vars (ren_cap (k + nb_aliens_vec t) (fill c (sub s l)))) with
  | left _ => s2 x | right _ => s3 x end end). exists s'.
rewrite sub_fun. apply args_eq. rewrite Vmap_cast, Vmap_app. simpl.
apply Vcast_eq_intro. apply Vapp_eq_intro.
trans (Vmap (sub s1) (ren_caps k t)).
hyp. apply Vmap_sub_eq. intros. ded (vars_ren_caps H3). unfold s'.
case (In_dec x (vars_vec (ren_caps k t))); intro. refl. intuition.
apply Vcons_eq_intro. rewrite H1. apply sub_eq. intros. ded (vars_ren_cap H3).
unfold s'. case (In_dec x (vars_vec (ren_caps k t))); intro.
ded (vars_ren_caps i0). lia. case
  (In_dec x (vars (ren_cap (k + nb_aliens_vec t) (fill c (sub s l)))));
  intro. refl. intuition.
trans (Vmap (sub s3)
  (ren_caps (k + nb_aliens_vec t + nb_aliens (fill c (sub s l))) t0)).
hyp. apply Vmap_sub_eq. intros. ded (vars_ren_caps H3). unfold s'.
case (In_dec x (vars_vec (ren_caps k t))); intro.
ded (vars_ren_caps i0). lia. case
  (In_dec x (vars (ren_cap (k + nb_aliens_vec t) (fill c (sub s l)))));
  intro. ded (vars_ren_cap i0). lia. refl.
Qed.

Lemma rtc_red_sub_ren_cap : forall k u v,
  red R # u v -> exists s, v = sub s (ren_cap k u).

Proof.
induction 1; intros. apply red_sub_ren_cap. hyp.
destruct (ren_cap_intro x k). exists x0. intuition.
destruct IHclos_refl_trans1. destruct IHclos_refl_trans2. subst.
destruct (ren_cap_sub x0 (ren_cap k x) k). destruct H1.
rewrite H1, ren_cap_idem, sub_sub. exists (sub_comp x1 x2). refl.
Qed.

End S.

Arguments vars_ren_cap [Sig R x t k] _.
Arguments vars_ren_caps [Sig R x n ts k] _.


Require Import all_ssreflect fingroup perm core ordinal_ext Wf_nat.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Search.

Variable (I : finType) (A : Type) (f : A -> bool).

Definition up_search (i j : 'I_#|I|.+1) :
  i <= j -> AState {ffun I -> A} {k : 'I_#|I|.+1 | i <= k <= j} :=
  Fix
    (@well_founded_ordgt #|I|.+1)
    (fun i => i <= j -> AState {ffun I -> A} {k : 'I_#|I|.+1 | i <= k <= j})
    (fun (i : 'I_#|I|.+1) rec (H : i <= j) =>
       match i < j as cij return (i < j) = cij -> _ with
         | true => fun H' : i < j =>
           mlet x := astate_GET (idx_of_iter H') in
           if f x
           then astate_ret (exist (fun k : 'I_ _ => i <= k <= j) i
                  ltac:(by rewrite /= leqnn H))
           else mlet '(exist k Hk) := rec (ord_leq H') (leqnn _) H' in
                astate_ret (exist (fun k : 'I_ _ => i <= k <= j) k
                  ltac:(by case/andP: Hk => /ltnW ->))
         | false => fun _ =>
           astate_ret (exist (fun k : 'I_ _ => i <= k <= j) j
             ltac:(by rewrite /= leqnn H))
       end (erefl (i < j)))
    i.

Variant up_search_spec (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) :
  {k : 'I_#|I|.+1 | i <= k <= j} * {ffun I -> A} -> Prop :=
  UpSearchSpec (k : 'I_#|I|.+1) (Hk : i <= k <= j) :
  (forall k' : 'I_#|I|, k = k' :> nat -> k < j -> f (arr (fin_decode k'))) ->
  (forall i' : 'I_#|I|, i <= i' < k -> ~~ f (arr (fin_decode i'))) ->
  @up_search_spec i j arr (exist _ k Hk, arr).

Lemma run_up_search (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) (Hij : i <= j) :
  up_search_spec arr (run_AState (up_search Hij) arr).
Proof.
rewrite /up_search /Fix.
elim/Acc_rect: i / (well_founded_ordgt i) (well_founded_ordgt i) Hij
  => i _ IH Hi Hij; rewrite -Fix_F_eq /=.
case: {2 3}(i < j) (erefl (i < j)) => H; rewrite !run_AStateE;
  first case: ifP => H0; rewrite ?run_AStateE.
- constructor=> [k' H1 H2 |]; first congr (f (arr (_ _))): H0; ssromega.
- case: {IH Hi} (IH (ord_leq H)) => //= k /andP [] H1 H2 H3 H4;
    rewrite !run_AStateE; constructor=> // i';
    rewrite leq_eqVlt andb_orl => /orP [] H5; auto;
    congr (~~ (f (arr (_ _)))): (negbT H0); ssromega.
- constructor; ssromega.
Qed.

Definition down_search (i j : 'I_#|I|.+1) :
  j <= i -> AState {ffun I -> A} {k : 'I_#|I|.+1 | j <= k <= i} :=
  Fix
    (@well_founded_ordlt #|I|.+1)
    (fun i => j <= i -> AState {ffun I -> A} {k : 'I_#|I|.+1 | j <= k <= i})
    (fun (i : 'I_#|I|.+1) rec (H : j <= i) =>
       (if j < i as cij return (j < i) = cij -> _
        then fun H' : j < i =>
               mlet x : A := astate_GET (idx_of_pred_iter (ltnm0m H')) in
               if f x
               then astate_ret (exist (fun k : 'I_ _ => j <= k <= i) i
                                      ltac:(by rewrite /= H leqnn))
               else mlet '(exist k Hk) :=
                      rec (ord_pred' (i := i) (ltnm0m H'))
                          ltac:(by move/ltn_predK: (H') => ->)
                          ltac:(by case: (i) H' => -[]) in
                    astate_ret (exist (fun k : 'I_ _ => j <= k <= i) k
                      ltac:(by case/andP: Hk => -> /leq_trans;
                            apply; apply/leq_pred))
        else fun _ => astate_ret (exist (fun k : 'I_ _ => j <= k <= i) j
                        ltac:(by rewrite /= leqnn H)))
       (erefl (j < i)))
    i.

Variant down_search_spec (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) :
  {k : 'I_#|I|.+1 | j <= k <= i} * {ffun I -> A} -> Prop :=
  DownSearchSpec (k : 'I_#|I|.+1) (Hk : j <= k <= i) :
  (forall k' : 'I_#|I|, k = k'.+1 :> nat -> j < k ->
                        f (arr (fin_decode k'))) ->
  (forall i' : 'I_#|I|, k <= i' < i -> ~~ f (arr (fin_decode i'))) ->
  @down_search_spec i j arr (exist _ k Hk, arr).

Lemma run_down_search (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) (Hij : j <= i) :
  @down_search_spec i j arr (run_AState (down_search Hij) arr).
Proof.
rewrite /down_search /Fix.
elim/Acc_rect: i / (well_founded_ordlt i) (well_founded_ordlt i) Hij
  => i _ IH Hi Hji; rewrite -Fix_F_eq /=.
case: {2 3}(j < i) (erefl (j < i)) => H; rewrite !run_AStateE;
  first case: ifP => [| /negbT] H0; rewrite ?run_AStateE.
- constructor=> [k' H1 H2 |]; first congr (f (arr (_ _))): H0; ssromega.
- case: {IH} (IH (ord_pred' (ltnm0m H))) => [| k Hk H1 H2]; first ssromega.
  rewrite !run_AStateE; constructor=> // i' /andP [] H3.
  rewrite leq_eqVlt => /orP [] H4;
    [ congr (~~ (f (arr (_ _)))): H0 | apply: H2 ]; ssromega.
- constructor; ssromega.
Qed.

End Search.

Module Quicksort.
Section Quicksort.

Variable
  (I : finType) (A : Type) (cmp : A -> A -> bool)
  (Hcmp_trans : transitive cmp) (Hcmp_asym : forall x y, ~~ cmp y x -> cmp x y).

Lemma Hcmp_refl x : cmp x x.
Proof. by case: (cmp x x) (@Hcmp_asym x x) => //; apply. Qed.

Definition partition (pivot : A) :
  forall (i j : 'I_#|I|.+1),
    i <= j -> AState {ffun I -> A} {k : 'I_#|I|.+1 | i <= k <= j} :=
  Fix
    (@well_founded_ordgt #|I|.+1)
    (fun i => forall j : 'I_#|I|.+1,
         i <= j -> AState {ffun I -> A} {k : 'I_#|I|.+1 | i <= k <= j})
    (fun (i : 'I_#|I|.+1) rec (j : 'I_#|I|.+1) (Hij : i <= j) =>
       mlet '(exist i' Hi) := up_search (cmp pivot) (i := i) (j := j) Hij in
       mlet '(exist j' Hj) :=
         down_search (xpredC (cmp pivot)) (i := j) (j := i) Hij in
       match i'.+1 < j' as cij return i'.+1 < j' = cij -> _ with
         | true => fun Hij : i'.+1 < j' =>
           SWAP (idx_of_iter (ltnW Hij)) (idx_of_pred_iter (ltnm0m Hij));;
           mlet '(exist k Hk) :=
             rec (ord_leq (ltnW Hij))
                 ltac: (by case/andP: Hi; rewrite ltnS)
                 (ord_pred' (i := j') (ltnm0m Hij))
                 ltac: (by case: (j') Hij => -[]) in
           astate_ret (exist (fun k : 'I_ _ => i <= k <= j) k
             ltac:(move: Hi Hj Hk => /andP [Hi _] /andP [_ Hj] /andP [Hkl Hkr];
                   rewrite (leq_trans Hi (ltnW Hkl)) (leq_trans Hkr) //
                           (leq_trans (leq_pred _)) //))
         | false => fun _ =>
           astate_ret (exist (fun k : 'I_ _ => i <= k <= j) i' Hi)
       end (erefl (i'.+1 < j'))).

Variant partition_spec (pivot : A) (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) :
  {k : 'I_#|I|.+1 | i <= k <= j} * {ffun I -> A} -> Prop :=
  PartitionSpec (p : {perm I}) (k : 'I_#|I|.+1) (Hk : i <= k <= j) :
  let arr' := perm_ffun p arr in
  perm_on [set ix | i <= fin_encode ix < j] p ->
  (forall ix : 'I_#|I|, i <= ix < j ->
                        cmp pivot (arr' (fin_decode ix)) = (k <= ix)) ->
  @partition_spec pivot i j arr (exist _ k Hk, arr').

Lemma run_partition
      (pivot : A) (i j : 'I_#|I|.+1) (Hij : i <= j) (arr : {ffun I -> A}) :
  @partition_spec pivot i j arr (run_AState (partition pivot Hij) arr).
Proof with rewrite ?run_AStateE.
rewrite /partition /Fix.
elim/Acc_rect: i / (well_founded_ordgt i) (well_founded_ordgt i) j Hij arr
  => /= i _ IH Hi j Hij arr; rewrite -Fix_F_eq /=...
case: run_up_search => i' Hi'0 Hi'1 Hi'2...
case: run_down_search => j' Hj'0 Hj'1 Hj'2...
case: {2 3}(i'.+1 < j') (erefl (i'.+1 < j')) => [Hij' | /negbT];
  rewrite -?leqNgt !(run_SWAP, run_AStateE).
- case: {IH} (IH (ord_leq _) _ _ (ord_pred' _)); first ssromega;
    move=> p k Hk arr' /=...
  have {arr'} ->:
       arr' = [ffun ix => arr
               ((p * tperm (fin_decode (idx_of_iter (ltnW Hij')))
                           (fin_decode (idx_of_pred_iter (ltnm0m Hij'))))%g ix)]
    by apply/ffunP => ix; rewrite !ffunE permM.
  set arr' := [ffun ix => arr _] => Hp Hpart; constructor.
  + rewrite perm_onM //; [ apply/(subset_trans Hp) | ]; apply/subsetP => ix;
      rewrite !inE; first ssromega.
    rewrite -(inj_eq fin_encode_inj) (inj_tperm _ _ _ fin_encode_inj)
            !fin_decodeK; case: tpermP; ssromega.
  + move=> ix /andP [H H0]; case: (boolP (i' < ix < j'.-1)) => [/Hpart // | H1].
    rewrite ffunE permE /= (out_perm Hp) ?inE ?fin_decodeK //.
    rewrite -(inj_tperm _ _ _ fin_decode_inj).
    move: (Hj'1 (idx_of_pred_iter (ltnm0m Hij')))
          (Hi'1 (idx_of_iter (ltnW Hij')))
          (Hi'2 ix) (Hj'2 ix); case: tpermP; ssromega.
- rewrite leq_eqVlt ltnS -{2}(perm_ffunE1 arr) => Hij'; constructor;
    rewrite ?perm_on1 //= => ix /andP [H H0]; rewrite ffunE permE.
  case/predU1P: Hij' => Hij'; last by move: (Hi'2 ix) (Hj'2 ix); ssromega.
  have Hij'' : i' < j' by rewrite Hij'.
  move: (Hi'1 (idx_of_iter Hij'') erefl) (Hj'1 (idx_of_iter Hij'') Hij').
  ssromega.
Qed.

Definition quicksort_rec :
  'I_#|I|.+1 -> 'I_#|I|.+1 -> AState {ffun I -> A} unit :=
  Fix
  (@well_founded_ordgt #|I|.+1)
  (fun _ => 'I_#|I|.+1 -> AState {ffun I -> A} unit)
  (fun (i : 'I_#|I|.+1) recl =>
     Fix
     (@well_founded_ordlt #|I|.+1)
     (fun _ => AState {ffun I -> A} unit)
     (fun (j : 'I_#|I|.+1) recr =>
        match i.+1 < j as cij return i.+1 < j = cij -> _ with
          | true => fun Hij : i.+1 < j =>
            let i' := idx_of_iter (ltnW Hij) in
            let si := ord_leq (ltnW Hij) in
            mlet pivot : A := astate_GET i' in
            mlet '(exist k Hk) := @partition pivot si j (ltnW Hij) in
            let Hk' : 0 < k := ltac:(by case/andP: Hk => /ltnm0m) in
            let pk := idx_of_pred_iter (j := k) Hk' in
            mlet x : A := astate_GET pk in
            astate_SET i' x;; astate_SET pk pivot;;
            recr (ord_pred' (i := k) Hk')
                 ltac:(by case/andP: (Hk); rewrite /= (ltn_predK Hk'));;
            recl k ltac:(by case/andP: (Hk)) j
          | false => fun _ => astate_ret tt
        end (erefl (i.+1 < j)))).

Definition quicksort : AState {ffun I -> A} unit :=
  quicksort_rec ord0 (@Ordinal #|I|.+1 $|I| ltac:(by rewrite raw_cardE)).

Variant quicksort_rec_spec (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) :
  unit * {ffun I -> A} -> Prop :=
  QuicksortRecSpec (p : {perm I}) :
  let arr' := perm_ffun p arr in
  perm_on [set ix | i <= fin_encode ix < j] p ->
  (forall ix ix' : 'I_#|I|,
    i <= ix -> ix <= ix' -> ix' < j ->
    cmp (arr' (fin_decode ix)) (arr' (fin_decode ix'))) ->
  quicksort_rec_spec i j arr (tt, arr').

Lemma QuicksortRecSpec_
      (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) (p : {perm I}) :
  let arr' := perm_ffun p arr in
  perm_on [set ix | i <= fin_encode ix & fin_encode ix < j] p ->
  (forall ix ix' : 'I_#|I|,
    i <= ix -> ix < ix' -> ix' < j ->
    cmp (arr' (fin_decode ix)) (arr' (fin_decode ix'))) ->
  quicksort_rec_spec i j arr (tt, arr').
Proof.
by simpl=> H H'; constructor=> // ix ix' ?;
  rewrite leq_eqVlt => /predU1P [/ord_inj <- | ?] ?;
  [ apply: Hcmp_refl | apply: H' ].
Qed.

Lemma run_quicksort_rec (i j : 'I_#|I|.+1) (arr : {ffun I -> A}) :
  quicksort_rec_spec i j arr (run_AState (quicksort_rec i j) arr).
Proof with rewrite ?run_AStateE.
rewrite /quicksort_rec /Fix.
elim/Acc_rect: i / (well_founded_ordgt i) (well_founded_ordgt i) j arr =>
  i _ IHi Hi j arr; rewrite -Fix_F_eq /=.
elim/Acc_rect: j / (well_founded_ordlt j) (well_founded_ordlt j) arr =>
  j _ IHj Hj arr; rewrite -Fix_F_eq /=.
case: {2 3}(i.+1 < j) (erefl (i.+1 < j)) => [| /negbT];
  rewrite -/(is_true _) -?leqNgt => Hij; rewrite !run_AStateE /=;
  last by rewrite -{2}(perm_ffunE1 arr);
          apply: QuicksortRecSpec_; rewrite ?perm_on1 //; ssromega.
case: (run_partition _ (i := ord_leq (ltnW Hij))) => /= pp k Hk...
set ix_pivot := idx_of_iter (ltnW Hij).
set ix_part := idx_of_pred_iter _.
set arr' := dffun_set _ _ _.
move=> Hpp Hpart.
have {arr'} ->:
  arr' = perm_ffun (tperm (fin_decode ix_part) (fin_decode ix_pivot) * pp) arr.
  apply/ffunP => ix; rewrite !ffun_setE !ffunE permM permE /=.
  do !case: eqP => // ?; rewrite (out_perm Hpp) ?inE; try congruence.
  rewrite fin_decodeK; ssromega.
case: {IHj} (IHj (ord_pred' _)); first by ssromega.
rewrite /= /predn' => /= pl Hpl Hsortl.
case: IHi => [| pr arr' Hpr]; first by case/andP: (Hk).
subst arr'; rewrite -!perm_ffunEM mulgA => Hsortr.
apply: QuicksortRecSpec_ => [| ix ix' H H0 H1]; first by
  do !apply: perm_onM; [ apply: (subset_trans Hpr) | apply: (subset_trans Hpl) |
                       | apply: (subset_trans Hpp) ];
  apply/subsetP => x; rewrite !inE; try ssromega;
  case: tpermP; rewrite ?eqxx => // -> _; rewrite fin_decodeK; ssromega.
rewrite !ffunE !permM.
case: (ltngtP ix ix_part) (ltngtP ix' ix_part) => H2 [] H3; try ssromega.
- rewrite !(out_perm Hpr); try by rewrite inE fin_decodeK; ssromega.
  by move: (Hsortl ix ix'); rewrite !ffunE !permM; apply; ssromega.
- rewrite (out_perm Hpr); last by rewrite inE fin_decodeK; ssromega.
  move: (perm_closed (fin_decode ix) Hpl) (perm_closed (fin_decode ix') Hpr);
    rewrite !inE !fin_decodeK => H4 H5.
  rewrite (out_perm (x := pr _) Hpl); last by rewrite !inE; ssromega.
  apply: (Hcmp_trans (y := arr (fin_decode ix_pivot)) (Hcmp_asym _));
    rewrite -[tperm _ _ _]fin_encodeK -(ffunE (fun ix => arr (pp ix))) Hpart
            (inj_tperm _ _ _ fin_encode_inj) !fin_decodeK;
    case: tpermP; ssromega.
- move/ord_inj in H3; subst ix' => {H2}.
  rewrite !(out_perm Hpr, out_perm (x := _ ix_part) Hpl, tpermL,
            out_perm (x := _ ix_pivot) Hpp);
    try by rewrite inE fin_decodeK; ssromega.
  move: (perm_closed (fin_decode ix) Hpl); rewrite !inE fin_decodeK /= => H2.
  apply: Hcmp_asym.
  rewrite -[X in pp X]fin_encodeK -(ffunE (fun ix => arr (pp ix))) Hpart
          (inj_tperm _ _ _ fin_encode_inj) !fin_decodeK;
    case: tpermP; ssromega.
- move: (Hsortr ix ix'); rewrite !ffunE !permM; apply; ssromega.
- move/ord_inj in H2; subst ix => {H3}.
  move: (perm_closed (fin_decode ix') Hpr); rewrite !inE !fin_decodeK => H2.
  rewrite (out_perm Hpr) ?(out_perm Hpl) ?tpermL 1?(out_perm Hpp);
    try by rewrite ?inE ?fin_decodeK; ssromega.
  rewrite -(fin_encodeK (pr _)) -(inj_tperm _ _ _ fin_decode_inj)
          -(ffunE (fun ix => arr (pp ix))) tpermD ?Hpart; ssromega.
Qed.

Variant quicksort_spec (arr : {ffun I -> A}) : unit * {ffun I -> A} -> Prop :=
  QuicksortSpec (p : {perm I}) :
  let arr' := perm_ffun p arr in
  (forall ix ix' : 'I_#|I|,
    ix <= ix' -> cmp (arr' (fin_decode ix)) (arr' (fin_decode ix'))) ->
  quicksort_spec arr (tt, arr').

Lemma run_quicksort (arr : {ffun I -> A}) :
  quicksort_spec arr (run_AState quicksort arr).
Proof.
rewrite /quicksort.
set j := Ordinal _.
have ->: j = ord_max by apply/ord_inj => /=; rewrite raw_cardE.
by case: run_quicksort_rec => p /= Hp Hsort; constructor=> *; apply: Hsort.
Qed.

Definition quicksort_ (arr : {ffun I -> A}) : {ffun I -> A} :=
  (run_AState quicksort arr).2.

End Quicksort.
End Quicksort.

Require Import extraction_ocaml.

Extraction Implicit Quicksort.partition [I].
Extraction Implicit Quicksort.quicksort_rec [I].

Extraction Inline negb up_search down_search Quicksort.quicksort.

Set Extraction Flag 2031.
Extract Type Arity AState 0.

Extraction "../../ocaml/quicksort_o0.ml" nat_eqType ordinal_finType Quicksort.

Set Extraction Flag 8175.
Extract Type Arity AState 1.

Extraction "../../ocaml/quicksort.ml" nat_eqType ordinal_finType Quicksort.