(** * Tests of the small step semantics and typing rules defined in LDEF.  *)

(** This file contains Pierce's examples taken from Stlc.v. *)

Load Init.
Require Export LDef.
Import LDef.

(** *** Definitions *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)
(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x)))
      ==>* (\x:Bool. x)
i.e.
  (idBB (idBB idB)) ==>* idB.
*)

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) (\x:Bool. if x then false
                              else true)) true)
      ==>* false
i.e.
  ((idBB notB) ttrue) ==>* tfalse.
*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:
((\x:Bool -> Bool. x) ((\x:Bool. if x then false
                               else true) true))
      ==>* false
i.e.
  (idBB (notB ttrue)) ==>* tfalse.
*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** A more automatic proof using [normalize] as defined in LDef.v *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

(* Exercise: 2 stars (step_example3)  *)
(* Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof. (* FILLED IN  *)
(*
  eapply multi_step; eauto; try instantiate; simpl.
  eapply multi_step; eauto; try instantiate; simpl.
  apply multi_refl.
*)
  repeat (eapply multi_step; eauto; try instantiate; simpl; try apply multi_refl).
  (* In this file, coq infinitie-looped without the final try. *)
Qed.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  empty |-- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  empty |-- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:
     empty |-- \x:A. \y:A->A. y (y x))
           \in A -> (A->A) -> A.
*)

Example typing_example_2 :
  empty |--
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using lookup_add_vdecl_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** (Exerice) The same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  empty |--
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILLED IN *)
  apply T_Abs.
  apply T_Abs.
  apply T_App with (T1:=TBool). apply T_Var. apply lookup_add_vdecl_eq.
  apply T_App with TBool. apply T_Var. apply lookup_add_vdecl_eq.
  apply T_Var. apply lookup_add_vdecl_neq. unfold not. intro HP. inversion HP.
Qed.
(* Why is not "apply lookup_add_vdecl_eq" needed in the last line? *)
(* As discovered below, "reflexivity" can be used after "apply T_Var".
    I leave this as a way to deal with contexts that are not gound. *)
(** [] *)

(*
Lemma extend_neq' : forall A (ctxt: partial_map A) x1 T2 x2 R,
  x2 <> x1 ->
  ctxt x1 = R ->
  (extend ctxt x2 T2) x1 = R.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.
*)

Example typing_example_2_full' :
  forall (ctxt : context),
  ctxt |--
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* DONE OVER *)
  intro.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (T1:=TBool). apply T_Var. apply lookup_add_vdecl_eq.
  apply T_App with TBool. apply T_Var. reflexivity. (* it DOES work. *)
  apply T_Var. apply lookup_add_vdecl_neq. discriminate.
Qed.

(** **** Exercise: 2 stars (typing_example_3)  *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |-- \x:Bool->B. \y:Bool->Bool. \z:Bool.
               y (x z)
         \in T.
*)

Example typing_example_3 :
  exists T,
    empty |--
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  (* FILLED IN *)
  eexists.
  eapply T_Abs.
  eapply T_Abs.
  eapply T_Abs.
  eapply T_App. apply T_Var. reflexivity.
  eapply T_App. apply T_Var. reflexivity.
  apply T_Var. reflexivity.
Qed.

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |-- \x:Bool. \y:Bool, x y : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |--
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc as [T].
  clear Hc. (* Added this and "as" above *)
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  (* rewrite lookup_add_vdecl_neq in H1. rewrite lookup_add_vdecl_eq in H1. *)
  inversion H1.  Qed.

(** (Exercie) Another nonexample:
    ~ (exists S, exists T,
          empty |-- \x:S. x x : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |--
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  (* FILLED IN *)
  intros Hc. inversion Hc as [S [T H1]]. clear Hc.
  inversion H1; subst; clear H1.
  inversion H5; subst; clear H5.
  inversion H2; subst; clear H2.
  inversion H4; subst; clear H4.
  rewrite H1 in H2. inversion H2. clear H1 H2.
  induction T1; inversion H0.
    apply IHT1_1. rewrite H2. apply H1.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (Succ (plus lv1 lv0))).
Admitted.
QuickChick conj13eqsynthconj2.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal80.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_2  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_3  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_4  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_5  := ( Cons (Succ Zero) Nil).
Definition lfind_example_6  := ( Cons Zero         (Cons (Succ (Succ (Succ Zero)))            (Cons (Succ (Succ (Succ (Succ Zero)))) Nil))).
Definition lfind_example_7  := ( Cons Zero Nil).
Definition lfind_example_8  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_9  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_10  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_11  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal80_theorem0_58_append_nil/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 .


Require Import OrderedType OrderedTypeEx.
Import ListNotations.

Inductive Paren :=
| paren_end
| paren_nop (p: Paren)
| paren (inner p: Paren).

Function paren_append (p1 p2: Paren) :=
  match p1 with
  | paren_end => p2
  | paren_nop p' => paren_nop (paren_append p' p2)
  | paren inner p' => paren inner (paren_append p' p2)
  end.

Inductive ParenNode :=
| pnode_open
| pnode_nop
| pnode_close.

Function print_paren (p: Paren): list ParenNode :=
  match p with
  | paren_end => []
  | paren_nop p' => pnode_nop :: (print_paren p')
  | paren inner p' => [pnode_open] ++ (print_paren inner) ++ [pnode_close]
                                   ++ (print_paren p')
  end.

Inductive ParenParseState :=
| ok (next: Paren) (stack: list Paren)
| error.

Definition parse_init := ok paren_end [].

Function parse_paren_state (init_state: ParenParseState)
         (ps: list ParenNode): ParenParseState :=
  match ps with
  | [] => init_state
  | hd :: tl =>
    match parse_paren_state init_state tl with
    | error => error
    | ok cur stack =>
      match hd with
      | pnode_nop => ok (paren_nop cur) stack
      | pnode_close => ok paren_end (cur :: stack)
      | pnode_open =>
        match stack with
        | [] => error
        | next :: stack' => ok (paren cur next) stack'
        end
      end
    end
  end.

Function parse_paren (ps: list ParenNode): option Paren :=
  match parse_paren_state parse_init ps with
  | error => None
  | ok p (_ :: _) => None
  | ok p [] => Some p
  end.

Example paren_print_parse_end:
  parse_paren (print_paren paren_end) = Some paren_end.
auto. Qed.

Example paren_print_parse_nop:
  parse_paren (print_paren (paren_nop paren_end)) = Some (paren_nop paren_end).
auto. Qed.

Example paren_print_parse_nesting:
  let prog := (paren
                 (paren (paren_nop paren_end) paren_end)
                 (paren paren_end paren_end)) in
  parse_paren (print_paren prog) = Some prog.
auto. Qed.

Lemma paren_parse_app (state: ParenParseState) (str1 str2: list ParenNode):
  parse_paren_state state (str1 ++ str2) =
  parse_paren_state (parse_paren_state state str2) str1.
Proof.
  revert state str2.
  induction str1; intros; auto.
  rewrite <- app_comm_cons.
  rewrite parse_paren_state_equation.
  symmetry.
  rewrite parse_paren_state_equation.
  now rewrite <- IHstr1.
Qed.

Lemma paren_print_parse_paren (p: Paren):
  parse_paren_state parse_init (print_paren p) = ok p [] ->
  parse_paren_state parse_init (pnode_open :: (print_paren p) ++ [pnode_close])
  = ok (paren p paren_end) [].
Proof.
  intros; simpl in *.
  rewrite paren_parse_app.
  simpl in *.
  induction (print_paren p).
  - simpl in *.
    unfold parse_init in *.
    now replace p with paren_end in * by congruence.
  - destruct a; simpl in *.
    + destruct (parse_paren_state parse_init l).
      * destruct stack; try discriminate.
Admitted.

Lemma paren_print_parse_app (s1 s2: list ParenNode) (p1 p2: Paren)
      (stack: list Paren):
  parse_paren_state parse_init (s1) = ok p1 [] ->
  parse_paren_state parse_init (s2) = ok p2 [] ->
  parse_paren_state parse_init (s1 ++ s2) =
  ok (paren_append p1 p2) stack.
Proof.
  intros.
  rewrite paren_parse_app.
  rewrite H0; clear H0.
  revert p1 H p2 stack.
  induction s1; intros.
Admitted.

Lemma paren_print_parse_parens (p1 p2: Paren):
    parse_paren_state parse_init (print_paren p1) = ok p1 [] ->
    parse_paren_state parse_init (print_paren p2) = ok p2 [] ->
    parse_paren_state parse_init (pnode_open :: (print_paren p1) ++ [pnode_close]
                                  ++ (print_paren p2))
    = ok (paren p1 p2) [].
Proof.
  intros.
  rewrite app_assoc.
  rewrite app_comm_cons.
  replace (paren p1 p2) with (paren_append (paren p1 paren_end) p2) by auto.
  apply paren_print_parse_app; auto.
  apply paren_print_parse_paren; auto.
Qed.

Lemma paren_print_parse_state_inverse (p: Paren):
  parse_paren_state parse_init (print_paren p) = ok p [].
Proof.
  induction p; unfold parse_init in *;
    rewrite print_paren_equation, parse_paren_state_equation;
    [| rewrite IHp | apply (paren_print_parse_parens)]; auto.
Qed.

Theorem paren_print_parse_inverse (p: Paren):
  parse_paren (print_paren p) = Some p.
Proof.
  unfold parse_paren; now rewrite paren_print_parse_state_inverse.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 3 *)

Require Import Frap Pset3Sig.

Set Implicit Arguments.

(*note: In trying to incorporate lemma l1 into predicate abstration simulates, I get an error and compiling issues that I can't figure out. I know that the second lemma I use in predicate_abstraction_simulates will also come from l1, I just need to connect assumptions and assertions. I also need to use lemma l1 in my proof, but haven't fully integrated that in. I have it partially included in in ps3_v3.1.v*)

Lemma l1: forall  (l : list rule) (x : var) (b : bool), forall (pm pm': fmap var bool), applyRules pm pm' l $? x = Some b -> pm' $? x = None -> exists r: rule, ((r.(Conclusion).(AssumedPredicate)), (r.(Conclusion).(AssumedToBe))) = (x, b) /\ In r l /\ assumptionsHold pm (Assumptions r) = true.
Proof.
  induct l.
  unfold applyRules.
  assert (forall (b : bool), None = Some b -> False).
  intros. equality.
  simplify.
  specialize (H b).
  contradiction H.
  rewrite <- H0.
  rewrite -> H1.
  equality.
  simplify.

  cases (AssumedPredicate (Conclusion a) ==v x).
  cases b.
  intros.

  (*unfold In.
  SearchAbout (_ :: _).
  exact(in_eq (A:=rule) a l).*)

  assert ((applyRule pm pm' a) $? x = None).
  admit.

  cases (AssumedToBe (Conclusion a)).
  exists a.
  propositional.
  invert e.
  invert Heq.
  equality.

  admit. (* prove assumptions hold *)

  (* TODO figure out syntax *)
  specialize (IHl x true pm (applyRule pm pm' a) H H1).
  assert (forall r, In r l -> a = r \/ In r l).
  intros.
  right. assumption.
  destruct IHl.
  specialize (H2 x0).
  exists x0.
  propositional.

  cases (AssumedToBe (Conclusion a)).
  exists a.
  propositional.
  invert e.
  rewrite -> Heq.
  assert ( False).
  admit.
  contradiction H1.

  (* again assumptions hold*)
  admit.

  exists a.
  propositional.
  invert e.
  invert Heq.
  equality.

  (* again assmptions*)
  admit.

  specialize (IHl x b pm (applyRule pm pm' a)).
  specialize (IHl H).

  assert (applyRule pm pm' a $? x = None).
  unfold applyRule.
  (*can't figure out how to do cases on assumptionsHold pm asn :( :( *)
  cases a.
  cases (assumptionsHold pm Assumptions).
  SearchAbout (fmap).
  rewrite (lookup_add_ne (pm') (k:=AssumedPredicate Conclusion) (k':=x) (AssumedToBe Conclusion)).
  assumption.
  admit.

  apply H0.
  specialize (IHl H1).
  destruct IHl.
  exists x0.
  propositional.

Qed.

Theorem predicate_abstraction_simulates : forall pc state action
  (pc0 : pc) (st0 : state)
  (actionOf : pc -> action -> pc -> Prop)
  (doAction : action -> state -> state -> Prop)
  (pa : predicate_abstraction state action),
  predicate_abstraction_sound doAction pa
  -> simulates (paR pa)
               (actionSys pc0 st0 actionOf doAction)
               (predicate_abstract pc0 actionOf pa).
Proof.
  simplify.
  econstructor.
  intros.
  simplify.
  propositional.
  exists (pc0, $0).
  propositional.
  invert H1; simplify.
  eapply PaR.
  simplify.
  invert H0.

  simplify.
  invert H1.
  propositional.
  Check $0.
  destruct st2.
  exists (pc2, match (Rules pa) $? act with
            | None => $0
            | Some rs => applyRules f $0 rs
                end).
  propositional.
  eapply PaR.
  simplify.
  unfold predicate_abstraction_sound in H.
  unfold ruleAccurate in H.
  unfold assertionAccurate in H.
  cases (Rules pa $? act).
  cases (Predicates pa $? x).

  (* prove this as lemma1 *)

  assert (applyRules f $0 l $? x = Some b -> exists r : rule, ((r.(Conclusion).(AssumedPredicate)), (r.(Conclusion).(AssumedToBe))) = (x, b) /\ In r l).
  simplify.

  admit.

  specialize (H4 H1).
  invert H4.
  specialize (H act l x0).
  specialize (H Heq).
  destruct H5.
  specialize (H H5).
  specialize (H st3 st4).
  (*prove this as lemma 2*)
  assert (assumptionsAccurate (Predicates pa) (Assumptions x0) st3).
  admit.
  specialize (H H6).
  specialize (H H3).
  invert H4.
  rewrite Heq0 in H.
  apply H.

  SearchAbout $0.
  (*prove as lemma1*)
  assert (applyRules f $0 l $? x = Some b -> exists r : rule, ((r.(Conclusion).(AssumedPredicate)), (r.(Conclusion).(AssumedToBe))) = (x, b) /\ In r l).

  admit.
  specialize (H4 H1).
  invert H4.
  specialize (H act l x0).
  specialize (H Heq).
  destruct H5.
  specialize (H H5).
  specialize (H st3 st4).

  (*being proving false*)
  (*prove as lemma2*)
  assert (assumptionsAccurate (Predicates pa) (Assumptions x0) st3).
  admit.

  specialize (H H6).
  specialize (H H3).
  invert H4.
  rewrite Heq0 in H.
  apply H.

  rewrite (lookup_empty (A:=var) bool x) in H1.
  assert (forall (b : bool), None = Some b -> False).
  intros. equality.
  specialize (H4 b).
  contradiction H4.
  (* end proving false *)

  econstructor.
  invert H0.
  apply H2.
Qed.

(* Optional part: using predicate abstraction for another example *)

Import Program2 ZArith.

(* This is not the right abstraction. :-) *)
Definition sys_pa : predicate_abstraction state action := {|
  Predicates := $0;
  Rules := $0 $+ (LockOK, [])
              $+ (AssignA, [])
              $+ (IfFalse, [])
              $+ (IfTrue, [])
              $+ (UnlockOK, [])
              $+ (IncA, [])
              $+ (WhileFalse, [])
              $+ (WhileTrue, [])
|}.

Opaque Zplus. (* Important to keep Coq from trying too hard to help and
               * unfolding the definition of addition for integers! *)

Theorem sys_ok : forall np npo,
  invariantFor (sys np npo) (fun st => fst st = Done -> (snd st).(HasLock) = false).
Proof.
Admitted.


(* Librariile necesare pt a lucra cu stringuri*)
Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(* Librariile necesare pt a lucra cu int *)
Require Import Coq.ZArith.ZArith.
Open Scope Z_scope.

(* Librariile necesare pentru a lucra cu liste *)
Require Import Coq.Lists.List.
Import ListNotations.
Scheme Equality for list.

(* Acum voi inlocui tipul nat pe care l am mai folosit cu un nou tip: ErrorNar, care trateaza si cazurile mai speciale *)
Inductive ErrorNat :=
 | error_nat: ErrorNat
 | num : nat -> ErrorNat.
Check ErrorNat.
Check error_nat.
Check num.
Coercion num : nat >-> ErrorNat.

(* La fel pentru int *)

Inductive ErrorInt :=
 | error_int : ErrorInt
 | int : Z -> ErrorInt.
Check ErrorInt.
Check error_int.
Check int.
Coercion int : Z >-> ErrorInt.

(* Same pentru bool *)

Inductive ErrorBool :=
 | error_bool : ErrorBool
 | bul : bool -> ErrorBool.
Check ErrorBool.
Check error_bool.
Check bul.
Coercion bul : bool >-> ErrorBool.

(* Fac un tip cu erori si pentru string, pentru moment*)

Inductive ErrorString :=
 | error_string : ErrorString
 | char : string -> ErrorString.
Check ErrorString.
Check error_string.
Check char.
Coercion char : string >-> ErrorString.

(* Pentru expr aritmetice *)
Inductive AExp :=
 | anum : ErrorNat -> AExp
 | avar : string -> AExp
 | aint : ErrorInt -> AExp
 | aplus : AExp -> AExp -> AExp
 | aminus : AExp -> AExp -> AExp
 | amul : AExp -> AExp -> AExp
 | adiv : AExp -> AExp -> AExp
 | amod : AExp -> AExp -> AExp
 | to_nat : string -> AExp
 | to_int : string -> AExp.

Coercion avar : string >-> AExp.
Coercion anum : ErrorNat >-> AExp.
Coercion aint : ErrorInt >-> AExp.

Notation "A +' B" := (aplus A B)(at level 60, right associativity).
Notation "A -' B" := (aminus A B)(at level 60, right associativity).
Notation "A *' B" := (amul A B)(at level 59, right associativity).
Notation "A /' B" := (adiv A B)(at level 59, right associativity).
Notation "A %' B" := (amod A B)(at level 58, right associativity).
Check ("a" +' "b").
Check ("a" -' "b").
Check ("a" +' 3).
Check ("a" -' (-5)).
Check ("a" /' 0).
Check (7 %' 2).

(* Acum pentru expresii booleene *)
Inductive BExp :=
 | berror
 | btrue
 | bfalse
 | bvar : string -> BExp
 | blessthan : AExp -> AExp -> BExp
 | beqlessthan : AExp -> AExp -> BExp
 | bgreaterthan : AExp -> AExp -> BExp
 | beqgreaterthan : AExp -> AExp -> BExp
 | bnot : BExp -> BExp
 | band : BExp -> BExp -> BExp
 | bor : BExp -> BExp -> BExp
 | bequal : AExp -> AExp -> BExp
 | to_bool : string -> BExp.

Coercion bvar : string >-> BExp.

Notation "A <' B" := (blessthan A B) (at level 53).
Notation "A <=' B" := (beqlessthan A B) (at level 53).
Notation "A >' B" := (bgreaterthan A B) (at level 53).
Notation "A >=' B" := (beqgreaterthan A B) (at level 53).
Notation "!' A" := (bnot A) (at level 50, left associativity).
Notation "A &&' B" := (band A B) (at level 51, left associativity).
Notation "A ||' B" := (bor A B) (at level 52, left associativity).
Notation "A ==' B" := (bequal A B) (at level 54, left associativity).
Check berror.
Check btrue.
Check bfalse.
Check (!' "a").
Check (!' btrue).
Check ("a" <' "b").
Check ("a" <=' "b").
Check ("a" >' "b").
Check ("a" >=' "b").
Check ("a" &&' bfalse).
Check ("a" ||' "b").

(* Pentru expresii cu siruri de caractere *)

Inductive CExp :=
 | cconst : ErrorString -> CExp
 | cvar : string -> CExp
 | cequal : ErrorString -> ErrorString -> CExp
 | clength : ErrorString -> CExp
 | cappend : ErrorString -> ErrorString -> CExp
 | to_char : string -> CExp.

Coercion cvar : string >-> CExp.

Notation " A =s= B " := (cequal A B) (at level 30).
Notation " 'length' ( A ) " := (clength A) (at level 31).
Notation " A +s+ B " := (cappend A B) (at level 32).

Check ("asd" =s= "asd").
Check (length ( "asd" )).
Check ("asd" +s+ "fgh").

(* Statementuri *)
Print Coq.Lists.List.

Inductive Stmt :=
 | nat_decl : string -> Stmt
 | nat_assign : string -> AExp -> Stmt
 | int_decl : string -> Stmt
 | int_assign : string -> AExp -> Stmt
 | bool_decl : string -> Stmt
 | bool_assign : string -> BExp -> Stmt
 | string_decl : string -> Stmt
 | string_assign : string -> CExp -> Stmt
 | sequence : Stmt -> Stmt -> Stmt
 | while : BExp -> Stmt -> Stmt
 | ifthenelse : BExp -> Stmt -> Stmt -> Stmt
 | ifthen : BExp -> Stmt -> Stmt
 | break : Stmt
 | continue : Stmt
 | fct_declare : string -> Stmt -> Stmt -> Stmt
 | fct_call : string -> list Z -> Stmt
 | switch : AExp -> list Case -> Stmt
 with Case :=
 | case : AExp -> Stmt -> Case
 | default' : Stmt -> Case.

Notation "'unsigned' X" := (nat_decl X)(at level 80).
Notation "'int' X" := (int_decl X)(at level 80).
Notation "'bool' X" := (bool_decl X)(at level 80).
Notation "'char' X" := (string_decl X)(at level 80).

Notation "X :n= A" := (nat_assign X A)(at level 80).
Notation "X :i= A" := (int_assign X A)(at level 80).
Notation "X :b= A" := (bool_assign X A)(at level 80).
Notation "X :s= A" := (string_assign X A)(at level 80).

Notation "S1 ;; S2" := (sequence S1 S2)(at level 93).

Notation "'if'' B 'then'' S1 'end''" := (ifthen B S1)(at level 83).
Notation "'if'' B 'then'' S1 'else'' S2 'end''" := (ifthenelse B S1 S2)(at level 83).
Notation "'for' ( A ~ B ~ C ) { S }" := (A ;; while B  (S ;; C )) (at level 97).
Notation "'while'' ( B ) { S }" := (while B S) (at level 83).

Notation " 'switch' A 'en' L 'ends' " := (switch A L)(at level 83).
Notation " 'case' A 'en' S 'en' " := (case A S)(at level 84).
Notation " 'default'' S 'en'" := (default' S)(at level 84).

Notation " 'declare' X S1 'begin' { S2 } 'endf' " := (fct_declare X S1 S2)(at level 78).
Notation " 'call' X 'begin' L 'endf'" := (fct_call X L)(at level 68).

Notation "'(int)' { A }" := (to_int A)( at level 35).
Notation "'(nat)' { A }" := (to_nat A)( at level 35).
Notation "'(bool)' { A }" := (to_bool A)( at level 35).
Notation "'(char)' { A }" := (to_char A)( at level 35).

Check (unsigned "a").
Check ("a" :n= 3).

Check (bool "a").
Check ("a" :b= bfalse).

Check (char "c").
Check ("c" :s= "abc").

Check (

int "a";;
int "b";;
int "sum";;
"sum" :n= 0;;
"a" :i= 1;;
"b" :i= 5;;
char "rasp";;

if' ("a" <=' "b") then'
  "rasp" :s= "a este mai mic sau egal cu b"
else'
  "rasp" :s= "a este mai mare decat b"
end'
).

Check (

switch 6 en [
  case 6 en "c" :i= 6 en ;
  case 9 en "c" :i= 9 en ;
  default' "c" :i= -1 en
]
ends
).

Check (
declare "fun" int "a"
  begin
    {
      int "b" ;;
      "b" :i= ("a" *' 10)
}endf
).

Check (call "fun" begin [10;20] endf).

Check (

int "x";;
int "y";;
"x" :i= 1;;
"y" :i= 4;;
while' ( "x" <' "y" ) {
  "x" :i= "x" +' 1;;
  if' ("x" ==' 2 ) then'
      break
  end'
}

).

(* Creez un tip in care adun toate celelalte tipuri *)

Inductive Tipuri :=
 | error_undecl : Tipuri (* Sa nu folosesc variabile nedeclarate *)
 | error_assign : Tipuri (* Sa nu atribui valori de alt tip decat tipul variabilei *)
 | default : Tipuri (* O valoare default care se pune in variabile la declarere *)
 | tip_nat : ErrorNat -> Tipuri
 | tip_bul : ErrorBool -> Tipuri
 | tip_int : ErrorInt -> Tipuri
 | tip_string : ErrorString -> Tipuri
 | code : Stmt -> Tipuri.

Check tip_nat.
Check tip_string.
Check tip_int.
Check tip_bul.
Check Tipuri.

(* Scheme Equality for Tipuri. *)

(* Deoarece am construit tipul "Tipuri", nu mai trebuie sa fac cate un enviroment pentru toate tipurile, ci doar pentru el*)
Definition Env := string -> Tipuri.

(* Functie pentru egalitatea pe tipuri *)

Definition Egalitate_tipuri (t1 : Tipuri)(t2 : Tipuri) : ErrorBool :=
 match t1 with
 | error_undecl => match t2 with
                   | error_undecl => true
                   | _ => false
                   end
 | error_assign => match t2 with
                   | error_assign => true
                   | _ => false
                   end
 | default => match t2 with
                   | default => true
                   | _ => false
                   end
 | tip_nat _x => match t2 with
                   | tip_nat _y => true
                   | _ => false
                   end
 | tip_bul _x => match t2 with
                   | tip_bul _y => true
                   | _ => false
                   end
 | tip_string _x => match t2 with
                   | tip_string _y => true
                   | _ => false
                  end
 | tip_int _x => match t2 with
                   | tip_int _y => true
                   | _ => false
                   end
 | code _x => match t2 with
                   | code _y => true
                   | _ => false
                   end
 end.
Check Egalitate_tipuri.
Check tip_nat.
(* Definesc un environment in care practic spun ca initial nici o variabila nu este declarata*)
Definition env : Env := fun x => error_undecl.
 Check (env "x").
Compute (env "x").

(* Acum fac functia de atribuire a unei valori unei variabile*)

(* Definition update (env : Env) (x : string) (v : Tipuri ) : Env :=
  fun y =>
    if (eqb y x)
    then
      if(andb (Egalitate_tipuri error_undecl (env y)) (negb (Egalitate_tipuri default v)))
      then error_undecl
      else
        if(andb (Egalitate_tipuri error_undecl (env y))(Egalitate_tipuri default v))
        then default
        else
          if(orb (Egalitate_tipuri default (env y))(Egalitate_tipuri v (env y)))
          then v
          else error_assign
    else (env y).

Notation "S [ V /' X ]" := (update S X V) (at level 1).

Check (update env "y" default).
Compute (update (update env "y" (default)) "y" (tip_bul true) "y").
 *)
(* Este nevoie de anumite functii pentru a trata si cazurile cu erori, cate o functie pentru fiecare operatie*)

(* Definition plus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 + v2)
  end.

Compute plus_ErrorNat 1 2.

Definition minus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => if (Nat.leb v1 v2)
                        then error_nat
                        else num (v1 - v2)
  end.

Definition mul_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 * v2)
  end.
Import Nat.
Definition div_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, 0 => error_nat
    | num v1, num v2 => (div v1 v2)
  end.

Definition mod_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, 0 => error_nat
    | num v1, num v2 => (modulo v1 v2)
  end.

Check mod_ErrorNat.
(* Am pus si semantica Big Step pentru a face exemplele*)

Reserved Notation "A =[ S ]=> N" (at level 70).
Inductive aeval : AExp -> Env -> ErrorNat -> Prop :=
 | const : forall n sigma, anum n =[ sigma ]=> n
 | var : forall v sigma, avar v =[ sigma ]=> match (sigma v) with
                                               | tip_nat x => x
                                               | _ => error_nat
                                             end
 | add : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (plus_ErrorNat i1 i2) -> (a1 +' a2) =[ sigma ]=> n
 | dif : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (minus_ErrorNat i1 i2) -> a1 -' a2 =[ sigma ]=> n
 | times : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (mul_ErrorNat i1 i2) -> a1 *' a2 =[ sigma ]=> n
 | div : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (div_ErrorNat i1 i2) -> a1 /' a2 =[ sigma ]=> n
 | modd : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = mod_ErrorNat i1 i2 -> a1 %' a2 =[ sigma ]=> n
where "a =[ sigma ]=> n" := ( aeval a sigma n).

Example eroare_la_dif : 2 -' 3 =[ env ]=> error_nat.
Proof.
  eapply dif.
    - apply const.
    - apply const.
    - simpl. reflexivity.
Qed.

Example eroare_la_div : 9 /' 0 =[ env ]=> error_nat.
Proof.
  eapply div.
    - apply const.
    - apply const.
    - simpl. reflexivity.
Qed.

Example eroare_la_mod : 5 %' 0 =[ env ]=> error_nat.
Proof.
  eapply modd.
    - apply const.
    - apply const.
    - simpl. reflexivity.
Qed. *)

(* Asemanator ca la numerele naturale, fac functii pentru fiecare operatie, deoarece au aparut cazurile in care pot avea erori*)

(* Definition lessthan_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => bul (Nat.ltb v1 v2)
  end.

Definition greaterthan_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => bul (negb (Nat.leb v1 v2))
  end.

Definition not_ErrorBool (n : ErrorBool) : ErrorBool :=
  match n with
    | error_bool => error_bool
    | bul v => bul (negb v)
  end.

Definition and_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | bul v1, bul v2 => bul (andb v1 v2)
  end.

Definition or_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | bul v1, bul v2 => bul (orb v1 v2)
  end.

Definition equal_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => bul (eqb v1 v2)
  end.
Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval : BExp -> Env -> ErrorBool -> Prop :=
 | e_error : forall sigma,
  berror ={ sigma }=> error_bool
 | e_true : forall sigma,
  btrue ={ sigma }=> true
 | e_false : forall sigma,
  bfalse ={ sigma }=> false
 | e_var : forall v sigma,
  bvar v ={ sigma }=> match (sigma v) with
                        | tip_bul x => x
                        | _ => error_bool
                      end
 | e_lessthan : forall a1 a2 i1 i2 sigma b,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  b = (lessthan_ErrorBool i1 i2) -> a1 <=' a2 ={ sigma }=> b
 | e_greaterthan : forall a1 a2 i1 i2 sigma b,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  b = (greaterthan_ErrorBool i1 i2) -> a1 >=' a2 ={ sigma }=> b
 | e_not : forall a1 i1 sigma b,
  a1 ={ sigma }=> i1 ->
  b = (not_ErrorBool i1) -> !' a1 ={ sigma }=> b
 | e_and : forall a1 a2 i1 i2 sigma b,
  a1 ={ sigma }=> i1 ->
  a2 ={ sigma }=> i2 ->
  b = (and_ErrorBool i1 i2) -> (a1 &&' a2) ={ sigma }=> b
 | e_or : forall a1 a2 i1 i2 sigma b,
  a1 ={ sigma }=> i1 ->
  a2 ={ sigma }=> i2 ->
  b = (or_ErrorBool i1 i2) -> (a1 ||' a2) ={ sigma }=> b
 | e_equal : forall a1 a2 i1 i2 sigma b,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  b = (equal_ErrorBool i1 i2) -> a1 ==' a2 ={ sigma }=> b
where "B ={ S }=> B'" := ( beval B S B').

Example eroare_bool : band (10 <=' 5) (100 >=' "n") ={ env }=> error_bool.
Proof.
  eapply e_and.
    - eapply e_lessthan.
      + apply const.
      + apply const.
      + auto.
    - eapply e_greaterthan.
      + apply const.
      + apply var.
      + simpl. auto.
    - simpl. reflexivity.
Qed.
 *)

(* Functii stringuri *)

(* Definition equal_ErrorString (c1 c2 : ErrorString) : ErrorBool :=
  match c1, c2 with
    | error_string, _ => error_bool
    | _, error_string => error_bool
    | char c1, char c2 => bul (eqb c1 c2)
  end.

Definition append_ErrorString (c1 c2 : ErrorString) : ErrorString :=
  match c1, c2 with
    | error_string, _ => error_string
    | _, error_string => error_string
    | char c1, "" => error_string
    | "", char c2 => error_string
    | char c1, char c2 => char (append c1 c2)
  end.

(* Definition length_ErrorString (c1 : ErrorString) : ErrorNat :=
  match c1 with
    | error_string => error_nat
    | char c1 => num (length c1)
  end. Bug aici, sa revii!! *)

Reserved Notation "C -[ S ]-> C'" (at level 70).
Inductive ceval : CExp -> Env -> ErrorString -> Prop :=
 | const : forall c sigma, cconst c -[ sigma ]-> c
 | var : forall c sigma, cvar c -[ sigma ]-> match (sigma c) with
                                               | tip_string x => x
                                               | _ => error_string
                                             end
 | equal : forall c1 c2 i1 i2 sigma s,
  c1 -[ sigma ]-> i1 ->
  c2 -[ sigma ]-> i2 ->
  s = (equal_ErrorString i1 i2) -> (c1 =s= c2) -[ sigma ]-> s
 | append : forall c1 c2 i1 i2 sigma s,
  c1 -[ sigma ]-> i1 ->
  c2 -[ sigma ]-> i2 ->
  s = (append_ErrorString i1 i2) -> (c1 =s= c2) -[ sigma ]-> s
 | length : forall c1 i1 sigma s,
  c1 -[ sigma ]-> i1 -> s = (length_ErrorString i1) -> ( length ( c1 )) -[ sigma ]-> s
where "c -[ sigma ]-> c'" := ( ceval c sigma c'). *)


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.finite Require Import monad monad_par par_quicksort monad_par_hoare.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Coq.omega.Omega Coq.Program.Wf.

Lemma perm_eq_cat {A: eqType} (l1a l1b l2a l2b: seq A) :
  perm_eq l1a l2a →
  perm_eq l1b l2b →
  perm_eq (l1a ++ l1b) (l2a ++ l2b).
Proof.
  move /permP => Hpa.
  move /permP => Hpb.
  apply /permP.
  intros x. rewrite ?count_cat. rewrite (Hpa x) (Hpb x). done.
Qed.

Lemma sorted_cat {A: eqType} (l1 l2: seq A) (R: rel A):
  sorted R l1 → sorted R l2 →
  (∀ n1 n2, n1 \in l1 → n2 \in l2 → R n1 n2) →
  sorted R (l1 ++ l2).
Proof.
  revert l2. induction l1 => //=.
  intros l2 HP Hsorted Hle.
  rewrite cat_path. apply /andP; split; auto.
  induction l2 => //=. apply /andP; split; auto.
  apply Hle.
  - apply mem_last.
  - rewrite in_cons eq_refl //.
Qed.

Lemma quicksort_correct (l: list nat): mspec (qs l) (λ l', (sorted leq l' && perm_eq l l'):Prop).
Proof.
  remember (size l) as k eqn:Heq.
  revert l Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l Heq.
  destruct l as [| a l].
  - rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=.
  - destruct l as [| b0 l0].
    { rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=. }
    rewrite qs_unfold.
    remember (b0 :: l0) as l eqn:Hl0. clear l0 Hl0.
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin'). intros (Hl&Hm&Hu). rewrite //= in Hl, Hm, Hu.
    tbind (λ x, (sorted leq (fst x) && perm_eq (lower spl) (fst x)) ∧
                (sorted leq (snd x) && perm_eq (upper spl) (snd x))).
    { rewrite //=.
      eapply (mspec_rpar2 _ _ (λ x, (sorted leq x && perm_eq (lower spl) x))
                              (λ x, (sorted leq x && perm_eq (upper spl) x))).
      - eapply (IH (size (lower spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
      - eapply (IH (size (upper spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
    }
    intros (ll&lu) (Hll&Hlu).
    move /andP in Hll. destruct Hll as (Hllsorted&Hllperm).
    move /andP in Hlu. destruct Hlu as (Hlusorted&Hluperm).
    apply mspec_mret => //=. apply /andP; split.
    * apply sorted_cat; [| apply sorted_cat |]; auto.
      ** rewrite Hm. clear. induction l0 => //=.
         case: ifP; auto.
         move /eqP => ->. rewrite //=.
         clear IHl0.
         induction l0 => //=.
         case: ifP; auto. move /eqP => -> //=. rewrite leqnn IHl0 //.
      ** rewrite Hm => a' b'; rewrite mem_filter.
         move /andP => [Heqpv Hin1 Hin2]. move /eqP in Heqpv.
         move: Hin2.
         rewrite -(perm_mem Hluperm) Hu mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite Heqpv. apply /leP. omega.
      ** intros a' b'. rewrite -(perm_mem Hllperm) Hl mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite mem_cat. move /orP => [].
         *** rewrite Hm; rewrite mem_filter.
             move /andP => [Heqpv ?]. move /eqP in Heqpv.
             rewrite Heqpv. apply /leP. omega.
         *** rewrite -(perm_mem Hluperm) Hu mem_filter.
             move /andP => [Hltpv ?]. move /ltP in Hltpv.
             apply /leP. omega.
    * move /andP in Hin'. destruct Hin' as (Hperm&_).
      rewrite perm_sym in Hperm.
      rewrite (perm_trans Hperm) //.
      repeat apply perm_eq_cat; auto.
Qed.