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

(************************************************************************)
(*                                                                      *)
(*                       Process.v                                      *)
(*                                                                      *)
(*    Laurent.Thery @sophia.inria.fr        March 2002                  *)
(************************************************************************)
Require Import List.
Require Import Normal.
Require Import Nat.
Require Import ArithRing ZArithRing.
Require Import sTactic.
Require Import ReduceEq.
Require Import ReduceCong.

Fixpoint maxL (l : list Z) (l1 : list (nat * form)) {struct l1} : Z :=
  match l1 with
  | nil => 0%Z
  | (n1, Neg (Form.Eq a b)) :: l2 =>
      Zmax (maxL l l2) (Zsucc (exp2Z l a - exp2Z l b))
  | _ => 0%Z
  end.

Theorem maxPos : forall l l1, (0 <= maxL l l1)%Z.
intros l l1; elim l1; simpl in |- *; auto with zarith.
intros a; case a; simpl in |- *; auto with arith.
intros n; intros f; case f; simpl in |- *; auto with zarith.
intros f0; case f0; simpl in |- *; auto with zarith.
intros; apply Zle_trans with (maxL l l0); auto.
apply Zmax1; auto.
Qed.

Theorem onlyNeg_correct_aux :
 forall l l1,
 listNEqP l1 -> forall a, (maxL l l1 <= a)%Z -> formL2Prop a l l1.
intros l l1 H; elim H; simpl in |- *; auto.
intros n a b l0 H0 H1 H2 a0 H3; split; auto.
2: apply H2.
2: apply Zle_trans with (2 := H3).
2: apply Zmax1.
red in |- *; intros H4;
 absurd (Zmax (maxL l l0) (Zsucc (exp2Z l a - exp2Z l b)) <= a0)%Z;
 auto.
apply Zlt_not_le.
replace (Zsucc (a0 * Z_of_nat n + exp2Z l b - exp2Z l b)) with
 (Zsucc (a0 * Z_of_nat n)); [ idtac | unfold Zsucc in |- *; ring ].
apply Zlt_le_trans with (Zsucc (a0 * Z_of_nat n)).
apply Zle_lt_succ.
pattern a0 at 1 in |- *; replace a0 with (a0 * Z_of_nat 1)%Z;
 [ idtac | simpl in |- *; ring ].
apply Zmult_le_compat_l; auto with zarith arith.
apply Znat.inj_le; auto with arith.
apply Zle_trans with (maxL l l0).
apply maxPos.
apply Zle_trans with (2 := H3).
apply Zmax1.
replace (exp2Z l a - exp2Z l b)%Z with (a0 * Z_of_nat n)%Z.
apply Zmax2.
rewrite H4; ring.
Qed.

Theorem onlyNeg_correct :
 forall l l1, listNEqP l1 -> exists a : _, formL2Prop a l l1.
intros l l1 H; exists (maxL l l1).
apply onlyNeg_correct_aux; auto with zarith.
Qed.

Fixpoint maxC (l1 : list (nat * form)) : nat :=
  match l1 with
  | nil => 1
  | (n1, Cong i a b) :: l2 => lcm i (maxC l2)
  | _ => 1
  end.

Theorem maxCPos : forall l, listCongP l -> 1 <= maxC l.
intros l H; elim H; simpl in |- *; auto.
intros n i a b l0 H0 H1 H2 H3; (apply le_trans with i; auto with arith).
case (divides_lcm1 i (maxC l0)); auto with arith.
intros m1 H4; rewrite H4; pattern i at 1 in |- *; replace i with (i * 1);
 [ idtac | ring ].
cut (0 < lcm i (maxC l0)).
rewrite H4; case m1; auto with arith.
intros H5; Contradict H5; rewrite mult_comm; simpl in |- *; auto with arith.
apply lcm_lt_O; auto.
Qed.

Theorem onlyNeg_correct_aux1 :
 forall a b l l1,
 listCongP l1 ->
 formL2Prop a l l1 -> formL2Prop (a + b * Z_of_nat (maxC l1)) l l1.
intros a b l l1 H; generalize a b; elim H; simpl in |- *; clear H a b l1;
 auto.
intros n i a b l0 H H0 H1 H2 a0 b0 ((m3, H3), H4).
split.
exists (m3 - Z_of_nat n * (b0 * Z_of_nat (div (lcm i (maxC l0)) i)))%Z.
rewrite H3.
cut
 (forall a b c d e,
  ((a - e * (b * Z_of_nat c)) * d)%Z = (a * d - e * (d * Z_of_nat c * b))%Z);
 [ intros H5; rewrite H5 | intros; ring ].
rewrite <- Znat.inj_mult; rewrite <- divides_div; auto.
ring.
apply divides_lcm1; auto.
generalize (maxCPos _ H1); auto with arith.
replace (b0 * Z_of_nat (lcm i (maxC l0)))%Z with
 (b0 * Z_of_nat (div (lcm i (maxC l0)) (maxC l0)) * Z_of_nat (maxC l0))%Z;
 auto.
cut (forall a b c, (a * b * c)%Z = (c * b * a)%Z);
 [ intros H5; rewrite H5 | intros; ring ].
rewrite <- Znat.inj_mult; rewrite <- divides_div; auto.
ring.
generalize (maxCPos _ H1); auto with arith.
apply divides_lcm2; auto.
generalize (maxCPos _ H1); auto with arith.
Qed.

Theorem onlyNeg_correct_aux2 :
 forall a b l l1,
 listCongP l1 ->
 formL2Prop a l l1 -> exists c : _, (b <= c)%Z /\ formL2Prop c l l1.
intros a b l l1 H H0; (case (Zle_or_lt b a); intros H1).
exists a; auto with zarith.
exists (a + (b - a) * Z_of_nat (maxC l1))%Z.
split.
pattern b at 1 in |- *; replace b with (a + (b - a) * Z_of_nat 1)%Z;
 [ idtac | simpl in |- *; ring ].
apply Zplus_le_compat_l.
apply Zmult_le_compat_l.
apply Znat.inj_le; apply maxCPos; auto.
apply Zlt_le_weak; unfold Zminus in |- *; apply Zlt_left_lt; auto.
apply onlyNeg_correct_aux1; auto.
Qed.

Theorem oneCongNeq_correct :
 forall l l1 l2,
 listNEqP l1 ->
 listCongP l2 ->
 ((exists c : _, formL2Prop c l l1 /\ formL2Prop c l l2) <->
  (exists c : _, formL2Prop c l l2)).
intros l l1 l2 H H1; split.
intros (c, (H2, H3)); exists c; auto.
intros (d, H2).
case (onlyNeg_correct_aux2 d (maxL l l1) l l2); auto.
intros c (H3, H4); exists c; split; auto.
apply onlyNeg_correct_aux; auto.
Qed.

(** Process the list produced by Sort and generate the appropriate reduction *)
Definition processList
  (ls : list form *
        (list (nat * form) * (list (nat * form) * list (nat * form)))) :
  list form :=
  match ls with
  | (l1, ((m1, Form.Eq a1 b1) :: l2, (l3, l4))) =>
      Cong m1 a1 b1
      :: l1 ++
         reduceEqEq m1 a1 b1 l2 ++
         reduceEqNEq m1 a1 b1 l3 ++ reduceEqCong m1 a1 b1 l4
  | (l1, (nil, (l3, (m1, Cong i1 a1 b1) :: l4))) =>
      match reduceCongCong i1 m1 a1 b1 l4 with
      | (i2, (m2, (a2, (b2, l5)))) => Cong (gcd i2 m2) a2 b2 :: l1 ++ l5
      end
  | (l1, (l2, (l3, l4))) => l1
  end.

Theorem processList_correct :
 forall l l1 l2 l3 l4,
 Cnf1 (buildConj l1) ->
 listEqP l2 ->
 listNEqP l3 ->
 listCongP l4 ->
 ((exists a : _,
     form2Prop l (buildConj l1) /\
     formL2Prop a l l2 /\ formL2Prop a l l3 /\ formL2Prop a l l4) <->
  form2Prop l (buildConj (processList (l1, (l2, (l3, l4)))))) /\
 Cnf1 (buildConj (processList (l1, (l2, (l3, l4))))).
intros l l1 l2 l3 l4 H H0 H1 H2; inversion H0.
inversion H2; simpl in |- *.
split; auto; split.
intros (m5, (H5, H6)); auto.
case (onlyNeg_correct l l3); auto with arith.
intros a H5 H6; exists a; auto.
split.
split.
intros (c, (H8, (H9, (H10, (H11, H12))))).
generalize (reduceCongCong_correct i n a b (c :: l) l0 H4 H5 H6);
 case (reduceCongCong i n a b l0).
intros n1 p; case p; clear p.
intros n2 p; case p; clear p.
intros a1 p; case p; clear p.
intros b1 ll.
intros (H13, (H14, (H'14, H''14))); simpl in H13, H14.
case H13; clear H13; intros H13 H15; case H13; clear H13 H15; auto.
intros H15 H16; apply form2Prop_cons; auto.
case H15; intros m17 H17.
simpl in |- *;
 exists
  (c * Z_of_nat (div n2 (gcd n1 n2)) + m17 * Z_of_nat (div n1 (gcd n1 n2)))%Z.
rewrite H17.
cut
 (forall a b c d e, ((a * b + c * d) * e)%Z = (a * (e * b) + c * (e * d))%Z);
 [ intros H18; rewrite H18 | intros; ring ].
repeat rewrite <- Znat.inj_mult; repeat rewrite <- divides_div; auto.
ring.
apply gcd_lt_zero; auto.
apply divides_gcd1; auto.
apply gcd_lt_zero; auto.
apply divides_gcd2; auto.
CaseEq (reduceCongCong i n a b l0).
intros n1 p; case p; clear p.
intros n2 p; case p; clear p.
intros a1 p; case p; clear p.
intros b1 ll.
intros H8 H9.
generalize (form2Prop_cons_inv _ _ _ H9); intros ((m10, H10), H11).
case (gcd_bezout n1 n2); intros z1 (z2, H12).
rewrite <- H12 in H10.
generalize (reduceCongCong_correct i n a b ((m10 * z2)%Z :: l) l0 H4 H5 H6).
rewrite H8; simpl in |- *.
intros ((H13, H14), (H15, (H16, H17))); case H14; clear H13 H14.
split.
exists (m10 * z1)%Z; rewrite H10; ring.
case (form2Prop_app_inv _ _ _ H11); auto.
intros H13 H14.
case (oneCongNeq_correct l l3 ((n, Cong i a b) :: l0)); auto.
intros H18 H19; case H19; clear H18 H19; auto.
exists (m10 * z2)%Z; simpl in |- *; auto.
simpl in |- *; intros m5 (H18, (H19, H20)); exists m5; repeat split; auto.
case (form2Prop_app_inv _ _ _ H11); auto.
CaseEq (reduceCongCong i n a b l0).
intros n1 p; case p; clear p.
intros n2 p; case p; clear p.
intros a1 p; case p; clear p.
intros b1 ll.
intros H8; apply Cnf1_cons; auto.
apply Cnf1_app; auto.
generalize (reduceCongCong_correct i n a b (0%Z :: l) l0 H4 H5 H6).
rewrite H8; intuition.
unfold processList in |- *; lazy beta in |- *.
split.
split.
intros (m6, (H6, (H7, (H8, H'8)))).
simpl in H7; case H7; intros H9 H10.
apply form2Prop_cons.
simpl in |- *; exists m6; rewrite H9; ring.
apply form2Prop_app; auto.
apply form2Prop_app; auto.
case (reduceEqEq_correct n a b (m6 :: l) l0); simpl in |- *; auto.
intuition.
apply form2Prop_app; auto.
case (reduceEqNEq_correct n a b (m6 :: l) l3); simpl in |- *; auto.
intuition.
case (reduceEqCong_correct n a b (m6 :: l) l4); simpl in |- *; auto.
intuition.
intros H6.
case (form2Prop_cons_inv _ _ _ H6); auto.
intros H7 H8.
simpl in H7; case H7; clear H7; intros m7 H7.
exists m7; repeat split; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
rewrite H7; ring.
case (reduceEqEq_correct n a b (m7 :: l) l0); simpl in |- *; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
intros H9 H10.
case (form2Prop_app_inv _ _ _ H10); auto.
rewrite Zplus_comm; intuition.
case (reduceEqNEq_correct n a b (m7 :: l) l3); simpl in |- *; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
intros H9 H10.
case (form2Prop_app_inv _ _ _ H10); auto.
intros H11 H12.
case (form2Prop_app_inv _ _ _ H12); auto.
rewrite Zplus_comm; intuition.
case (reduceEqCong_correct n a b (m7 :: l) l4); simpl in |- *; auto.
case (form2Prop_app_inv _ _ _ H8); auto.
intros H9 H10.
case (form2Prop_app_inv _ _ _ H10); auto.
intros H11 H12.
case (form2Prop_app_inv _ _ _ H12); auto.
rewrite Zplus_comm; intuition.
case (reduceEqEq_correct n a b l l0); auto.
case (reduceEqNEq_correct n a b l l3); auto.
case (reduceEqCong_correct n a b l l4); auto.
Qed.
Require Import GroundN.

Theorem processList_groundN :
 forall n l1 l2 l3 l4,
 listEqP l2 ->
 listNEqP l3 ->
 listCongP l4 ->
 groundNL n l1 ->
 groundNL2 n l2 ->
 groundNL2 n l3 ->
 groundNL2 n l4 -> groundNL n (processList (l1, (l2, (l3, l4)))).
intros n l1 l2 l3 l4 H; inversion H; simpl in |- *.
intros H1 H2; inversion H2; auto.
intros H7 H8 H9 H10; inversion H10.
inversion H14.
cut (groundNExp n a);
 [ intros H25 | apply groundNExp_le with (n := n2); auto ].
cut (groundNExp n b);
 [ intros H26 | apply groundNExp_le with (n := m0); auto ].
generalize (reduceCongCong_groundN i n n0 a b l H5 H16 H25 H26);
 case (reduceCongCong i n0 a b l).
intros i3 p0; case p0; clear p0.
intros m3 p0; case p0; clear p0.
intros a3 p0; case p0; clear p0.
intros b3 l5 (H27, (H28, H29)).
apply GNVCons; auto.
apply GNCong with (n := n) (m := n); auto.
intros H3 H4 H5 H6 H7 H8.
inversion H6.
inversion H12.
apply GNVCons; auto.
apply GNCong with (n := n2) (m := m0); auto.
apply groundNL_app; auto.
apply groundNL_app; auto.
apply reduceEqEq_groundN; auto.
apply groundNExp_le with (n := n2); auto.
apply groundNExp_le with (n := m0); auto.
apply groundNL_app; auto.
apply reduceEqNEq_groundN; auto.
apply groundNExp_le with (n := n2); auto.
apply groundNExp_le with (n := m0); auto.
apply reduceEqCong_groundN; auto.
apply groundNExp_le with (n := n2); auto.
apply groundNExp_le with (n := m0); auto.
Qed.


From Cofq.SystemC Require Import
     SystemCDefinitions
     SystemCShow (* Need show for errors in evaluation *)
     SystemCUtils.

From Cofq.Utils Require Import Utils.
From Cofq.BaseExpressions Require Import Integers.
From Cofq.Show Require Import ShowUtils.

From Coq Require Import
     String
     List
     Lia
     ZArith.

From ExtLib Require Import
     Structures.Monads
     Structures.Functor
     Eqv.

Import MonadNotation.
Local Open Scope monad_scope.

From ITree Require Import
     Basics
     Basics.Basics
     ITree
     Interp.Recursion
     Events.Exception
     Events.StateFacts
     Events.State.

Import Basics.Basics.Monads.

From Vellvm.Utils Require Import Util.

Section Substitution.

  Fixpoint cterm_lift_raw_value {I} `{FInt I} (lift_amt : N) (n : N) (rv : CRawValue) : CRawValue :=
    match rv with
    | CNum x => CNum x
    | CVar x =>
      if N.ltb x n
      then CVar x
      else CVar (x + lift_amt)
    | CTuple es => CTuple (map (cterm_lift_value lift_amt n) es)
    | CPack t1 rv t2 => CPack t1 (cterm_lift_raw_value lift_amt n rv) t2
    | CTApp rv τ => CTApp (cterm_lift_raw_value lift_amt n rv) τ
    end
  with
  cterm_lift_value {I} `{FInt I} (lift_amt : N) (n : N) (v : CValue) : CValue :=
    match v with
    | CAnnotated rv t => CAnnotated (cterm_lift_raw_value lift_amt n rv) t
    end.

  Definition cterm_lift_declaration {I} `{FInt I} (lift_amt : N) (n : N) (dec : CDeclaration) : CDeclaration :=
    (* TODO: lift by varied amount for declarations. E.g, unpack binds value and type? *)
    match dec with
    | CVal v => CVal (cterm_lift_value lift_amt n v)
    | CProjN i v => CProjN i (cterm_lift_value lift_amt n v)
    | COp op v1 v2 => COp op (cterm_lift_value lift_amt n v1) (cterm_lift_value lift_amt n v2)
    | CUnpack rv => CUnpack (cterm_lift_raw_value lift_amt n rv)
    end.

  Fixpoint cterm_lift_term {I} `{FInt I} (lift_amt : N) (n : N) (term : CTerm) : CTerm :=
    match term with
    (* Let should always bind a single term variable *)
    | CLet d e => CLet (cterm_lift_declaration lift_amt n d) (cterm_lift_term lift_amt (n+1) e)
    | CApp v args => CApp (cterm_lift_value lift_amt n v) (map (cterm_lift_value lift_amt n) args)
    | CIf0 c e1 e2 => CIf0 (cterm_lift_value lift_amt n c) (cterm_lift_term lift_amt n e2) (cterm_lift_term lift_amt n e2)
    | CHalt v t => CHalt (cterm_lift_value lift_amt n v) t
    end.

  Definition cterm_lift_heap_value {I} `{FInt I} (lift_amt : N) (n : N) (hv : CHeapValue) : CHeapValue :=
    match hv with
    | CCode t n ts body => CCode t n ts (cterm_lift_term lift_amt n body)
    end.

  (* Each heap value in the list is bound to a type variable in order *)
  Definition cterm_lift_program {I} `{FInt I} (lift_amt : N) (n : N) (prog : CProgram) : CProgram :=
    match prog with
    | CProg hvs body =>
      CProg (map (fun '(i, hv) => cterm_lift_heap_value lift_amt (n+i) hv) (addIndices hvs)) (cterm_lift_term lift_amt (n + N.of_nat (length hvs)) body)
    end.

  Fixpoint ctype_lift (lift_amt : N) (n : N) (τ : CType) : CType :=
    match τ with
    | CTForall n_type_bindings arrows => CTForall n_type_bindings (map (ctype_lift lift_amt (n + n_type_bindings)) arrows)
    | CTExists τ => CTExists (ctype_lift lift_amt (n + 1) τ)
    | CProd τs => CProd (map (ctype_lift lift_amt n) τs)
    | CTVar x =>
      if N.ltb x n then CTVar x else CTVar (x + lift_amt)
    | CIntType => τ
    end.

  (** * Actual substitution *)

  (* Applications must be a code block applied using the CApp
     constructor to some CType and CValue arguments.

     CApp : CValue -> list CType -> list CValue -> CTerm

     Which means that the code block has to be referenced through an
     annotated CVar, as there's no other way to reference code in a
     value.

     The body of CCode is a term, so we'll have to be able to
     substitute values and types into terms.
   *)

  Fixpoint cterm_subst_raw_value {I} `{FInt I} (v : VarInd) (body arg : CRawValue) : CRawValue :=
    match body with
    | CVar x =>
      if N.eqb x v
      then arg
      else CVar x
    | CNum x => CNum x
    | CTuple es => CTuple (map (fun e => cterm_subst_value v e arg) es)
    | CPack t1 rv t2 => CPack t1 (cterm_subst_raw_value v rv arg) t2
    | CTApp rv τ => CTApp (cterm_subst_raw_value v rv arg) τ
    end
  with
  cterm_subst_value {I} `{FInt I} (v : VarInd) (body : CValue) (arg : CRawValue) : CValue :=
    match body with
    | CAnnotated rv t => CAnnotated (cterm_subst_raw_value v rv arg) t
    end.

  Definition cterm_subst_declaration {I} `{FInt I} (v : VarInd) (body : CDeclaration) (arg : CRawValue) : CDeclaration :=
    match body with
    | CVal val => CVal (cterm_subst_value v val arg)
    | CProjN i val => CProjN i (cterm_subst_value v val arg)
    | COp op v1 v2 => COp op (cterm_subst_value v v1 arg) (cterm_subst_value v v2 arg)
    | CUnpack x => CUnpack (cterm_subst_raw_value v x arg)
    end.

  Fixpoint cterm_subst_term {I} `{FInt I} (v : VarInd) (body : CTerm) (arg : CRawValue) : CTerm :=
    match body with
    | CLet dec e => (* Need to lift here *)
      CLet (cterm_subst_declaration v dec arg) (cterm_subst_term (v+1) e arg)
    | CApp f es =>
      CApp (cterm_subst_value v f arg) (map (fun e => cterm_subst_value v e arg) es)
    | CIf0 c e1 e2 =>
      CIf0 (cterm_subst_value v c arg)
           (cterm_subst_term v e1 arg)
           (cterm_subst_term v e2 arg)
    | CHalt x τ =>
      CHalt (cterm_subst_value v x arg) τ
    end.

  Obligation Tactic := try Tactics.program_simpl; try solve [cbn; try lia | repeat split; try solve [intros; discriminate]].
  Program Fixpoint ctype_subst_in_type (v : TypeInd) (τ : CType) (arg : CType) {measure (ctype_size τ)} : CType :=
    match τ with
    | CTVar x =>
      if N.eqb x v
      then arg
      else if N.ltb v x
           then CTVar (x-1)
           else CTVar x
    | CProd τs =>
      CProd (map_In τs (fun τ HIn => ctype_subst_in_type v τ arg))
    | CTForall n τs => CTForall n (map_In τs (fun τ HIn => ctype_subst_in_type (v+n) τ (ctype_lift 1 0 arg)))
    | CTExists τ => CTExists (ctype_subst_in_type (v+1) τ (ctype_lift 1 0 arg))
    | CIntType => CIntType
    end.
  Next Obligation.
    cbn.
    pose proof (list_sum_map ctype_size τ τs HIn).
    lia.
  Qed.
  Next Obligation.
    cbn.
    pose proof (list_sum_map ctype_size τ τs HIn).
    lia.
  Qed.

  Fixpoint ctype_subst_raw_value {I} `{FInt I} (v : TypeInd) (rv : CRawValue) (arg_type : CType) : CRawValue
    := match rv with
       | CTuple es =>
         CTuple (map (fun e => ctype_subst_value v e arg_type) es)
       | CPack τ1 rv τ2 =>
         CPack (ctype_subst_in_type v τ1 arg_type) rv (ctype_subst_in_type v τ2 arg_type)
       | CTApp x τ =>
         CTApp x (ctype_subst_in_type v τ arg_type)
       | CNum x => rv
       | CVar x => rv
       end
  with
  ctype_subst_value {I} `{FInt I} (v : TypeInd) (val : CValue) (arg_type : CType) : CValue
    := match val with
       | CAnnotated rv τ => CAnnotated rv (ctype_subst_in_type v τ arg_type)
       end.

  Definition ctype_subst_declaration {I} `{FInt I} (v : TypeInd) (e : CDeclaration) (arg_type : CType) : CDeclaration
    := match e with
       | CVal x =>
         CVal (ctype_subst_value v x arg_type)
       | CProjN i e =>
         CProjN i (ctype_subst_value v e arg_type)
       | COp op e1 e2 =>
         COp op (ctype_subst_value v e1 arg_type) (ctype_subst_value v e2 arg_type)
       | CUnpack x =>
         CUnpack (ctype_subst_raw_value v x arg_type)
       end.

  Fixpoint ctype_subst_term {I} `{FInt I} (v : TypeInd) (e : CTerm) (arg_type : CType) : CTerm
    := match e with
         (* Unpack binds a type variable and a term variable *)
       | CLet (CUnpack x) e =>
         CLet (ctype_subst_declaration v (CUnpack x) arg_type) (ctype_subst_term (v+1) e arg_type)
       | CLet dec e =>
         CLet (ctype_subst_declaration v dec arg_type) (ctype_subst_term v e arg_type)
       | CApp f vs =>
         CApp (ctype_subst_value v f arg_type) (map (fun e => ctype_subst_value v e arg_type) vs)
       | CIf0 c e1 e2 =>
         CIf0 (ctype_subst_value v c arg_type)
              (ctype_subst_term v e1 arg_type)
              (ctype_subst_term v e2 arg_type)
       | CHalt x τ =>
         CHalt (ctype_subst_value v x arg_type) (ctype_subst_in_type v τ arg_type)
       end.
End Substitution.

(** Denotation of SystemC in terms of itrees. *)
Section Denotation.
Set Implicit Arguments.
Set Contextual Implicit.
  Definition Failure := exceptE string.

  Definition cv_to_rv {I} `{FInt I} (val : CValue) : CRawValue
    := match val with
       | CAnnotated rv τ => rv
       end.

  Open Scope string_scope.
  Definition ceval_declaration {I} `{FInt I} `{Show I} (dec : CDeclaration) : itree Failure ((CType * CRawValue) + CRawValue)
    := match dec with
       | CVal x =>
         ret (inr (cv_to_rv x))
       | CProjN i v =>
         match cv_to_rv v with
         | CTuple vs =>
           match nth_error vs (N.to_nat i) with
           | Some e => ret (inr (cv_to_rv e))
           | None => throw ("Tuple projection out of bounds: " ++ show dec)
           end
         | _ =>
           throw ("Ill-typed projection: " ++ show dec)
         end
       | COp op e1 e2 =>
         match cv_to_rv e1, cv_to_rv e2 with
         | CNum x, CNum y =>
           ret (inr (CNum (eval_op op x y)))
         | _, _ =>
           throw ("Ill-typed operation: " ++ show dec)
         end
       | CUnpack x =>
         (* TODO: not sure about variables... *)
         match x with
         | CPack τ1 e τ2 => ret (inl (τ1, e))
         | _ => throw ("Ill-typed unpack: " ++ show dec)
         end
       end.

  Variant CodeE {I} `{FInt I} : Type -> Type :=
  | CodeLookup  (id: VarInd): CodeE CHeapValue.

  Notation TermE := (callE CTerm CRawValue +' (CodeE +' Failure)).
  Notation ProgE := Failure.

  Definition fail_to_TermE {I} `{FInt I} : Failure ~> TermE :=
    fun T f => inr1 (inr1 f).

  Definition ceval_declaration' {I} `{FInt I} `{Show I} (dec : CDeclaration) : itree TermE ((CType * CRawValue) + CRawValue) :=
    translate fail_to_TermE (ceval_declaration dec).

  Definition apply_args {I} `{FInt I} (e : CTerm) (args : list CValue) : CTerm
    := fold_left (fun body '(i, arg) => cterm_subst_term i body (cv_to_rv arg)) (addIndices' 1 args) e.

  Definition eval_app {I} `{FInt I} (e : CTerm) (x : VarInd) (args : list CValue) : itree TermE CRawValue
    := let body := cterm_subst_term 0 e (CVar x)
       in call (apply_args body args).

  Definition eval_app_type {I} `{FInt I} (e : CTerm) (x : VarInd) (τ : CType) (args : list CValue) : itree TermE CRawValue
    := let body := cterm_subst_term 0 (ctype_subst_term 0 e τ) (CVar x)
       in call (apply_args body args).

  Definition raise {E} {A} `{Failure -< E} (msg : string) : itree E A :=
    v <- trigger (Throw msg);; match v: void with end.

  Definition ceval_term {I} `{FI: FInt I} `{Show I} (e : CTerm) : itree TermE CRawValue
    := match e with
       | CHalt v τ =>
         ret (cv_to_rv v)
       | CLet dec body =>
         d <- ceval_declaration' dec;;
         match d with
         | inl (τ, dv) =>
           call (ctype_subst_term 0 (cterm_subst_term 0 body dv) τ)
         | inr dv =>
           call (cterm_subst_term 0 body dv)
         end
       | CApp f args =>
         match cv_to_rv f with
         | CVar x =>
           hv <- trigger (CodeLookup x);;
           match hv with
           | CCode τ n arg_τs body =>
             (* TODO: should we do something about a lack of type applications? *)
             if Nat.eqb (length args) (length arg_τs)
             then eval_app body x args
             else raise ("Not enough arguments to application: " ++ show e)
           end
         | _ => raise "unimplemented"
         end
       | CIf0 c e1 e2 =>
         match cv_to_rv c with
         | CNum x =>
           if eq x zero
           then call e1
           else call e2
         | _ =>
           raise ("Conditional not a number: " ++ show e)
         end
       end.

  Definition ceval_term_loop {I} `{FI: FInt I} `{Show I} (e : CTerm) : itree (CodeE +' Failure) CRawValue
    := rec ceval_term e.

  (* TODO: should we use readerT? *)
  Definition handle_code {I} `{FInt I} {E} `{Failure -< E} : CodeE ~> stateT (list CHeapValue) (itree E) :=
    fun _ e s =>
      match e with
      | CodeLookup id =>
        match nth_error s (N.to_nat id) with
        | Some hv => ret (s, hv)
        | None => raise ("Could not find heap value: " ++ show id)
        end
      end.

  Section Itrees.
  (* TODO: move to itrees? *)
  Instance Functor_readerT {m s} {Fm : Functor m} : Functor (readerT s m)
    := {|
    fmap _ _ f := fun run s => fmap f (run s)
      |}.

  Instance Monad_readerT {m s} {Fm : Monad m} : Monad (readerT s m)
    := {|
    ret _ a := fun s => ret a
    ; bind _ _ t k := fun s =>
                        sa <- t s ;;
                        k sa s
      |}.
  End Itrees.

  Arguments interp_state {E M S FM MM IM} h [T].

  Section PARAMS.
    Variable (F : Type -> Type).
    Context `{Failure -< F}.
    Notation Effin := (CodeE +' F).
    Notation Effout := (F).

    Definition F_trigger {I} `{FInt I} {M} : forall R, F R -> (stateT M (itree Effout) R) :=
      fun R e m => r <- trigger e ;; ret (m, r).

    Definition interp_code_h {I} `{FInt I} := case_ handle_code F_trigger.
    Definition interp_code {I} `{FInt I} :
      itree Effin ~> stateT (list CHeapValue) (itree Effout) :=
      interp_state interp_code_h.
  End PARAMS.

  Definition ceval_program {I} `{FI: FInt I} `{Show I} (p : CProgram) : itree Failure CRawValue
    := match p with
       | CProg defs body =>
         '(_, rv) <- interp_code (ceval_term_loop body) defs;;
         ret rv
       end.
End Denotation.


(*In this file, we verify the additional function hmac2, that we added to the c file
  in order to exercise the reuse of a key for several messages. The function calls
  hmac twice, (on the same message, using the same key) and puts the resulting
  (identical) digests side by side in a suitably large array.*)

Require Import floyd.proofauto.
Import ListNotations.
Require sha.sha.
Require Import sha.SHA256.
Local Open Scope logic.

Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC256_functional_prog.

Require Import sha.hmac.

Require Import sha.spec_hmac.
Require Import sha.vst_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.hmac_common_lemmas.

Definition HMAC_Double_spec :=
  DECLARE _HMAC
   WITH keyVal: val, KEY:DATA,
        msgVal: val, MSG:DATA,
        kv:val, shmd: share, md: val
   PRE [ _key OF tptr tuchar,
         _key_len OF tint,
         _d OF tptr tuchar,
         _n OF tint,
         _md OF tptr tuchar ]
         PROP (writable_share shmd;
               has_lengthK (LEN KEY) (CONT KEY);
               has_lengthD 512 (LEN MSG) (CONT MSG))
         LOCAL (temp _md md; temp _key keyVal;
                temp _key_len (Vint (Int.repr (LEN KEY)));
                temp _d msgVal;
                temp _n (Vint (Int.repr (LEN MSG)));
                gvar sha._K256 kv)
         SEP(data_block Tsh (CONT KEY) keyVal;
             data_block Tsh (CONT MSG) msgVal;
             K_vector kv;
             memory_block shmd 64 md)
  POST [ tptr tuchar ]
         EX digest:_,
          PROP (digest = HMAC256 (CONT MSG) (CONT KEY))
          LOCAL (temp ret_temp md)
          SEP(K_vector kv;
              data_block shmd (digest++digest) md;
              initPostKey keyVal (CONT KEY);
              data_block Tsh (CONT MSG) msgVal).

Definition n324 := 324%Z.
Opaque n324.

Lemma body_hmac_double: semax_body HmacVarSpecs HmacFunSpecs
      f_HMAC2 HMAC_Double_spec.
Proof.
start_function.
name key' _key.
name keylen' _key_len.
name d' _d.
name n' _n.
name md' _md.
rename lvar0 into c.
rename keyVal into k. rename msgVal into d.
destruct KEY as [kl key].
destruct MSG as [dl data]. simpl in *.
rewrite memory_block_isptr. normalize.
rename H into KL. rename H0 into DL.

forward_if  (
  PROP  (isptr c)
   LOCAL  (lvar _c t_struct_hmac_ctx_st c; temp _md md; temp _key k;
   temp _key_len (Vint (Int.repr kl)); temp _d d;
   temp _n (Vint (Int.repr dl)); gvar sha._K256 kv)
   SEP  (data_at_ Tsh t_struct_hmac_ctx_st c; data_block Tsh key k;
   data_block Tsh data d; K_vector kv;
   memory_block shmd 64 md)).
  { apply denote_tc_test_eq_split.
       apply sepcon_valid_pointer2. apply memory_block_valid_ptr. auto. omega.
       apply valid_pointer_zero. }
  { (* Branch1 *) exfalso. subst md. contradiction.  }
  { (* Branch2 *) forward. entailer. }
normalize.
assert_PROP (isptr k).
{ unfold data_block. normalize. rewrite data_at_isptr with (p:=k). entailer. } (*Issue: used to be solved just by entailer *)
rename H into Pk.
forward_call (c, k, kl, key, kv, HMACabs nil nil nil).
  { unfold initPre.
    destruct k; try contradiction.
    entailer!.
  }

assert_PROP (s256a_len (absCtxt (hmacInit key)) = 512) as H0_len512.
  { unfold hmacstate_. Intros r. apply prop_right. apply H. }
remember (hmacInit key) as h0.
forward_call (h0, c, d, dl, data, kv).
  { rewrite H0_len512. assumption. }
apply isptrD in Pmd. destruct Pmd as [b [i Pmd]]. rewrite Pmd in *.
assert (GTmod64: 64 < Int.modulus).
  rewrite <- initialize.max_unsigned_modulus, int_max_unsigned_eq. omega.
specialize (memory_block_size_compatible shmd (tarray tuint 16)). simpl; intros.
rewrite H (*_ GTmod64)*); clear H.
normalize. unfold size_compatible in H. simpl in H; rename H into SizeCompat64.
specialize (memory_block_split shmd b (Int.unsigned i) 32 32); intros XX.
  rewrite Int.repr_unsigned in XX.
  assert (32 + 32 = 64) by omega. rewrite H in XX; clear H.
  rewrite XX; trivial; clear XX.
2: destruct (Int.unsigned_range i); omega.
clear GTmod64.
flatten_sepcon_in_SEP.

forward_call (hmacUpdate data h0, c, Vptr b i, shmd, kv).
simpl.

(**************Round 2*******************************)
remember (hmacFinal (hmacUpdate data h0)) as RND1.
destruct RND1 as [h2 dig].
replace_SEP 1 (initPre c nullval h2 kl key).
  { entailer!. eapply hmacstate_PostFinal_PreInitNull.
    symmetry in HeqRND1. apply HeqRND1. }
forward_call (c, nullval, kl, key, kv, h2).
simpl; normalize.

assert_PROP (s256a_len (absCtxt (hmacInit key)) = 512).
  { unfold hmacstate_. entailer!. }
rename H into H3_len512.
forward_call (hmacInit key, c, d, dl, data, kv).
  { rewrite H3_len512. assumption. }

assert_PROP (field_compatible (Tstruct _hmac_ctx_st noattr) [] c)
  as FC_c by (unfold hmacstate_; Intros r;  entailer!).
forward_call (hmacUpdate data (hmacInit key), c, Vptr b (Int.repr (Int.unsigned i + 32)), shmd, kv).
remember (hmacFinal (hmacUpdate data (hmacInit key))) as RND2.
destruct RND2 as [h5 dig2].
simpl.

forward_call (h5,c).
match goal with |- context [data_block  Tsh ?A c] =>
  change A with (list_repeat (Z.to_nat n324) 0)
end.

forward.
clear H2.
pose proof (HMAC_Zlength data key).
rewrite <- (hmac_sound key data) in *. unfold hmac in *.
rewrite <- HeqRND2 in HeqRND1. inv HeqRND1.
rewrite <- HeqRND2 in *. simpl in *.
Exists c dig2.
unfold data_block at 1. simpl. entailer!.
rewrite <- memory_block_data_at_ by auto.
change (sizeof (Tstruct _hmac_ctx_st noattr))
   with (sizeof (tarray tuchar (Zlength (list_repeat (Z.to_nat n324) 0)))).
rewrite memory_block_data_at_ by auto.
cancel.

assert (FC_b: field_compatible (Tarray tuchar 64 noattr) [] (Vptr b i)).
  red. intuition. apply Z.divide_1_l.

rewrite (split2_data_block 32 _ (dig2 ++ dig2))
 by (autorewrite with sublist; omega).
autorewrite with sublist.
cancel.
apply derives_refl'.
  f_equal.
  rewrite field_address0_offset  by auto with field_compatible.
  reflexivity.
Qed.


Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.ExprVariables.
Require Import MirrorCore.Lambda.ExprTac.
Require Import MirrorCore.Lambda.Rtac.
Require Import McExamples.Hoare.Imp.
Require Import McExamples.Hoare.ILogicFunc.

Set Universe Polymorphism.
Set Printing Universes.

Section parametric.
  Context {typ func : Set}.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Typ2_RFun : Typ2 RType_typ RFun}.
  Context {Typ2Ok_RFun : Typ2Ok Typ2_RFun}.
  Context {Typ0_Prop : Typ0 RType_typ Prop}.
  Context {Typ0Ok_Prop : Typ0Ok Typ0_Prop}.
  Context {RSym_func : RSym func}.
  Context {RSymOk_func : RSymOk RSym_func}.

  Context {FV : PartialView func (ilfunc typ)}.
  Variable ilo : @logic_ops  _ _.
  Variable eo : @embed_ops  _ _.
  Context {iloOk : logic_opsOk ilo}.
  Context {FVO : FuncViewOk FV RSym_func (RSym_ilfunc (RelDec_eq_typ) ilo eo _ _) }.

  Context {ilo_Prop : ilo (typ0 (F:=Prop)) =
                      lSome match eq_sym (typ0_cast (F:=Prop)) in _ = X
                                  return ILogic.ILogicOps X with
                            | eq_refl => ILogic.ILogicOps_Prop
                            end}.

  Definition bin_op {T U V W : Type} (f : T -> U -> V -> W)
             (t : ptrn func T) (l : ptrn (expr typ func) U) (r : ptrn (expr typ func) V)
  : ptrn (expr typ func) W :=
    appl (appl (inj t) (pmap (fun t x => (x,t)) l))
         (pmap (fun v tx => let '(t,x) := tx in f t x v) r).

  Instance ptrn_ok_bin_op : ltac:(PtrnOk @bin_op) := _.

  Definition ptrn_entails@{A X P} {T U V : Type@{A}}
             (t : ptrn@{Set A X P} typ V)
             (a : ptrn@{Set A X P} (expr typ func) (V -> T))
             (b : ptrn@{Set A X P} (expr typ func) (T -> U))
  : ptrn@{Set A X P} (expr typ func) U :=
    appl (appl (inj (ptrn_view _ (fptrn_lentails@{A X P} t))) a) b.

  Instance ptrn_entails_ok : ltac:(PtrnOk @ptrn_entails) := _.

  Definition intro_ptrn_all : ptrn (expr typ func) (OpenAs typ (expr typ func))
  :=
    por
      (appl (inj (ptrn_view FV (fptrn_lforall get (fun t => pmap (fun _ => t) ignore))))
            (pmap (fun body t => SimpleOpen_to_OpenAs (sAsAl t body)) get))
      (ptrn_entails get (pmap (fun G t => (G,t)) get)
                    (appl (inj (ptrn_view FV (fptrn_lforall get (fun t => pmap (fun _ => t) ignore))))
                          (pmap (fun body t Gt =>
                                   let '(G,l) := Gt in
                                   AsAl t (fun arg =>
                                             App (App (Inj (f_insert (ilf_entails l))) G)
                                                 (Red.beta (App body arg)))) get))).

  Definition intro_ptrn_hyp : ptrn (expr typ func) (OpenAs typ (expr typ func))
  :=
    bin_op (fun _ P Q => AsHy P Q)
           (ptrn_view _ (fptrn_limpl ignore)) get get.

  Local Existing Instance RSym_ilfunc.
  Local Existing Instance RSym_func.
  Local Existing Instance RType_typ.

  Theorem Succeeds_bin_op {T U V W : Type} f t l r e res
  : ptrn_ok t -> ptrn_ok l -> ptrn_ok r ->
    Succeeds e (@bin_op T U V W f t l r) res ->
    exists ef el er rf rl rr,
      e = App (App (Inj ef) el) er /\
      res = f rf rl rr /\
      Succeeds ef t rf /\
      Succeeds el l rl /\
      Succeeds er r rr.
  Proof.
    unfold bin_op. intros. ptrn_elim; subst.
    do 6 eexists.
    repeat (split; [ reflexivity | ]); auto.
  Qed.

  Theorem Succeeds_ptrn_entails@{A X P} {T U V : Type@{A}}
          (e : expr typ func) (t : ptrn@{Set A X P} _ _) (a : ptrn@{Set A X P} _ _) (b : ptrn@{Set A X P} _ _) r
  : ptrn_ok@{Set A X P} a -> ptrn_ok@{Set A X P} b -> ptrn_ok@{Set A X P} t ->
    Succeeds@{Set A X P} e (@ptrn_entails@{A X P} T U V t a b) r ->
    exists te ta tb tr ar br,
      e = App (App (Inj (f_insert (ilf_entails te))) ta) tb /\
      r = br (ar tr) /\
      Succeeds@{Set A X P} te t tr /\
      Succeeds@{Set A X P} ta a ar /\
      Succeeds@{Set A X P} tb b br.
  Proof.
    unfold ptrn_entails. intros.
    ptrn_elim; subst.
    do 6 eexists; split; eauto.
  Qed.

  Let Expr_expr := @Expr_expr _ _ RType_typ _ RSym_func.
  Local Existing Instance Expr_expr.
  Let ExprOk_expr : ExprOk Expr_expr :=
    @ExprOk_expr _ _ RType_typ _ RSym_func _ _ _.
  Local Existing Instance ExprOk_expr.

  Local Opaque Red.beta.

  Hint Opaque pmap appl appr inj ptrn_view get ignore : typeclass_instances.

  Theorem intro_ptrn_hyp_sound : open_ptrn_sound intro_ptrn_hyp.
  Proof.
    red; intros.
    unfold intro_ptrn_hyp in H.
    eapply Succeeds_bin_op in H; eauto with typeclass_instances.
    forward_reason. subst.
    ptrn_elim; subst.
    red.
    unfold propD, exprD_typ0.
    red_exprD. intros.
    forwardy; inv_all; subst.
    assert (x = typ0 (F:=Prop) /\ x2 = typ0 (F:=Prop) /\ x6 = typ0 (F:=Prop)).
    { unfold symAs in H; simpl in H.
      destruct (ilo x6); try congruence.
      forwardy. clear H0 H.
      apply typ2_inj in y; eauto; destruct y.
      apply typ2_inj in H0; eauto; destruct H0.
      unfold Rty in *. subst. clear. tauto. }
    destruct H0 as [ ? [ ? ? ] ]; subst.
    rewrite H2. rewrite H1.
    do 2 eexists; split; [ reflexivity | split; [ reflexivity | ] ].
    clear H2 H1.
    unfold symAs in H; simpl in H.
    rewrite ilo_Prop in H.
    rewrite type_cast_refl in H; eauto.
    inv_all; subst.
    simpl.
    unfold AbsAppI.exprT_App, typ2_cast_bin.
    clear ilo_Prop.
    generalize (typ0_cast (F:=Prop)).
    generalize (typ2_cast (typ0 (F:=Prop)) (typ0 (F:=Prop))).
    generalize (typ2_cast (typ0 (F:=Prop))
                    (typ2 (typ0 (F:=Prop)) (typ0 (F:=Prop)))).
    generalize dependent (typD (typ0 (F:=Prop))).
    generalize dependent (typD (typ2 (typ0 (F:=Prop)) (typ0 (F:=Prop)))).
    generalize dependent (typD
            (typ2 (typ0 (F:=Prop)) (typ2 (typ0 (F:=Prop)) (typ0 (F:=Prop))))).
    do 8 intro; subst. simpl.
    clear. tauto.
  Qed.

  Theorem intro_ptrn_all_sound : open_ptrn_sound intro_ptrn_all.
  Proof.
    red. intros.
    unfold intro_ptrn_all in H.
    eapply Succeeds_por in H; eauto 100 with typeclass_instances.
    destruct H.
    - ptrn_elim; subst.
      eapply SimpleOpen_to_OpenAs_sound; eauto.
      simpl. unfold propD, exprD_typ0. simpl. intros.
      forwardy.
      inv_all. subst.
      unfold symAs in H. simpl in H.
      forward. inv_all; subst.
      destruct (decompose_Rty_typ2 _ _ r) as [ ? [ ? ? ] ].
      subst.
      destruct x2.
      red in x0. subst x.
      eexists; split; eauto.
      intros.
      simpl.
      specialize (iloOk (typ0 (F:=Prop))).
      rewrite H in *; clear H.
      inversion ilo_Prop; clear ilo_Prop; subst.
      revert iloOk.
      clear - H2.
      revert H2.
      unfold typ2_cast_quant, castD in *. simpl.
      generalize dependent (typ0_cast (F:=Prop)).
      generalize dependent (typ0 (F:=Prop)).
      intro.
      generalize dependent (typ2_cast x7 t).
      unfold AbsAppI.exprT_App, exprT_Inj.
      generalize dependent (typ2_cast (typ2 x7 t) t).
      generalize dependent (typD (typ2 x7 t)).
      generalize dependent (typD t).
      generalize dependent (typD (typ2 (typ2 x7 t) t)).
      intros; subst; simpl in *. auto.
    - ptrn_elim; subst.
      simpl.
      unfold propD, exprD_typ0. simpl.
      intros.
      forwardy; inv_all; subst.
      assert (x2 = typ2 x19 x18 /\ x = x18 /\ x7 = x4 /\ x = x4).
      { clear - H H3 RTypeOk_typ Typ2Ok_RFun.
        unfold symAs in *.
        simpl in *.
        destruct (ilo x18); try congruence.
        destruct (ilo x4); try congruence.
        forwardy. clear H2 H1 H H0.
        apply typ2_inj in y; eauto.
        eapply typ2_inj in y0; eauto.
        destruct y; destruct y0.
        eapply typ2_inj in H2; eauto.
        unfold Rty in *. destruct H2.
        tauto. }
      destruct H2 as [ ? [ ? [ ? ? ] ] ]; subst. subst.
      eapply exprD_weakenV with (Expr_expr:=Expr_expr)(tvs':=x19::nil) in H6; eauto.
      eapply exprD_weakenV with (Expr_expr:=Expr_expr)(tvs':=x19::nil) in H4; eauto.
      forward_reason.
      erewrite ExprTac.lambda_exprD_AppL; eauto.
      Focus 2.
      erewrite ExprTac.lambda_exprD_AppR; eauto.
      red_exprD.
      rewrite <- (@fv_compat _ _ _ _ _ _ _ FVO).
      rewrite H. reflexivity.
      generalize (Red.beta_sound tus (tvs ++ x19 :: nil) (App x21 e') x4).
      erewrite lambda_exprD_App_both_cases; eauto.
      intros; forwardy.
      rewrite H7. eexists; split; [ reflexivity | ].
      intros.
      unfold symAs in H, H3. simpl in H, H3.
      destruct (ilo x4) eqn:Hilo; try congruence.
      specialize (iloOk x4).
      rewrite Hilo in iloOk.
      rewrite type_cast_refl in *; eauto.
      inv_all; subst.
      simpl in *.
      generalize (H6 us vs); clear H6.
      generalize (H5 us vs); clear H5.
      generalize (H8 us); clear H8.
      revert H9.
      unfold AbsAppI.exprT_App.
      clear H7 H2 H4 H0.
      unfold typ2_cast_quant.
      generalize (typ0_cast (F:=Prop)).
      generalize (typ2_cast x4 (typ2 x4 (typ0 (F:=Prop)))).
      generalize (typ2_cast x4 (typ0 (F:=Prop))).
      generalize (typ2_cast x19 x4).
      generalize (typ2_cast (typ2 x19 x4) x4).
      clear ilo_Prop.
      repeat match goal with
             | |- context [ @eq Type ?X _ ] => generalize dependent X
             end.
      do 12 intro; subst; simpl.
      intros.
      eapply ILogic.lforallR.
      intros.
      rewrite (H2 (HList.Hcons x1 HList.Hnil)); clear H2.
      rewrite (H0 (HList.Hcons x1 HList.Hnil)); clear H0.
      specialize (H (HList.hlist_app vs (HList.Hcons x1 HList.Hnil))).
      specialize (H9 x1).
      rewrite H1 in *.
      rewrite H. assumption.
  Qed.

  Definition INTRO_all : rtac typ (expr typ func) :=
    INTRO_ptrn intro_ptrn_all.

  Instance RtacSound_INTRO_all : RtacSound INTRO_all.
  Proof.
    eapply INTRO_ptrn_sound; eauto.
    - eauto 100 with typeclass_instances.
    - eapply intro_ptrn_all_sound.
  Qed.

  Definition INTRO_hyp : rtac typ (expr typ func) :=
    INTRO_ptrn intro_ptrn_hyp.

  Instance RtacSound_INTRO_hyp : RtacSound INTRO_hyp.
  Proof.
    unfold INTRO_hyp.
    unfold Expr_expr.
    eapply INTRO_ptrn_sound; eauto.
    - eauto with typeclass_instances.
    - eapply intro_ptrn_hyp_sound.
  Qed.

End parametric.


Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.LemmaApply.
Require Import MirrorCore.UnifyI.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.Reduce.
Require Import MirrorCore.RTac.EApply.

Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Variable typ : Set.
  Variable expr : Set.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.
  Context {ExprUVar_expr : ExprUVar expr}.
  Context {ExprUVarOk_expr : ExprUVarOk _}.

  Variable exprUnify : forall subst, Subst subst expr -> SubstUpdate subst expr ->
    unifier typ expr subst.

  Variable exprUnify_sound
  : forall subst (S : Subst subst expr) (SO : SubstOk subst typ expr) SU (SUO : SubstUpdateOk subst typ expr),
      unify_sound (@exprUnify subst S SU).

  Variable lem : Lemma.lemma typ expr expr.

  Definition APPLY : rtac typ expr :=
    (** TODO(gmalecha): This can be more efficient because APPLY is not supposed
     ** to introduce new unification variables
     **)
    @EAPPLY typ expr _ _ _ _ exprUnify lem.

  Hypothesis lemD : ReifiedLemma lem.

  Theorem APPLY_sound : rtac_sound APPLY.
  Proof.
    eapply EAPPLY_sound; eauto.
  Qed.

End parameterized.

Hint Opaque APPLY : typeclass_instances.

Arguments APPLY {typ expr _ _ _ _} unify lem _ _ _ : rename.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal10.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_2  := ( Cons Zero         (Cons (Succ (Succ Zero))            (Cons (Succ Zero)               (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))))).
Definition lfind_example_3  := ( Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_4  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_5  := ( Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) Nil).
Definition lfind_example_6  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_7  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_8  := ( Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)).
Definition lfind_example_9  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_10  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_11  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_12  := ( Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_13  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_14  := ( Cons Zero         (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)))).
Definition lfind_example_15  := ( Cons (Succ Zero) Nil).
Definition lfind_example_16  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_17  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_18  := ( Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero Nil)).
Definition lfind_example_19  := ( Cons (Succ (Succ Zero))         (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil))).
Definition lfind_example_20  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal10_theorem0_65_rev_append/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 .