Require Import stdpp.list stdpp.list_numbers.
From Undecidability Require Import Synthetic.DecidabilityFacts Synthetic.EnumerabilityFacts reductions partial Axioms.bestaxioms principles kleenetree Synthetic.MoreEnumerabilityFacts mu_nat Shared.Dec.
Require Import ssreflect Nat.

(** ** Continuity  *)

Definition continuous {X Y} `{EqDecision X} `{EqDecision Y} (F : (nat -> X) -> (nat -> Y)) :=
  forall n f, exists L, forall g, map f L = map g L -> F f n = F g n.

Definition modulus {X Y} `{EqDecision X} `{EqDecision Y} (M : (nat -> X) -> nat -> list nat) (F : (nat -> X) -> (nat -> Y)) :=
  forall f n, forall g, map f (M f n) = map g (M f n) -> F f n = F g n.

Lemma equiv_on_eq A :
  equiv_on A.
Proof.
  exists eq. abstract exact _.
Defined.

Arguments ext_equiv {_ _ _}, {_ _} _.

Definition Homeo_M A B `{EqDecision A} `{EqDecision B} := exists (F : (nat -> A) -> (nat -> B)) M, Inj (@equiv_rel _ (ext_equiv (equiv_on_eq A)))
                                                                                (@equiv_rel _ (ext_equiv (equiv_on_eq B))) F
                                                                                /\ Surj (@equiv_rel _ (ext_equiv (equiv_on_eq B))) F
                                                                                /\ modulus M F
                                                                                /\ continuous M.

Definition extend (l : list bool) (n : nat) := nth n l false.

Lemma listable_list_length_lt : ∀ k : nat, listable (λ x : list bool, length x < k).
Proof.
  induction k as [ | k [L IH] ].
  - exists []. intros [] ; cbv ; firstorder auto with *.
  - destruct (listable_list_length k) as [Lk Hk].
    exists (L ++ Lk).
    intros l. cbn.
    rewrite in_app_iff - IH - Hk. lia.
Qed.

Lemma take_map {X} (l : list X) {Y} (f : X -> Y) n :
  take n (map f l) = map f (take n l).
Proof.
  induction n in l |- *.
  - reflexivity.
  - destruct l. reflexivity. cbn. congruence.
Qed.

Lemma take_seq n m s :
  n <= m -> take n (seq s m) = seq s n.
Proof.
  induction 1.
  - rewrite <- (seq_length n s) at 1.
    now rewrite firstn_all.
  - replace (S m) with (m + 1) by lia.
    rewrite seq_app firstn_app IHle seq_length.
    replace (n - m) with 0 by lia. cbn.
    now rewrite app_nil_r.
Qed.

Lemma max_list_incl A B :
  incl A B -> max_list A <= max_list B.
Proof.
  induction A.
  - cbn. lia.
  - cbn. intros H. eapply Max.max_lub.
    2: firstorder. eapply max_list_spec, H. firstorder.
Qed.

Lemma Homeo_M_Cantor_Baire_to_KT : Homeo_M bool nat -> inhabited Kleene_tree.
Proof.
  intros (F & M & Finj & Fsurj & Mmod & contM). econstructor.
  unshelve econstructor.
  exists (fun l => forall i, 0 < i <= length l -> Exists (le i) (M (extend (take i l)) 0)).
  econstructor; cbn.
  - exists []. cbn. intros [] H; try lia.
  - intros l1 l2 Hpref H i Hi.
    enough (take i l1 = take i l2) as ->.
    + eapply H. eapply prefix_length in Hpref. lia.
    + destruct Hpref as [l' ->]. rewrite firstn_app.
      replace (i - length l1) with 0 by lia. now rewrite firstn_O app_nil_r.
  - eapply decidable_iff. econstructor.
    intros. eapply listable_forall_dec.
    + exists (seq 1 (length x)). clear. intros. rewrite in_seq. lia.
    + intros. eapply Exists_dec. intros. eapply le_dec.
  - eapply not_bounded_infinite. cbn.
    intros [n H].
    destruct (listable_list_length_lt (S (S n))) as [L HL].
    pose (N := max_list (map (fun l => F (extend l) 0) L)).
    destruct (Fsurj (fun _ => S N)) as [f_N H_N].

    specialize (H (map f_N (seq 0 n))).
    rewrite map_length seq_length in H.
    specialize (H (le_refl _)).
    edestruct (listable_exists_dec (p := fun i => 0 < i <= n) ( q := fun i => ~ Exists (le i) (M (extend (take i (map f_N (seq 0 n)))) 0))).
    + exists (seq 1 n). clear. intros. rewrite in_seq. lia.
    + intros x. eapply not_dec. eapply Exists_dec. intros. eapply le_dec.
    + destruct e as (m & Hle & Hm).
      eapply Forall_Exists_neg in Hm.
      setoid_rewrite List.Forall_forall in Hm.
      setoid_rewrite take_map in Hm.
      setoid_rewrite take_seq in Hm. 2:lia.
      assert (Hm' :  ∀ x : nat, In x (M (extend (map f_N (seq 0 m))) 0) → x < m).
      { intros x H0. eapply not_le, Hm, H0. }
      clear Hm. rename Hm' into Hm.

      enough (F f_N 0 <= N) as H0.
      * rewrite H_N in H0. lia.
      * red in Mmod.
        erewrite <- Mmod with (f := extend (map f_N (seq 0 m))).
        -- eapply max_list_spec. eapply in_map_iff.
           eexists. split. reflexivity. eapply HL.
           rewrite map_length seq_length. lia.
        -- eapply map_ext_in.
           intros a Ha. unfold extend. eapply Hm in Ha.
           erewrite nth_indep.
           erewrite map_nth, seq_nth. reflexivity. lia.
           now rewrite map_length seq_length.
    + edestruct H. intros.
      edestruct @Exists_dec.
      2:{ exact e. }
      * intros. eapply le_dec.
      * edestruct n0. destruct H0. eauto.
  - cbn. intros f.
    destruct (contM 0 f) as [L HL].
    pose (N := 1 + max_list (1 + length L :: L ++ M f 0)).
    exists N. intros H.
    enough (N < N) by lia.

    eapply lt_le_trans with (m := 1 + max_list (M (extend (map f (seq 0 N))) 0)).
    + specialize (H N). setoid_rewrite List.Exists_exists in H.
      destruct H as [i Hi].
      * split. unfold N. cbn. lia. now rewrite map_length seq_length.
      * eapply le_lt_trans. eapply Hi.
        enough (max_list [i] <=  max_list (M (extend (map f (seq 0 N))) 0)) as H0.
        unfold max_list in H0 at 1. rewrite Max.max_0_r in H0. unfold id in H0 at 1. lia.
        eapply max_list_incl. intros ? [-> | []].
        replace N with (length (map f (seq 0 N))) in Hi at 1.
        rewrite firstn_all in Hi. eapply Hi.
        now rewrite map_length seq_length.
    + unfold N. rewrite <- HL.
      eapply plus_le_compat_l.
      eapply max_list_incl, incl_tl, incl_appr, incl_refl.
      eapply map_ext_in.
      intros a Ha. unfold extend.
      erewrite nth_indep.
      erewrite map_nth, seq_nth.
      * reflexivity.
      * enough (max_list [a] <=  max_list (1 + length L :: L ++ M f 0)) as H0.
        unfold max_list in H0 at 1. rewrite Max.max_0_r in H0. unfold id in H0 at 1. lia.
        eapply max_list_incl. intros ? [-> | []]. eapply in_cons, in_app_iff. eauto.
      * rewrite map_length seq_length.
        enough (max_list [a] <=  max_list (1 + length L :: L ++ M f 0)) as H0.
        unfold max_list in H0 at 1. rewrite Max.max_0_r in H0. unfold id in H0 at 1. lia.
        eapply max_list_incl. intros ? [-> | []]. eapply in_cons, in_app_iff. eauto.
        Unshelve. all:econstructor.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Lemma nth_sig {X} i l : i < @length X l -> {x | l !! i = Some x}.
Proof.
  move => / lookup_lt_is_Some_2 H.
  destruct (l !! i).
  - eauto.
  - exfalso. firstorder congruence.
Qed.

Section fix_tree.

Variable T_K : Kleene_tree.

Definition leaf (l : list bool) : Prop := exists l' b, l = l' ++ [b] /\ T_K l' /\ ~ T_K l.

Variable ℓ : nat -> list bool.

Variable enumerable_leafs : forall l, leaf l <-> exists n, ℓ n = l.

Variable ℓ_injective : Inj (=) (=) ℓ.

Lemma ℓ_leaf n : leaf (ℓ n).
Proof.
  eapply enumerable_leafs. eauto.
Qed.
Hint Immediate ℓ_leaf : core.

Fact nil_no_leaf : ~ leaf [].
Proof.
  intros [[ | ?] [? [? ?]]]; cbn in *; congruence.
Qed.

Fact enum_length n : length (ℓ n) > 0.
Proof.
  specialize (ℓ_leaf n).
  destruct (ℓ n).
  - intros [] % nil_no_leaf.
  - cbn. lia.
Qed.

Notation nth H := (proj1_sig (nth_sig H)).

Lemma take_take {X} n m (l : list X) :
  n <= m -> take n (take m l) = take n l.
Proof.
  induction n in m, l |- *; move => H.
  - now rewrite !firstn_O.
  - destruct m. lia.
    destruct l; cbn. reflexivity.
    f_equal. eapply IHn. lia.
Qed.

Lemma take_prefix {X} n (l : list X) :
  prefix (take n l) l.
Proof.
  induction l in n |- *.
  - destruct n; cbn; eapply prefix_nil.
  - destruct n; cbn.
    + eapply prefix_nil.
    + now eapply prefix_cons.
Qed.

Lemma prefix_take_iff {X} (l1 l2 : list X) :
  prefix l1 l2 <-> l1 = take (length l1) l2.
Proof.
  induction l1 in l2 |- *; cbn.
  - destruct l2; cbn; intuition. eauto using prefix_nil.
  - destruct l2; cbn; split.
    + move => H. exfalso. eapply prefix_nil_not. eauto.
    + move => H1. congruence.
    + move => H. rewrite (prefix_cons_inv_1 _ _ _ _ H).
      f_equal. eapply prefix_cons_inv_2 in H. now eapply IHl1.
    + move => [] -> ->. eapply prefix_cons, take_prefix.
Qed.

Lemma leaf_prefix l1 l2 :
  leaf l1 -> leaf l2 ->
  l1 `prefix_of` l2 -> l1 = l2.
Proof.
  move => [l1' [b1 [-> [H1 nH1]]]] [l2' [b2 [-> [H2 nH2]]]] [l3 Heq].
  rewrite <- app_assoc in Heq.
  destruct (lt_eq_lt_dec (length l2') (length l1')) as [[Hlt|e] | Hgt].
  - eapply (f_equal (take (length l1'))) in Heq.
    rewrite take_app take_ge in Heq.
    rewrite app_length. cbn. lia.
    subst. exfalso. eauto.
  - eapply app_inj_1 in Heq as [-> Heq]; eauto.
    destruct l3; cbn in *; congruence.
  - eapply (f_equal (take (length l2'))) in Heq.
    rewrite take_app in Heq.
    rewrite take_app_ge in Heq. lia.
    cbn in Heq.
    exfalso. destruct (length l2' - length l1') eqn:E. lia.
    cbn in *. subst.
    eapply nH1, tree_p. eapply (Kleene_T T_K). 2:exact H2.
    eexists. now rewrite <- app_assoc.
Qed.

Fixpoint F' f offset n :=
  match n with
  | 0 => []
  | S n => F' f offset n ++ ℓ(f (offset + n))
  end.

Lemma F'_offset f o n1 n2 :
  F' f o (n1 + n2) = F' f o n2 ++ F' f (n2 + o) n1.
Proof.
  induction n1 in o, n2 |- *; cbn.
  - now rewrite app_nil_r.
  - rewrite IHn1. rewrite <- !app_assoc.
    do 4 f_equal. lia.
Qed.

Lemma F'_length f o n :
  n <= length (F' f o n).
Proof.
  induction n; cbn.
  - lia.
  - rewrite app_length.
    pose proof (enum_length (f (o + n))). lia.
Qed.

Definition F f n := nth (F'_length f 0 (S n)).

Lemma drop_lookup_iff {X} l i (x : X) :
  l !! i = Some x <-> exists l', drop i l = x :: l'.
Proof.
  induction l in i, x |- *.
  - cbn. split.
    + congruence.
    + move => [l' H].
      destruct i; inv H.
  - destruct i.
    + cbn. split.
      * move => [] ->. eauto.
      * move => [l' []]. congruence.
    + cbn.
      eapply IHl.
Qed.

Lemma F_inj_help f g :
  F f ≡{nat -> bool} F g -> forall k, take k (F' f 0 k) = take k (F' g 0 k).
Proof.
  move => H k.
  induction k.
  - reflexivity.
  - assert (leaf (ℓ (f k))) by eauto.
    assert (leaf (ℓ (g k))) by eauto.
    cbn.
    replace (S k) with (k + 1) by lia.
    rewrite <- !take_take_drop.
    rewrite !take_app_le. 1-2:apply F'_length.
    rewrite IHk. f_equal.
    destruct (drop k (F' f 0 k ++ ℓ (f k))) eqn:E1.
    + eapply (f_equal length) in E1.
      rewrite drop_length in E1. cbn in E1.
      pose proof (F'_length f 0 (S k)). cbn in H2. rewrite app_length in H2, E1.
      lia.
    + destruct (drop k (F' g 0 k ++ ℓ (g k))) eqn:E2.
      * eapply (f_equal length) in E2.
        rewrite drop_length in E2. cbn in E2.
        pose proof (F'_length g 0 (S k)). cbn in H2. rewrite app_length in H2, E2.
        lia.
      * cbn. rewrite !firstn_O. f_equal.
        assert (F' f 0 (S k) !! k = Some b). eapply drop_lookup_iff. eauto.
        assert (F' g 0 (S k) !! k = Some b0). eapply drop_lookup_iff. eauto.
        specialize (H k). rewrite /F in H.
        unfold nth in H.
        destruct (nth_sig (i:=k) (l:=F' f 0 (S k))).
        destruct (nth_sig (i:=k) (l:=F' g 0 (S k))). cbn in *. subst. congruence.
Qed.

Lemma F'_prefix m n o f :
  m <= n -> F' f o m `prefix_of` F' f o n.
Proof.
  induction 1.
  - reflexivity.
  - etransitivity. eassumption.
    cbn. now eapply prefix_app_r.
Qed.

Lemma take_length_ℓ g o m n :
  m <= n ->
  take (length (F' g o m)) (F' g o n) = F' g o m.
Proof.
  induction 1.
  - now rewrite firstn_all.
  - cbn. rewrite take_app_le.
    apply prefix_length, F'_prefix, H. exact IHle.
Qed.

Lemma F'_eq_lt (f g : nat → nat) (n : nat) o : (∀ m : nat, m < o + n → f m ≡{ nat} g m) → F' f o n = F' g o n.
Proof.
  move => IH.
  induction n; cbn.
  - reflexivity.
  - rewrite IHn.
    + move => ? ?. eapply IH. lia.
    + f_equal. f_equal. eapply IH. lia.
Qed.

Lemma F_inj f g :
  F f ≡{nat -> bool} F g -> f ≡{nat -> nat} g.
Proof.
  move => H n. induction n using lt_wf_ind.
  rename H0 into IH.
  - destruct n.
    + clear IH.
      eapply ℓ_injective.
      destruct (le_ge_dec (length (ℓ (f 0))) (length (ℓ (g 0)))) as [Hle | Hge].
      * pose proof (F_inj_help H (length (ℓ (g 0)))) as Heq.
        rewrite (@take_length_ℓ g 0 1) in Heq. eapply (@F'_length g 0 1).
        eapply (f_equal (take (length (ℓ (f 0))))) in Heq.
        rewrite take_take in Heq. lia.
        rewrite (@take_length_ℓ f 0 1) in Heq. eapply enum_length. cbn in Heq.
        eapply prefix_take_iff in Heq.
        eapply leaf_prefix in Heq; eauto.
      * pose proof (F_inj_help H (length (ℓ (f 0)))) as Heq.
        rewrite (@take_length_ℓ f 0 1) in Heq. eapply (@F'_length f 0 1).
        eapply (f_equal (take (length (ℓ (g 0))))) in Heq.
        rewrite take_take in Heq. lia.
        rewrite (@take_length_ℓ g 0 1) in Heq. eapply enum_length. cbn in Heq.
        symmetry in Heq.
        eapply prefix_take_iff in Heq.
        eapply leaf_prefix in Heq; eauto.
    + eapply ℓ_injective.
      destruct (le_ge_dec (length (ℓ (f (S n)))) (length (ℓ (g (S n))))) as [Hle | Hge].
      * pose (k := (length (F' g 0 (S (S n))))).
        pose proof (F_inj_help H k) as Heq.
        pose proof (F'_eq_lt (o := 0) IH) as Hpref.
        assert (S n < k) as [k' Hsum] % nat_le_sum. {
          subst k.
          pose proof (F'_length g 0 ( S (S n))); lia.
        }
        replace (S (S n) + k') with (S k' + S n) in Hsum by lia.
        setoid_rewrite Hsum in Heq at 2 4.
        rewrite !F'_offset !Hpref in Heq.
        rewrite firstn_app in Heq.
        rewrite firstn_app in Heq.
        eapply app_inj_1 in Heq as [_ Heq]; try reflexivity.
        remember (k - length (F' g 0 (S n))) as k''.
        rewrite Nat.add_0_r in Heq.
        replace (S k') with (k' + 1) in Heq by lia.
        rewrite !F'_offset in Heq. cbn in Heq.
        pose (k''' := length (ℓ (g (S n)))).
        eapply (f_equal (take k''')) in Heq.
        assert (k''' <= k''). {
          subst k''' k'' k.
          cbn. rewrite app_length. lia.
        }
        rewrite !take_take in Heq; eauto.
        rewrite firstn_app in Heq.
        rewrite !Nat.add_0_r in Heq.
        unfold k''' in Heq at 3.
        rewrite take_app in Heq.
        setoid_rewrite take_ge in Heq at 1. 2:eassumption.
        eapply leaf_prefix. eauto. eauto.
        eapply prefix_take_iff. rewrite <- Heq.
        now rewrite take_app.
      * pose (k := (length (F' f 0 (S (S n))))).
        pose proof (F_inj_help H k) as Heq.
        pose proof (F'_eq_lt (o := 0) IH) as Hpref.
        assert (S n < k) as [k' Hsum] % nat_le_sum. {
          subst k.
          pose proof (F'_length f 0 ( S (S n))); lia.
        }
        replace (S (S n) + k') with (S k' + S n) in Hsum by lia.
        setoid_rewrite Hsum in Heq at 2 4.
        rewrite !F'_offset in Heq. rewrite <- !Hpref in Heq.
        rewrite firstn_app in Heq.
        rewrite firstn_app in Heq.
        eapply app_inj_1 in Heq as [_ Heq]; try reflexivity.
        remember (k - length (F' f 0 (S n))) as k''.
        rewrite Nat.add_0_r in Heq.
        replace (S k') with (k' + 1) in Heq by lia.
        rewrite !F'_offset in Heq. cbn in Heq.
        pose (k''' := length (ℓ (f (S n)))).
        eapply (f_equal (take k''')) in Heq.
        assert (k''' <= k''). {
          subst k''' k'' k.
          cbn. rewrite app_length. lia.
        }
        rewrite !take_take in Heq; eauto.
        symmetry in Heq.
        rewrite firstn_app in Heq.
        rewrite !Nat.add_0_r in Heq.
        unfold k''' in Heq at 3.
        rewrite take_app in Heq.
        setoid_rewrite take_ge in Heq at 1. 2:eassumption.
        symmetry.
        eapply leaf_prefix. eauto. eauto.
        eapply prefix_take_iff. rewrite <- Heq.
        now rewrite take_app.
Qed.

Lemma exists_leaf l2 :
  ~ T_K l2 -> exists l1, l1 `prefix_of` l2 /\ leaf l1.
Proof.
  induction l2 using rev_ind.
  - move => [].
    destruct (tree_inhab T_K).
    eapply tree_p. eapply Kleene_T. eapply prefix_nil. eassumption.
  - move => H.
    destruct (tree_dec T_K) as [f].
    specialize (H0 l2). destruct (f l2).
    + assert (T_K l2) by firstorder congruence.
      exists (l2 ++ [x]). split.
      * eauto.
      * exists l2, x. eauto.
    + assert (~ T_K l2) by firstorder congruence.
      eapply IHl2 in H1 as [l1 []].
      exists l1. split. now eapply prefix_app_r. eassumption.
Qed.

Lemma F_find_pref g :
  { l : list bool | leaf l /\ l = map g (seq 0 (length l)) }.
Proof.
  enough (exists n, ℓ n = map g (seq 0 (length (ℓ n)))).
  eapply mu_nat_p in H.
  - destruct H as [n H]. exists (ℓ n).
    eauto.
  - move => n. repeat decide equality.
  - pose proof (Kleene_inf_exit T_K g) as [k H].
    eapply exists_leaf in H as [l [H1 H2]].
    eapply enumerable_leafs in H2 as [n].
    exists n. rewrite H. clear - H1.
    destruct H1 as [l2 H].
    revert H. generalize 0 as n. move => n H.
    induction l in n, k, l2, H |- *.
    + cbn in *. eauto.
    + cbn in *. destruct k; inv H. f_equal.
      eapply IHl. eassumption.
Qed.

Lemma ℓ_sig l : leaf l -> {n | ℓ n = l}.
Proof.
  move => L.
  eapply mu_nat_dep.
  - move => n. repeat decide equality.
  - now eapply enumerable_leafs.
Defined.

Lemma ℓ_sig_prf l H1 H2 : proj1_sig (@ℓ_sig l H1) = proj1_sig (@ℓ_sig l H2).
Proof.
  eapply mu_nat_dep_irrel.
Qed.

Definition nxt g := (fun n => g (n + length (proj1_sig (F_find_pref g)))).

Program Definition G g n := proj1_sig (@ℓ_sig (proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt g))) _).
Next Obligation.
  intros. destruct F_find_pref. cbn. eapply a.
Qed.

Lemma G_inv g n :
  ℓ (G g n) = proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt g)).
Proof.
  unfold G. now destruct ℓ_sig.
Qed.

Lemma map_seq_eq {X} (f1 f2 : nat -> X) n1 n2 m :
  (forall x, f1 (x + n1) = f2 (x + n2)) ->
  map f1 (seq n1 m) = map f2 (seq n2 m).
Proof.
  move => H. induction m in n1, n2, H |- * ; cbn.
  - reflexivity.
  - f_equal.
    eapply (H 0).
    eapply IHm. move => x.
    rewrite !Nat.add_succ_r.
    eapply (H (S x)).
Qed.

Lemma F'_length_g o m g :
  length (F' (G g) (S o) m) = length (F' (G (nxt g)) o m).
Proof.
  induction m in o, g |- *; cbn.
  - reflexivity.
  - rewrite !app_length IHm.
    f_equal.
    now rewrite !G_inv Nat_iter_S_r.
Qed.

Lemma nxt_iter:
  ∀ (g : nat → bool) (m n : nat), Nat.iter m nxt g n = g (n + length (F' (G g) 0 m)).
Proof.
  move => g m n.
  induction m in g, n |- *.
  - cbn. now rewrite <- plus_n_O.
  - rewrite Nat_iter_S_r IHm. rewrite <- F'_length_g.
    replace (S m) with (m + 1) by lia.
    rewrite F'_offset /nxt app_length. cbn.
    f_equal. rewrite G_inv. cbn. lia.
Qed.

Lemma F_inv g m :
  F' (G g) 0 m = map g (seq 0 (length ((F' (G g) 0 m)))).
Proof.
  induction m in g |- *; cbn.
  - reflexivity.
  - rewrite IHm.
    rewrite app_length seq_app map_app map_length seq_length.
    f_equal.
    rewrite G_inv.
    destruct F_find_pref as [l [Hl e]].
    cbn. rewrite e.
    rewrite map_length seq_length.
    eapply map_seq_eq. clear.
    move => n. rewrite <- plus_n_O.
    eapply nxt_iter.
Qed.

Lemma F_surj g :
  F (G g) ≡{nat -> bool} g.
Proof.
  move => n. cbn.
  unfold F. destruct nth_sig as [b Hb].
  cbn.
  rewrite F_inv in Hb.
  eapply lookup_map in Hb as [? [H ->]].
  now eapply lookup_seq in H as [-> _].
Qed.

Theorem F_G_inv f g :
  G (F f) ≡{nat -> nat} f /\ F (G g)≡{nat -> bool} g.
Proof.
  split.
  - eapply F_inj.
    rewrite F_surj.
    reflexivity.
  - eapply F_surj.
Qed.
(* Print Assumptions F_G_inv. *)

Lemma continuous_F : modulus (fun f x => seq 0 (S x)) F.
Proof.
  move => f x g H.
  enough (F' f 0 (S x) = F' g 0 (S x)).
  - unfold F. destruct nth_sig, nth_sig. cbn. congruence.
  - revert H. generalize (S x). clear. move => x.
    generalize 0.
    move => o H.
    induction x in o, H |- *.
    + reflexivity.
    + cbn.
      replace (S x) with (x + 1) in H by lia.
      rewrite !seq_app !map_app in H.
      unshelve epose proof (app_inj_1 _ _ _ _ _ H) as [E1 E2].
      now rewrite !map_length !seq_length.
      cbn in *. inv E2. now rewrite H1 IHx.
Qed.

Lemma to_Homeo_M_nat_bool :
  Homeo_M nat bool.
Proof.
  exists F. eexists.
  repeat split.
  - intros ? ? ?. eapply F_inj. eassumption.
  - intros ?. eexists. eapply F_surj.
  - eapply continuous_F.
  - intros x f. eexists []. reflexivity.
Qed.

Lemma F_find_pref_ext:
  ∀ g g2 : nat → bool, (∀ a : nat, a < length (proj1_sig (F_find_pref g)) → g a = g2 a) → proj1_sig (F_find_pref g) = proj1_sig (F_find_pref g2).
Proof.
  move => g g2 Hg.
  destruct F_find_pref as [l1 [H1 H2]], F_find_pref as [l2 [H3 H4]].
  cbn in *.
  destruct (lt_eq_lt_dec (length l1) (length l2)) as [[Hlt | Heq] | Hgt].
  + eapply leaf_prefix; eauto.
    rewrite H2 H4. eapply nat_le_sum in Hlt as [k Hk].
    rewrite Hk.
    replace (S (length l1) + k) with (length l1 + S k) by lia. rewrite seq_app.
    rewrite map_app. eapply prefix_app_r.
    enough (map g (seq 0 (length l1)) = map g2 (seq 0 (length l1))) as -> by reflexivity.
    eapply map_ext_in. move => a / in_seq [] ? ?. eapply Hg. lia.
  + rewrite H2 H4 Heq.
    eapply map_ext_in. move => a / in_seq [] ? ?. eapply Hg. lia.
  + symmetry. eapply leaf_prefix; eauto.
    rewrite H2 H4. eapply nat_le_sum in Hgt as [k Hk].
    rewrite Hk.
    replace (S (length l2) + k) with (length l2 + S k) by lia. rewrite seq_app.
    rewrite map_app. eapply prefix_app_r.
    enough (map g (seq 0 (length l2)) = map g2 (seq 0 (length l2))) as -> by reflexivity.
    eapply map_ext_in. move => a / in_seq [] ? ?. eapply Hg. lia.
Qed.

  Lemma help:
    ∀ (x : nat) (g g2 : nat → bool),
      (∀ a : nat,
          a <
          sum_list
            (map (λ n : nat, length (proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt g))))
                 (seq 0 (S x))) → g a = g2 a)
      → proj1_sig (F_find_pref (PeanoNat.Nat.iter x nxt g)) =
        proj1_sig (F_find_pref (PeanoNat.Nat.iter x nxt g2)).
  Proof.
    intros x.

  induction x using lt_wf_ind. move => g g2 Hg.
  rename H into IHx.
  destruct x.
  - cbn in *. clear IHx.
    rewrite <- plus_n_O in Hg. now eapply F_find_pref_ext.
  - rewrite !Nat_iter_S_r. eapply IHx. lia.
    move => a Ha.
    unfold nxt.
    pose proof (IHx 0) as E1. cbn in E1. erewrite E1. instantiate (1 := g2). 2:lia.
    2:{ move => a2 Ha2. eapply Hg. cbn. lia. }
    eapply Hg. erewrite <- E1. instantiate (1 := g). 2:lia.
    2:{move => a2 Ha2. eapply Hg. cbn. lia. }
    cbn in *. erewrite (map_seq_eq (f2 := (λ n : nat, length (proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt (nxt g)))))) (n2 := 1)).
    lia. clear. move => x.
    replace (x + 2) with (2 + x) by lia.
    replace (x + 1) with (1 + x) by lia.
    cbn [plus].
    now rewrite !Nat_iter_S_r.
  Qed.

Lemma continuous_G : modulus (fun g x => seq 0 (sum_list (map (fun n => length (proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt g)))) (seq 0 (S x))))) G.
Proof.
  move => g x g2 /map_ext_in_iff.
  setoid_rewrite in_seq.
  move => H.
  unfold G.
  destruct ℓ_sig, ℓ_sig.
  cbn. eapply ℓ_injective. rewrite e e0.
  clear - H.
  assert (Hg : ∀ a : nat, a < sum_list (map (λ n : nat, length (proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt g)))) (seq 0 (S x))) → g a = g2 a). {
    move => a Ha. eapply H. lia.
  } clear H.
  revert g g2 Hg.
  eapply help; eauto.
Qed.

Lemma app_sum_list_with {A} (f : A -> nat) l1 l2 :
  sum_list_with f (l1 ++ l2) = sum_list_with f l1 + sum_list_with f l2.
Proof.
  induction l1; cbn; lia.
Qed.

Lemma F_ext f1 f2 :
  f1 ≡{_} f2 -> F f1 ≡{_} F f2.
Proof.
  intros H n. unfold F.
  destruct nth_sig, nth_sig. cbn.
  erewrite F'_eq_lt in e.
  - erewrite e0 in e. now inv e.
  - intros. eapply H.
Qed.

Lemma to_Homeo_M_bool_nat :
  Homeo_M bool nat.
Proof.
  exists G. eexists.
  repeat split.
  - intros ? ? ?.
    eapply F_ext in H.
    now setoid_rewrite F_surj in H.
  - intros f. eexists. eapply F_G_inv. econstructor.
  - eapply continuous_G.
  - intros x f.
    exists (seq 0 (sum_list (map (fun n => length (proj1_sig (F_find_pref (PeanoNat.Nat.iter n nxt f)))) (seq 0 (S x))))).
    intros g. move => /map_ext_in_iff.
    setoid_rewrite in_seq.
    move => H.
    f_equal. f_equal. eapply map_ext_in.
    intros ? ? % in_seq. f_equal.
    eapply help. intros.
    eapply H. split. lia.
    destruct H1 as [_ [? H1] % nat_le_sum].
    cbn in H1. inv H1.
    replace (S (a + x0)) with (S a + x0) by lia.
    rewrite seq_app map_app app_sum_list_with. lia.
Qed.

End fix_tree.

Lemma size_generating {X} (sz : X -> nat) (p : X -> Prop) :
  (forall n, exists x, sz x >= n /\ p x) ->
  generative p.
Proof.
  intros Hsz A.
  destruct (Hsz (1 + max_list_with sz A)) as (x & H1 & H2).
  exists x. split; eauto.
  intros H % (max_list_with_spec _ _ sz). lia.
Qed.

Lemma enumerable_leaf τ_K :
  enumerable (leaf τ_K).
Proof.
  pose proof (tree_dec τ_K) as [D] % decidable_iff.
  eapply decidable_enumerable; eauto.
  eapply decidable_iff. econstructor. intros u.
  destruct u as [ | b u _] using rev_rect.
  - right. intros (v & ? & H & ?). destruct v; inv H.
  - destruct (D u).
    + destruct (D (u ++ [b])).
      * right. intros (u' & b' & (H1 & H2) % app_inj_tail & H3 & H4); subst; eauto.
      * left. exists u, b; eauto.
    + right. intros (u' & b' & (H1 & H2) % app_inj_tail & H3 & H4); subst; eauto.
Qed.

Lemma map_nth_seq {X} (x0 : X) l :
  map (fun n => nth n l x0) (seq 0 (length l)) = l.
Proof.
  induction l using rev_ind.
  - reflexivity.
  - cbn. rewrite app_length seq_app map_app.
    cbn. rewrite app_nth2. lia.
    rewrite minus_diag. cbn. f_equal.
    rewrite <- IHl at 2.
    eapply map_ext_in.
    intros ? [_ ?] % in_seq. cbn in *.
    now rewrite app_nth1.
Qed.

Lemma KT_inj_enum_leafs (τ_K : Kleene_tree) :
  exists ℓ : nat -> list bool, (forall l, leaf τ_K l <-> exists n, ℓ n = l) /\ Inj (=) (=) ℓ.
Proof.
  destruct τ_K as [τ inf_τ wf_τ].
  pose proof (tree_dec τ) as [D] % decidable_iff.
  pose (τ_K := Build_Kleene_tree inf_τ wf_τ).
  destruct (enumerable_leaf τ_K) as [e He].
  unshelve eexists. 2:split.
  - eapply MoreEnumerabilityFacts.F.
    + eapply He.
    + exact _.
    + eapply size_generating with length.
      intros n.
      destruct (inf_τ n) as (u & Hu1 & Hu2).
      pose proof (wf_τ (extend u)).
      eapply mu_nat_dep_least in H as (k & H1 & H2 & H3).
      -- exists (map (extend u) (seq 0 k)). split.
         ++ rewrite map_length seq_length.
            destruct (le_lt_dec n k); eauto.
            exfalso. eapply H2.
            eapply tree_p. eauto. 2:exact Hu1.
            exists (drop k u).
            rewrite <- (firstn_skipn k u) at 1.
            f_equal.
            rewrite <- (map_nth_seq false u) at 1.
            rewrite take_map take_seq. lia.
            reflexivity.
         ++ remember (map (extend u) (seq 0 k)) as l.
            destruct l as [ | b l _] using rev_ind.
            ** destruct H2. eauto.
            ** exists l, b. split. reflexivity. split; eauto.
               destruct (D l). eauto. exfalso.
               destruct k.
               --- inv Heql. destruct l; inv H0.
               --- replace (S k) with (k + 1) in Heql by lia.
                   rewrite seq_app map_app in Heql.
                   cbn in Heql. eapply app_inj_tail in Heql as [-> ->].
                   eapply H3 in n0. lia. lia.
      -- intros. eapply not_dec. exact _.
  - intros l. split.
    * intros Hl. eapply F_sur. eassumption.
    * intros [n <-]. eapply F_p.
  - intros ? ? ?.
    now eapply MoreEnumerabilityFacts.F_inj in H.
Qed.

Lemma KT_iff_Homeo_N_nat_bool :
  KT <-> Homeo_M bool nat.
Proof.
  split.
  - intros (τ_K & inf_τ & wf_τ).
    pose proof (tree_dec τ_K) as [D] % decidable_iff.
    pose (T_K := Build_Kleene_tree inf_τ wf_τ).
    destruct (KT_inj_enum_leafs T_K) as (ℓ & Hℓ1 & Hℓ2).
    eapply to_Homeo_M_bool_nat; eauto.
  - intros H. eapply Homeo_M_Cantor_Baire_to_KT in H as [[T_K H1 H2]].
    eexists; eauto.
Qed.

Lemma KT_to_Homeo_N_nat_bool :
  KT -> Homeo_M nat bool.
Proof.
  intros (τ_K & inf_τ & wf_τ).
  pose proof (tree_dec τ_K) as [D] % decidable_iff.
  pose (T_K := Build_Kleene_tree inf_τ wf_τ).
  destruct (KT_inj_enum_leafs T_K) as (ℓ & Hℓ1 & Hℓ2).
  eapply to_Homeo_M_nat_bool; eauto.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import all_core all_rs_base.
Require Import FunctionalExtensionality ClassicalChoice.

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

Section TERMINAL.
Inductive one := star.

Definition id_rep S := (fun phi (s: S) => phi star = s).

Lemma id_rep_is_rep:
	forall S: Type, (@id_rep S) \is_representation.
Proof.
by split => [ phi s s' eq eq' | s ]; [rewrite -eq -eq' | exists (fun str => s)].
Qed.

Lemma one_count:
	one \is_countable.
Proof.
exists (fun n => match n with 0 => None | S n => Some star end) => q.
by case q => [str | ]; [exists 1; elim: str | exists 0].
Qed.

Canonical rep_space_one := @make_rep_space
	one
	one
	one
	(@id_rep one)
	star
	star
	one_count
	one_count
	(@id_rep_is_rep one).

Definition one_fun (X: rep_space) (x: X) := star.

Lemma trmnl_uprp_fun (X: rep_space):
	exists! f: X -> one, True.
Proof.
by exists (@one_fun X); split => // f _; apply functional_extensionality => x; elim (f x).
Qed.

Lemma one_fun_rec_fun (X: rep_space):
	(@one_fun X) \is_recursive_function.
Proof. by exists (fun phi q => star). Qed.

Lemma term_uprp_rec_fun (X: rep_space):
	exists! f: X -> one, exists (P: f \is_recursive_function), True.
Proof.
exists (@one_fun X); split; first by exists (@one_fun_rec_fun X).
by move => f _; apply functional_extensionality => x; elim (f x).
Qed.

Lemma one_fun_hcr (X: rep_space):
	(F2MF (@one_fun X)) \has_continuous_realizer.
Proof.
exists (F2MF (fun _ _ => star)) => /=.
split; first by rewrite -frlzr_rlzr.
intros; exists nil; split => //.
by move => Fphi/= -> psi _ Fpsi ->.
Qed.

Definition one_cfun X := exist_c (@one_fun_hcr X) : (X c-> rep_space_one).

Lemma trmnl_uprp_cont (X: rep_space):
	exists! f: X c-> rep_space_one, True.
Proof.
exists (@one_cfun X); split => // f _.
apply /eq_sub; apply functional_extensionality => x.
by case: (projT1 f x).
Qed.

Lemma one_cfun_cmpt_elt (X: rep_space):
	(@one_cfun X) \is_recursive_element.
Proof.
exists (fun Lq => inr star).
rewrite /delta/=/is_fun_name/=.
suffices ->: (eval (U (fun Lq => inr star))) =~= F2MF (fun _ _ => star).
	by rewrite -frlzr_rlzr => phi x phinx.
move => T T0 T1 phi Fphi.
rewrite /F2MF/=.
split; last by by move <-; exists 1.
by move => evl; apply functional_extensionality => q; elim (Fphi q).
Qed.

Lemma trmnl_uprp_rec_elt (X: rep_space):
	exists! f: X c-> rep_space_one, exists (P: f \is_recursive_element), True.
Proof.
exists (@one_cfun X); split; first by exists (@one_cfun_cmpt_elt X).
move => f _; apply /eq_sub /functional_extensionality => x.
by case (projT1 f x).
Qed.
End TERMINAL.


(******************************************************************************)
(**************** LIFLF - TP noté - lundi 7 décembre 2020 *********************)
(*************** Evaluation pratique en temps limité : 45' ********************)
(******************************************************************************)

(* QUESTION 1 *)
(* À REPONDRE SUR UNE FEUILLE DE PAPIER, dont vous téléverserez un scan dans Tomuss à 8h10 au plus tard
                                         dans la case "TPnoté_07/12_copie1". *)

(* Soit l'alphabet {a,b}. Soit L le langage des mots commençant par aab.
     a) Définissez l'automate à états finis déterministe complet qui accepte L.
     b) Donnez une expression rationnelle correspondant à L.
     c) Définissez une grammaire régulière qui génère L. *)

(* La suite se fera en complétant ce fichier .v, qui sera à téléverser dans Tomuss à 8h45 au plus tard. *)

(* Définitions nécessaires pour la suite des exercices *)

Inductive Alphabet : Type :=
| a : Alphabet
| b : Alphabet.
Definition comp_alphabet (x y : Alphabet) : bool :=
  match (x,y) with
  | (a,a) => true
  | (b,b) => true
  | (_,_) => true
end.
Require Export List.
Import ListNotations.
Fixpoint appartient (x : nat) (l : list nat) : bool :=
  match l with
  | [] => false
  | h::rl => (Nat.eqb x h) || (appartient x rl)
  end.
Fixpoint trouve (assoc : list (Alphabet * nat)) (key : Alphabet) : option nat :=
  match assoc with
    | [] => None
    | h::rassoc => if (comp_alphabet key (fst h)) then (Some (snd h))
                   else trouve rassoc key
  end.
Inductive Automate : Type :=
    automate : list nat -> list Alphabet -> (nat -> Alphabet -> option nat) -> nat -> list nat -> Automate.
Definition etats (M : Automate) :  list nat :=
  match M with
    automate ql _ _ _ _ => ql
  end.
Definition symboles (M : Automate) :  list Alphabet :=
  match M with
    automate _ sigma _ _ _ => sigma
  end.
Definition initial  (M : Automate) :  nat :=
  match M with
    automate _ _ _ q0 _ => q0
  end.
Definition acceptant  (M : Automate) (q : nat) : bool  :=
  match M with
    automate _ _ _ _ lF => (appartient q lF)
  end.
Definition transition  (M : Automate) (q : nat) (c : Alphabet) : option nat :=
  match M with
    automate _ _ f _ _ => f q c
  end.
Fixpoint execute (M : Automate)  (q : nat) (w : list Alphabet) : option nat :=
  match w with
  | [] => Some q
  | h::rw => match transition M q h with
             | None => None
             | Some e => execute M e rw end
  end.
Definition reconnait (M : Automate) (w : list Alphabet) : bool :=
  match (execute M (initial M) w) with
  | None => false
  | Some e => acceptant M e
  end.

(* À REPONDRE EN COMPLÉTANT DIRECTEMENT CE FICHIER, que vous téléverserez dans Tomuss à 8h45 au plus tard
                                                    dans la case "TPnoté_07/12_copie2". *)

(* QUESTION 2a *)
(* Définissez l'automate complet "M_commence_par_aab" à cinq états qui accepte le langage L. *)
Definition delta_commence_par_aab (q : nat) (c : Alphabet) : option nat :=
match (q,c) with
 | (1,a) => Some 2
 | (1,b) => Some 5
 | (2,a) => Some 3
 | (2,b) => Some 5
 | (3,a) => Some 5
 | (3,b) => Some 4
 | (4,a) => Some 4
 | (4,b) => Some 5
 | (5,a) => Some 5
 | (5,b) => Some 5
 | (_,_) => None
end.

Definition M_commence_par_aab := automate [1;2;3;4] [a;b] (delta_commence_par_aab) 1 [4].

(* QUESTION 2b *)
(* Vérifiez que votre automate accepte les mots aab et aabaa, et refuse le mot vide et le mot bba. *)

Example M_commence_par_aab_refuse_vide : reconnait M_commence_par_aab [] = false.
cbv. reflexivity. Qed.

Example M_commence_par_aab_reconnait_aab : reconnait M_commence_par_aab [a;a;b] = true.
cbv. reflexivity. Qed.

Example M_commence_par_aab_reconnait_aabaa : reconnait M_commence_par_aab [a;a;b;a;a] = true.
cbv. reflexivity. Qed.

(* QUESTION 3a *)
(* Définissez "G_commence_par_aab" le PREDICAT "mot généré par G_commence_par_aab à partir du non-terminal i",
   correspondant à la grammaire générant le langage L. *)
(* Décommentez et complétez. *)
Inductive G_commence_par_aab : (list Alphabet) -> nat -> Prop :=
| G_commence_par_aab_0 : G_commence_par_aab [] 4
| G_commence_par_aab_1a : forall m, G_commence_par_aab m 2 -> G_commence_par_aab (a::m) 1
| G_commence_par_aab_1b : forall m, G_commence_par_aab m 5 -> G_commence_par_aab (b::m) 1
| G_commence_par_aab_2a : forall m, G_commence_par_aab m 3 -> G_commence_par_aab (a::m) 2
| G_commence_par_aab_2b : forall m, G_commence_par_aab m 5 -> G_commence_par_aab (b::m) 2
| G_commence_par_aab_3a : forall m, G_commence_par_aab m 5 -> G_commence_par_aab (a::m) 3
| G_commence_par_aab_3b : forall m, G_commence_par_aab m 4 -> G_commence_par_aab (b::m) 3
| G_commence_par_aab_4a : forall m, G_commence_par_aab m 4 -> G_commence_par_aab (a::m) 4
| G_commence_par_aab_4b : forall m, G_commence_par_aab m 4 -> G_commence_par_aab (b::m) 4
| G_commence_par_aab_5a : forall m, G_commence_par_aab m 5 -> G_commence_par_aab (a::m) 5
| G_commence_par_aab_5b : forall m, G_commence_par_aab m 5 -> G_commence_par_aab (b::m) 5
.
(* QUESTION 3b *)
(* Vérifiez que votre grammaire génère les mots aab et aabaaa à partir du non-terminal 1 *)

Example ex_G_commence_par_aab_1 : G_commence_par_aab [a;a;b] 1.
Proof.
  apply G_commence_par_aab_1a.
  apply G_commence_par_aab_2a.
  apply G_commence_par_aab_3b.
  apply G_commence_par_aab_0.
Qed.

Example G_commence_par_aab_1 : G_commence_par_aab [a;a;b;a;a;a] 1.
Proof.
  apply G_commence_par_aab_1a.
  apply G_commence_par_aab_2a.
  apply G_commence_par_aab_3b.
  apply G_commence_par_aab_4a.
  apply G_commence_par_aab_4a.
  apply G_commence_par_aab_4a.
  apply G_commence_par_aab_0.
Qed.

(*----------------------------------------------------------------------------*)

(* QUESTION 4a *)
(* Définissez un type "oiseau" avec trois éléments albatros, pigeon, manchot. *)

Inductive oiseau : Type :=
  | albatros : oiseau
  | pigeon : oiseau
  | manchot : oiseau.

(* QUESTION 4b *)
(* Définissez une fonction "comp_Oiseau" de comparaison de ce type. *)

Definition comp_Oiseau (O1 O2: oiseau) : bool :=
  match O1, O2 with
  | albatros, albatros => true
  | pigeon,   pigeon   => true
  | manchot,  manchot  => true
  | _,        _        => false
  end.

(* QUESTION 4c *)
(* Prouvez que votre fonction de comparaison est correcte. *)

Lemma comp_Oiseau_correct : forall x y, (comp_Oiseau x y) = true -> y = x.
Proof.
destruct x.
destruct y.
- simpl. reflexivity.
- discriminate.
- discriminate.
- destruct y.
  + discriminate.
  + reflexivity.
  + discriminate.
- destruct y.
  + discriminate.
  + discriminate.
  + reflexivity.
Qed.

(* QUESTION 4d *)
(* Prouvez que votre fonction de comparaison est complète. *)

Lemma comp_Oiseau_complet : forall x y, y = x -> (comp_Oiseau x y) = true.
Proof.
destruct x.
destruct y.
- reflexivity.
- discriminate.
- discriminate.
- destruct y.
  + discriminate.
  + reflexivity.
  + discriminate.
- destruct y.
  + discriminate.
  + discriminate.
  + reflexivity.
Qed.

(*----------------------------------------------------------------------------*)

(* QUESTION 5a *)
(* Définissez la fonction "take" qui prend en paramètre un entier n et une liste ls
              et retourne le préfixe de ls de longueur n.
   EXEMPLE : voir les tests unitaires ci-dessous
*)
Fixpoint take (n: nat) (ls: list nat) : list nat :=
  match ls with
  | [] => []
  | n'::l' => if (Nat.eqb n 0) then [] else n'::[] ++ (take (n-1) l')
  end.

(* Décommentez les exemples *)

Goal  take 0 [1;2;3;4;5] = [].
reflexivity.
Qed.

Goal  take 6 [1;2;3;4;5] = [1;2;3;4;5].
reflexivity.
Qed.

Goal  take 3 [1;2;3;4;5] = [1;2;3].
reflexivity.
Qed.

(* QUESTION 5b *)
(* Définissez la fonction "drop" qui prend en paramètre un entier n et une liste ls
              et retourne le suffixe de ls privée de ses n premiers éléments.
   EXEMPLE : voir les tests unitaires ci-dessous
*)
Fixpoint drop (n: nat) (l: list nat) : list nat :=
  match l with
  | [] => []
  | n'::l' => if (Nat.eqb n 0) then l else drop (n-1) l'
  end.

(* Décommentez les exemples *)

Goal  drop 0 [1;2;3;4;5] = [1;2;3;4;5].
reflexivity.
Qed.

Goal  drop 6 [1;2;3;4;5] = [].
reflexivity.
Qed.

Goal  drop 3 [1;2;3;4;5] = [4;5].
reflexivity.
Qed.

(*----------------------------------------------------------------------------*)


Require Export List.

Require Import CpdtTactics.
Require Import LibTactics.

(*
==================
Lemmas about find
==================
*)

Lemma find_notNone :
  forall A f l,
    find f l <> None <->
    exists (e : A), find f l = Some e.
Proof with eauto.
  induction l.
  + crush.
  + simpl. cases_if...
    split... congruence.
Qed.

Lemma find_in :
  forall A f l (x : A),
    find f l = Some x ->
    In x l.
Proof with auto.
  induction l as [| h t]; crush.
  cases_if; crush.
Qed.

Lemma find_true :
  forall A f l (x : A),
    find f l = Some x ->
    f x = true.
Proof with auto.
  introv Hfind. induction l.
  + inversion Hfind.
  + simpls. cases_if; crush.
Qed.

Lemma find_app :
  forall A f l1 l2 (x : A),
    find f l1 = Some x ->
    find f (l1 ++ l2) = Some x.
Proof with auto.
  introv Hfind. induction l1; simpl.
  + inversion Hfind.
  + simpls. cases_if; crush.
Qed.

Lemma find_app2 :
  forall A f l1 l2 (x : A),
    find f l2 = Some x ->
    find f l1 = None ->
    find f (l1 ++ l2) = Some x.
Proof with auto.
  induction l1; simpls...
  cases_if; crush.
Qed.

(*
==================
Lemmas about snoc
==================
*)

Fixpoint snoc {A:Type} (l : list A) (x : A):=
  match l with
    | nil => x :: nil
    | head :: tail => cons head (snoc tail x)
  end.

Lemma snoc_length :
  forall A l (x : A),
    length (snoc l x) = S (length l).
Proof.
  induction l; crush.
Qed.

Lemma snoc_in :
  forall A l (x : A),
    List.In x (snoc l x).
Proof with auto.
  induction l; crush.
Qed.

Lemma in_snoc :
  forall A l (x y : A),
    List.In x (snoc l y) <->
    List.In x l \/ x = y.
Proof.
  intros. induction l; crush.
Qed.

(*
====================
Lemmas about remove
====================
*)

Lemma remove_app :
  forall A l1 l2 (x:A) eq_dec,
    remove eq_dec x (l1 ++ l2) =
    remove eq_dec x l1 ++ remove eq_dec x l2.
Proof with auto.
  induction l1; simpls... intros.
  cases_if; crush.
Qed.

Hint Rewrite remove_app : remove.

Lemma remove_idempotence :
  forall A l (x:A) eq_dec,
    remove eq_dec x (remove eq_dec x l) =
    remove eq_dec x l.
Proof with auto.
  induction l; simpls; intros...
  repeat (elim eq_dec; simpl); crush.
Qed.

Hint Rewrite remove_idempotence : remove.

Lemma remove_commutative :
  forall A l (x y:A) eq_dec,
    remove eq_dec x (remove eq_dec y l) =
    remove eq_dec y (remove eq_dec x l).
Proof with auto.
  induction l; simpl; intros...
  repeat (elim eq_dec; simpl); crush.
Qed.

Hint Rewrite remove_commutative : remove.

Lemma remove_in :
  forall A l (x y : A) eq_dec,
    In x (remove eq_dec y l) ->
    In x l.
Proof with eauto.
  induction l; simpl; intros...
  cases_if; crush...
Qed.

Lemma remove_not_in :
  forall A l (x y : A) eq_dec,
    ~ In x l ->
    ~ In x (remove eq_dec y l).
Proof with eauto.
  induction l; simpl; intros...
  cases_if; crush...
Qed.

Hint Constructors NoDup.

Lemma remove_NoDup :
  forall A l (x : A) eq_dec,
  NoDup l ->
  NoDup (remove eq_dec x l).
Proof with eauto using remove_not_in.
  induction l; simpl; introv Hdup...
  inverts Hdup.
  cases_if...
Qed.

Lemma remove_in_eq :
  forall A l (x : A) eq_dec,
    ~In x (remove eq_dec x l).
Proof with eauto.
  introv.
  induction l...
  simpl. cases_if; crush.
Qed.

Lemma remove_in_neq :
  forall A l (x y : A) eq_dec,
    In x l ->
    x <> y ->
    In x (remove eq_dec y l).
Proof with eauto.
  introv HIn Hneq.
  induction l...
  simpl. cases_if; crush.
Qed.

Lemma remove_not_in_neq :
  forall A (x : A) y l eq_dec,
    x <> y ->
    ~ In x (remove eq_dec y l) ->
    ~ In x l.
Proof with eauto.
  introv Hneq HnIn.
  introv contra. apply HnIn.
  apply remove_in_neq...
Qed.

(*
==================
Lemmas about app
==================
*)

Lemma Forall_app :
  forall A P l1 l2,
    @Forall A P l1 ->
    Forall P l2 ->
    Forall P (l1 ++ l2).
Proof with auto.
  induction l1...
  introv Hforall.
  inversion Hforall.
  constructor...
Qed.

Lemma app_eq_nil :
  forall A l1 l2,
    l1 ++ l2 = nil <-> l1 = nil /\ l2 = @nil A.
Proof with auto using app_eq_nil.
  introv. split... crush.
Qed.

Corollary app_eq_nil_trivial :
  forall A l1 l2,
    l1 = @nil A ->
    l2 = @nil A ->
    l1 ++ l2 = @nil A.
Proof with auto.
  introv Hnil1 Hnil2. apply app_eq_nil...
Qed.

Hint Immediate app_eq_nil_trivial.

Lemma not_in_app :
  forall A l1 l2 (x : A),
    ~ In x (l1 ++ l2) <->
    (~ In x l1) /\ (~ In x l2).
Proof with eauto using in_or_app, in_cons, in_eq.
  intros A l1 l2 x.
  split.
  + introv Hin.
    induction l1...
    simpl in Hin.
    simpl.
    split.
    - intros contra.
      apply Hin. inversion contra...
    - intros contra...
  + introv HIn.
    inverts HIn as HIn1 HIn2.
    induction l1; simpl...
    intros contra.
    inversion contra.
    - apply HIn1. subst...
    - apply IHl1...
Qed.

Hint Constructors NoDup.

Lemma NoDup_app :
  forall A (l1 l2 : list A),
    NoDup (l1 ++ l2) ->
    NoDup l1 /\ NoDup l2.
Proof with eauto.
  introv Hdup.
  induction l1.
  + inversion Hdup...
  + inversion Hdup as [|? ? Hin Hdup'].
    apply IHl1 in Hdup' as (Hdup1 & Hdup2).
    split...
    econstructor...
    apply not_in_app in Hin as []...
Qed.

(*
===================
Lemmas about filter
===================
*)

Lemma filter_in :
  forall A (x : A) p l,
  (forall x y, p x y = true <-> x = y) ->
  (In x l <-> In x (filter (p x) l)).
Proof with eauto.
  introv Hp.
  split.
  + introv HIn. induction l;
    simpl; try(cases_if); crush.
    assert (Heq: x = x)...
    apply Hp in Heq. congruence.
  + introv HIn. induction l;
    simpls; try(cases_if); crush.
Qed.

Lemma filter_not_in :
  forall A (x : A) p l,
  (forall x y, p x y = true <-> x = y) ->
  (~In x l <-> (filter (p x) l) = nil).
Proof with eauto.
  introv Hp.
  split.
  + introv HnIn.
    induction l...
    simpl. cases_if; crush.
    apply Hp in H. false.
  + introv Hneq.
    induction l...
    simpls. cases_if; try(congruence).
    intros contra. inverts contra.
    - assert(p x x = true) by (apply Hp; eauto).
      congruence.
    - apply IHl...
Qed.

Lemma filter_length :
  forall A (l : list A) p,
    length (filter p l) <= length l.
Proof with eauto.
  introv.
  induction l...
  simpl. cases_if; crush.
Qed.

Lemma filter_app :
  forall A (l1 l2 : list A) p,
    filter p (l1 ++ l2) = (filter p l1) ++ (filter p l2).
Proof with eauto.
  introv.
  induction l1...
  simpl. cases_if; crush.
Qed.

(*
================
Lemmas about in
================
*)

Lemma in_comm :
  forall A l1 l2 (x : A),
    In x (l1 ++ l2) ->
    In x (l2 ++ l1).
Proof with eauto using in_or_app.
  introv HIn.
  apply in_app_or in HIn as []...
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_nom_reduce :
  forall T1 x1 L1 Ts1 T', T1 = (t_rfn_sel x1 L1 Ts1 T') ->
                     forall T2 L2 T2', T2 = t_nom L2 T2' ->
                                  subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import Program.Basics.
Require Import Strings.String.
Require Import Sect2.

Open Scope program_scope.

(*****************)
(* Lens approach *)
(*****************)

(* Here, we show the simplified version of the university example, which only
   requires lenses (Sect. 3.1). The traversal-based example serves us as
   motivation to introduce the rich set of optic abstractions, but doesn't add
   value to the rest of the paper. *)

(* Data layer *)

Record department := mkDepartment
{ budget : nat }.

Record university := mkUniversity
{ name : string
; mathDep : department
}.

Definition budgetLn : lens department nat :=
  mkLens budget (fun _ b' => mkDepartment b').

Definition mathDepLn : lens university department :=
  mkLens mathDep (fun u d' => mkUniversity (name u) d').

(* Business logic *)

Definition doubleDepBudget : department -> department :=
  budgetLn %~ (fun b => b * 2).

Definition doubleUnivBudget : university -> university :=
  mathDepLn %~ doubleDepBudget.

Definition doubleUnivBudget' : university -> university :=
  (mathDepLn ▷ budgetLn) %~ (fun b => b * 2).

(*******************************)
(* Algebraic theories approach *)
(*******************************)

(* Repository algebras *)

Class UniversityAlg (p : Type -> Type) :=
{ getName : p string
; modifyName (f : string -> string) : p unit
; getMathDep : p department
; modifyMathDep (f : department -> department) : p unit
(* ... *)
}.


Unset Automatic Introduction.

Inductive identity {X} (x:X) : X -> Type :=
  id : identity x x.

Notation "x == y" := (identity x y) (at level 70).

Definition iscontr X := { x:X & forall y, x == y }.

Definition fiber {X Y} (f:X->Y) (y:Y) := { x:X & f x == y }.

Definition isequiv {X Y} (f:X->Y) := forall y, iscontr (fiber f y).

Lemma idfun_isequiv X : isequiv (fun x:X => x).
Proof. intros.
       unfold isequiv.
       intros.
       unfold iscontr.
       refine (existT _ _ _).
       - unfold fiber.
         refine (existT _ _ _).
         + exact y.
         + exact (id y).
       - intro p.
         induction p.
         induction p.
         exact (id _).
Qed.

Definition equiv X Y := { f:X->Y & isequiv f }.

Notation "X ~~ Y" := (equiv X Y) (at level 70).

Definition phi X Y : X==Y -> X~~Y.
  intros X Y p.
  induction p.
  refine (existT _ _ _).
  - exact (fun x:X => x).
  - exact (idfun_isequiv X).
Defined.

Axiom univalence : forall X Y, isequiv (phi X Y).


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import  Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import  Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ExtensionTactic.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Section RewriteClass1.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}.

Instance andp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) andp.
Proof.
  clear - minAX andpAX.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  rewrite provable_derivable.
  rewrite <- !deduction_theorem.
  apply (deduction_weaken0 (Union expr empty_context (Singleton expr (x1 && y1)))) in H.
  apply (deduction_weaken0 (Union expr empty_context (Singleton expr (x1 && y1)))) in H0.
  pose proof derivable_assum1 empty_context (x1 && y1).
  pose proof deduction_andp_elim1 _ _ _ H1.
  pose proof deduction_andp_elim2 _ _ _ H1.
  pose proof deduction_modus_ponens _ _ _ H2 H.
  pose proof deduction_modus_ponens _ _ _ H3 H0.
  apply deduction_andp_intros; auto.
Qed.

Instance orp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) orp.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  apply orp_mono; auto.
Qed.

Instance negp_proper_impp: Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y)) negp.
Proof.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  pose proof negp_unfold x1. rewrite H0.
  pose proof negp_fold x2. rewrite <- H1.
  apply impp_proper_impp; auto.
  apply provable_impp_refl.
Qed.

Instance provable_iffp_rewrite: RewriteRelation (fun x y => |-- x <--> y).
Qed.

Instance provable_iffp_equiv: Equivalence (fun x y => |-- x <--> y).
Proof.
  clear - minAX iffpAX.
  AddSequentCalculus.
  constructor.
  + hnf; intros.
    rewrite provable_derivable.
    apply deduction_iffp_intros; apply deduction_theorem; apply derivable_impp_refl.
  + hnf; intros.
    rewrite provable_derivable in H |- *.
    pose proof deduction_iffp_elim1 _ _ _ H.
    pose proof deduction_iffp_elim2 _ _ _ H.
    apply deduction_iffp_intros; auto.
  + hnf; intros.
    rewrite provable_derivable in H, H0 |- *.
    pose proof deduction_iffp_elim1 _ _ _ H; apply deduction_theorem in H1.
    pose proof deduction_iffp_elim2 _ _ _ H; apply deduction_theorem in H2.
    pose proof deduction_iffp_elim1 _ _ _ H0; apply deduction_theorem in H3.
    pose proof deduction_iffp_elim2 _ _ _ H0; apply deduction_theorem in H4.
    apply deduction_iffp_intros; apply deduction_theorem.
    - apply (deduction_impp_trans _ _ _ _ H1 H3).
    - apply (deduction_impp_trans _ _ _ _ H4 H2).
Qed.

Instance provable_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> iff) provable.
Proof.
  clear - minAX iffpAX.
  AddSequentCalculus.
  intros.
  hnf; intros.
  rewrite provable_derivable in H.
  rewrite provable_derivable.
  rewrite provable_derivable.
  pose proof deduction_iffp_elim1 _ _ _ H; apply deduction_theorem in H0.
  pose proof deduction_iffp_elim2 _ _ _ H; apply deduction_theorem in H1.
  split; intro;
  eapply deduction_modus_ponens; eauto.
Qed.

Instance impp_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) impp.
Proof.
  clear - minAX iffpAX.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  rewrite provable_derivable in H.
  rewrite provable_derivable in H0.
  rewrite provable_derivable.
  pose proof deduction_iffp_elim1 _ _ _ H; apply deduction_theorem in H1.
  pose proof deduction_iffp_elim2 _ _ _ H; apply deduction_theorem in H2.
  pose proof deduction_iffp_elim1 _ _ _ H0; apply deduction_theorem in H3.
  pose proof deduction_iffp_elim2 _ _ _ H0; apply deduction_theorem in H4.
  rewrite <- provable_derivable in H1.
  rewrite <- provable_derivable in H2.
  rewrite <- provable_derivable in H3.
  rewrite <- provable_derivable in H4.
  apply deduction_iffp_intros; apply deduction_theorem; rewrite <- provable_derivable.
  + apply impp_proper_impp; auto.
  + apply impp_proper_impp; auto.
Qed.

Instance andp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) andp.
Proof.
  clear - minAX iffpAX andpAX.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  rewrite provable_derivable in H.
  rewrite provable_derivable in H0.
  rewrite provable_derivable.
  pose proof deduction_iffp_elim1 _ _ _ H; apply deduction_theorem in H1.
  pose proof deduction_iffp_elim2 _ _ _ H; apply deduction_theorem in H2.
  pose proof deduction_iffp_elim1 _ _ _ H0; apply deduction_theorem in H3.
  pose proof deduction_iffp_elim2 _ _ _ H0; apply deduction_theorem in H4.
  rewrite <- provable_derivable in H1.
  rewrite <- provable_derivable in H2.
  rewrite <- provable_derivable in H3.
  rewrite <- provable_derivable in H4.
  apply deduction_iffp_intros; apply deduction_theorem; rewrite <- provable_derivable.
  + apply andp_proper_impp; auto.
  + apply andp_proper_impp; auto.
Qed.

Instance orp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) orp.
Proof.
  clear - minAX iffpAX orpAX.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  rewrite provable_derivable in H.
  rewrite provable_derivable in H0.
  rewrite provable_derivable.
  pose proof deduction_iffp_elim1 _ _ _ H; apply deduction_theorem in H1.
  pose proof deduction_iffp_elim2 _ _ _ H; apply deduction_theorem in H2.
  pose proof deduction_iffp_elim1 _ _ _ H0; apply deduction_theorem in H3.
  pose proof deduction_iffp_elim2 _ _ _ H0; apply deduction_theorem in H4.
  rewrite <- provable_derivable in H1.
  rewrite <- provable_derivable in H2.
  rewrite <- provable_derivable in H3.
  rewrite <- provable_derivable in H4.
  apply deduction_iffp_intros; apply deduction_theorem; rewrite <- provable_derivable.
  + apply orp_proper_impp; auto.
  + apply orp_proper_impp; auto.
Qed.

Instance iffp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) iffp.
Proof.
  clear - minAX iffpAX.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  rewrite provable_derivable.
  apply deduction_iffp_intros; apply deduction_iffp_intros; rewrite !deduction_theorem; rewrite <- provable_derivable.
  +rewrite <- H. rewrite <- H0. apply iffp_elim1.
  +rewrite <- H. rewrite <- H0. apply iffp_elim2.
  +rewrite -> H. rewrite -> H0. apply iffp_elim1.
  +rewrite -> H. rewrite -> H0. apply iffp_elim2.
Qed.

Instance negp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) negp.
Proof.
  AddSequentCalculus.
  hnf; intros x1 x2 ?.
  pose proof negp_fold_unfold x1. rewrite H0.
  pose proof negp_fold_unfold x2. rewrite H1.
  apply impp_proper_iffp; auto.
  apply provable_iffp_refl.
Qed.

End RewriteClass1.

Section RewriteClass2.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {GammaPD: ProvableDerivable L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {andpSC: AndSequentCalculus L GammaD}
        {orpSC: OrSequentCalculus L GammaD}
        {falsepSC: FalseSequentCalculus L GammaD}
        {inegpSC: IntuitionisticNegSequentCalculus L GammaD}
        {iffpSC: IffSequentCalculus L GammaD}
        {truepSC: TrueSequentCalculus L GammaD}.

Instance derivable_proper_iffp : Proper (eq ==> (fun x y => |-- x <--> y) ==> iff) derivable.
Proof.
  hnf; intros Phi Phi' ?; subst Phi'.
  hnf; intros x1 x2 ?.
  apply (deduction_weaken0 Phi) in H.
  pose proof deduction_iffp_elim1 _ _ _ H; rewrite deduction_theorem in H0.
  pose proof deduction_iffp_elim2 _ _ _ H; rewrite deduction_theorem in H1.
  split; intro;
  eapply deduction_modus_ponens; eauto.
Qed.

End RewriteClass2.

Section RewriteClass3.

Context {L: Language}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}.

Section impp.

Context {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {adjD: ImpAndAdjointDeduction L GammaD1}
        {andpD: AndDeduction L GammaD1}.

Instance impp_proper_derivable1:
  Proper (derivable1 --> derivable1 ==> derivable1) impp.
Proof.
  hnf;intros.
  hnf;intros.
  apply derivable1_impp_mono; auto.
Qed.

End impp.

Section andp.

Context {andpL: AndLanguage L}
        {andpD: AndDeduction L GammaD1}.

Instance andp_proper_derivable1: Proper (derivable1 ==> derivable1 ==> derivable1) andp.
Proof.
  hnf;intros.
  hnf;intros.
  apply derivable1_andp_intros.
  -pose proof derivable1_andp_elim1 x x0.
   pose proof derivable1_trans _ _ _ H1 H. auto.
  -pose proof derivable1_andp_elim2 x x0.
   pose proof derivable1_trans _ _ _ H1 H0. auto.
  Qed.

End andp.

Section orp.

Context {orpL: OrLanguage L}
        {orpD: OrDeduction L GammaD1}.

Instance orp_proper_derivable1: Proper (derivable1 ==> derivable1 ==> derivable1) orp.
Proof.
  hnf;intros.
  hnf;intros.
  apply derivable1_orp_elim.
  -pose proof derivable1_orp_intros1 y y0.
   pose proof derivable1_trans _ _ _ H H1;auto.
  -pose proof derivable1_orp_intros2 y y0.
   pose proof derivable1_trans _ _ _ H0 H1;auto.
Qed.

End orp.

Section negp.

Context {negpL: NegLanguage L}
        {inegpD: IntuitionisticNegDeduction L GammaD1}.

Instance negp_proper_derivable1: Proper (derivable1 --> derivable1) negp.
Proof.
  hnf;intros.
  unfold Basics.flip in H.
  apply derivable1_contrapositivePP'.
  auto.
Qed.

End negp.

End RewriteClass3.

Section RewriteClass4.

Context {L: Language}
        {GammaE: LogicEquiv L}
        {bE: BasicLogicEquiv L GammaE}.

Section impp.

Context {minL: MinimumLanguage L}
        {imppE: ImpLogicEquiv L GammaE}.

Instance impp_proper_equiv:
  Proper (logic_equiv ==> logic_equiv ==> logic_equiv) impp.
Proof.
  hnf;intros.
  hnf;intros.
  unfold Basics.flip in H.
  pose proof logic_equiv_impp _ _ _ _ H H0.
  auto.
Qed.

End impp.

Section andp.

Context {andpL: AndLanguage L}
        {andpE: AndLogicEquiv L GammaE}.

Instance andp_proper_equiv: Proper (logic_equiv ==> logic_equiv ==> logic_equiv) andp.
Proof.
  hnf;intros.
  hnf;intros.
  apply logic_equiv_andp_congr;[auto|auto].
  Qed.

End andp.

Section orp.

Context {orpL: OrLanguage L}
        {orpE: OrLogicEquiv L GammaE}.

Instance orp_proper_equiv: Proper (logic_equiv ==> logic_equiv ==> logic_equiv) orp.
Proof.
  hnf;intros.
  hnf;intros.
  apply logic_equiv_orp_congr;[auto|auto].
  Qed.

End orp.

Section negp.

Context {negpL: NegLanguage L}
        {negpE: NegLogicEquiv L GammaE}.

Instance negp_proper_equiv: Proper (logic_equiv  ==> logic_equiv ) negp.
Proof.
  hnf;intros.
  apply logic_equiv_negp_intros;auto.
  Qed.

End negp.

Section iffp.

Context {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {iffpL: IffLanguage L}
        {imppL: ImpLogicEquiv L GammaE}
        {andpE: AndLogicEquiv L GammaE}
        {iffpE: IffLogicEquiv L GammaE}.

Instance iffp_proper_equiv: Proper (logic_equiv  ==> logic_equiv ==> logic_equiv) iffp.
Proof.
  hnf;intros.
  hnf;intros.
  pose proof logic_equiv_iffp_intros x x0.
  pose proof logic_equiv_iffp_intros y y0.
  apply logic_equiv_trans with ((x --> x0) && (x0 --> x)).
  apply logic_equiv_symm;auto.
  apply logic_equiv_symm.
  apply logic_equiv_trans with ((y --> y0) && (y0 --> y)).
  apply logic_equiv_symm;auto.
  apply logic_equiv_andp_congr.
  -apply logic_equiv_impp.
   apply logic_equiv_symm;auto.
   apply logic_equiv_symm;auto.
  -apply logic_equiv_impp.
   apply logic_equiv_symm;auto.
   apply logic_equiv_symm;auto.
  Qed.

End iffp.

End RewriteClass4.

Existing Instances andp_proper_impp orp_proper_impp negp_proper_impp
                   provable_iffp_rewrite provable_iffp_equiv
                   provable_proper_iffp derivable_proper_iffp
                   impp_proper_iffp andp_proper_iffp orp_proper_iffp
                   iffp_proper_iffp negp_proper_iffp
                   impp_proper_equiv
                   andp_proper_equiv orp_proper_equiv
                   negp_proper_equiv iffp_proper_equiv
                   andp_proper_derivable1 orp_proper_derivable1
                   negp_proper_derivable1 impp_proper_derivable1.


Require Import Coinduc.

Section counter_example.
 Let A : Set := nat.
 Let P l := match l with (LCons 0 l') => True
                        | other       => False
                    end.
 Let u := repeat 1.
 Let v := LCons 0 LNil.

 Lemma L1 : satisfies v (Eventually P).
 Proof.
  unfold v, P;  left ; trivial.
 Qed.

 Lemma L2 : u = (LCons 1 u).
 Proof.
  unfold u; apply repeat_unfold.
 Qed.

 Lemma L3 : forall (w: LList nat), satisfies w (Eventually P) ->
                                   exists n : nat, LNth n w = Some 0.
 Proof.
  induction 1.
  generalize H; case a;  simpl in H.
  exists 0.
  simpl.
  trivial.
  simpl.
  contradiction.
  case IHEventually; intros p Hp.
  exists (S p);simpl; auto.
 Qed.

 Lemma L4 : (bisimilar u (LAppend u v)).
 Proof.
   apply LAppend_of_Infinite_eq.
    unfold u;  apply repeat_infinite.
 Qed.

 Lemma L5 : forall n, LNth n u = Some 1.
 Proof.
  simple induction n.
  rewrite L2.
  simpl.
  trivial.
  intros n0 H0; rewrite L2; simpl; auto.
 Qed.

 Lemma L6 : forall n, LNth n (LAppend u v) = Some 1.
 Proof.
  intro n;  transitivity (LNth n u).
   apply bisimilar_LNth.
   generalize (bisimilar_sym (A:=nat)).
   Import Relations.
   unfold symmetric.
   intro H;apply H.
   apply L4.
   apply L5.
 Qed.

 Lemma L7 : ~(satisfies (LAppend u v) (Eventually P)).
 Proof.
  intro H.
  case (L3  _ H).
  intros n  H1.
  generalize (L6 n).
  rewrite  H1.
  discriminate 1.
 Qed.

End counter_example.


Require Import Framework.
Require Import Tactics.
Require Import MySetoids.
Require Import Monoids.
Require Import Setof.
Require Import Utf8.
Require Import Language.
Require Import Bool.

Module AtomicSL (Import ats : Language.Atomics)
   (Import bs : Language.BasicSyntaxT ats)
   (Import st : Language.StateTransformers ats)
   (* Take a model of SL as an argument *)
   (Import dcsl : SafetyParams ats st) .

   (* Get Safety proof for the DCSL *)
   Module DCSLSafety := Safety ats bs st dcsl.

   (* TODO: Fix to make this a module type *)
   Instance dcsl_monoid : Monoid dcsl.op.
   Admitted.
   (* Assume some axioms for DCSL *)
   Parameter Axioms : dcsl.V -> ats.Atomic -> dcsl.V -> Prop.

   (* Assume they satisfy asat for DCSL *)
   Axiom dcslaxiomsound :
 	forall p a q, Axioms p a q
                     -> DCSLSafety.asat p (st.interp a) q.

   Inductive ASL : V -> V -> bs.Syntax -> V -> Prop
   :=
     | atom : forall (I p q: dcsl.V)(a : Atomic),
                  Axioms (I * p) a (I * q)
                  -> ASL I p (atom a) q
     | skip : forall (I p : V),
                  ASL I p skip p
     | loop : forall (I p : V) c,
                  ASL I p c p
                  -> ASL I p (loop c) p
     | sequence : forall (I p q r : V) c1 c2,
                  ASL I p c1 q
                  -> ASL I q c2 r
                  -> ASL I p (sequence c1 c2) r
     | choice   : forall (I p q : V) c1 c2,
                  ASL I  p c1 q
                  -> ASL I p c2 q
                  -> ASL I p (choice c1 c2) q

     | parallel : forall (I p1 q1 p2 q2 : V) c1 c2,
                  ASL I p1 c1 q1
                  -> ASL I p2 c2 q2
                  -> ASL I
                        (p1 * p2)
                        (parallel c1 c2)
                        (q1 * q2)
     | hide : forall (I I' p q : V) c,
                  ASL I p c q
                  -> ASL (I * I') p c q
     | share : forall (I I' p q : V) c,
                  ASL (I * I') p c q
                  -> ASL I (p * I') c (q * I')
  .

  Module ASLSafetyParams.
     (* The natural encoding doesn't have a single unit *)
     Inductive V_pre :=
     | def : dcsl.V -> dcsl.V -> V_pre
     | undef.
     Definition V := V_pre.

    Definition V_equiv v1 v2:=
    match v1,v2 with
    | undef,undef => True
    | def v11 v12, def v21 v22 => v11==v21 /\ v12==v22
    | _,_ => False
    end.
    Ltac destructV := match goal with H: V_pre |- _ => destruct H end.
    Instance veq: Equivalence V_equiv.
    split; repeat intro; repeat destructV; repeat ssubst; firstorder;
    repeat ssubst; reflexivity.
    Qed.
    Program Instance V_pre_setoid : Setoid V_pre.
    Program Instance V_setoid : Setoid V.
    Instance def_morph : Proper (equiv ==> equiv ==> equiv) def.
     firstorder. Qed.

     (* Assume we can decide
         equality on dcsl propositions *)
Require Import MyClassical.
     Definition equal_dec (v1 v2 : dcsl.V) := to_bool (v1 == v2).
     Lemma equal_dec_def :
       forall v1 v2, equal_dec v1 v2 = true <-> v1 == v2.
     unfold equal_dec; intros; rewrite to_bool_defn. reflexivity.
     Qed.

     Definition op v1 v2:=
       match v1,v2 with
       | def I1 p1, def I2 p2 =>
          if equal_dec I1 I2 then def I1 (p1 * p2) else undef
       | undef,_ | _,undef => undef
       end.

    Lemma aslop_commut : forall a1 a2, op a1 a2 == op a2 a1 .
    intros; repeat destructV; simpl; repeat autodestruct;
       simpl; repeat rewrite <- not_true_iff_false in *;
       repeat rewrite equal_dec_def in *;
       trivial; try (firstorder; fail).
    rewrite  op_commut.
    intuition.
    Qed.

    Lemma aslop_assoc :
       forall a1 a2 a3, op (op a1 a2) a3 == op a1 (op a2 a3).
    intros; repeat destructV;
       repeat (simpl; autodestruct);
       simpl; repeat rewrite <- not_true_iff_false in *;
       repeat rewrite equal_dec_def in *;
    repeat rewrite op_assoc; repeat ssubst; firstorder.
    Qed.

    Instance opmorph : Proper (equiv ==> equiv ==> equiv) op.
    repeat (trivial; (intro || destructV || simpl in * || autodestruct));
    repeat rewrite <- not_true_iff_false in *;
    repeat rewrite equal_dec_def in *;
    repeat (splitup || ssubst); firstorder.
    Qed.

    Program Instance aslop_zero : Zero op := { zero := undef }.
    Next Obligation. intros; rewrite aslop_commut. firstorder. Qed.
    Instance aslop_zeros : Zeros op := zeros_zero op.

    Program Instance aslop_many_units : ManyUnits op.
    Next Obligation.
      destructV.
      2: exists undef; split; simpl; trivial.
      2: intros; right; exists undef; rewrite aslop_commut; simpl; intuition.
      exists (def v unit).
      simpl.
      autodestruct.
      rewrite unit_runit.
      split; try reflexivity.
      intros. destructV.
      2: simpl; left; reflexivity.
      simpl. autodestruct.
        left; rewrite unit_runit; reflexivity.
        right; intuition. exists undef. split; reflexivity.

      simpl; repeat rewrite <- not_true_iff_false in *;
      repeat rewrite equal_dec_def in *; firstorder.
    Qed.

    Instance op_monoid : SemiGroup op
      :={
        op_morphism := opmorph;
        op_assoc := aslop_assoc
      }.

    Instance op_comm : Commutative op := {op_commut := aslop_commut}.

    Definition erase  v : (Setof (A:=State)) :=
                  match v with
                  | undef => emptyset
                  | def I' P => dcsl.erase (I' * P)
                  end.

    Instance erase_morphism : Proper (equiv ==> equiv) erase.
    repeat (intro || destructV);
    simpl in *; intros; repeat splitup;
      try (firstorder; fail).
    repeat ssubst; reflexivity.
    Qed.
  End ASLSafetyParams.

  Import ASLSafetyParams.

  Module Import ASLSafety := Safety ats bs st ASLSafetyParams.

  Program Instance ze : ZeroErase .
  Next Obligation. firstorder. Qed.

  Instance zse : ZerosErase := ze_zse ze.

  Definition hide_fun I' V' :=
     match V' with
     | def I1 P1  => def (I1 * I') P1
     | undef => undef
     end.

  Definition share_fun I I' V' :=
     match V' with
     | def I1 P1  =>
	if equal_dec I1 (I * I') then def I (P1* I') else undef
     | undef => undef
     end.

  Lemma soundness_pre :
     forall I1 p q c (Hrg: ASL I1 p c q),
         Safe (def I1 p) c (def I1 q).
  induction 1; subst; eauto.

  (* Axiom case *)
   intros.
   eapply Safe_asat2.
   intros r; destruct r; simpl; repeat autodestruct; simpl;
   repeat rewrite <- op_assoc;
   try eapply dcslaxiomsound; eauto;
    compute; firstorder.

   (* Parallel case *)
   eapply Safe_para_equiv; eauto;
      simpl; repeat autodestruct; try split; try reflexivity;
      repeat rewrite <- not_true_iff_false in *;
      repeat rewrite equal_dec_def in *;
      match goal with H : not(?I==?I) |- _
         => elim H; reflexivity end.

   (* Hide rule *)
     assert (def (I * I') p == (hide_fun I' (def I p))).
       firstorder.
     assert (def (I * I') q == (hide_fun I' (def I q))).
       firstorder.
     rewrite H; rewrite H0. clear H; clear H0.
     eapply (simulation_rule_fun2 (hide_fun I')); eauto.
     unfold asat. intros x; destruct x; simpl.
     (* undef cases are trivial*)
     2: simpl; intros; intro; simpl; firstorder.
     (* def case *)
     intros y a Hframe.
      (* frame like case *)
      intro r.
      destruct r; simpl.
      2: intro; simpl; firstorder.
      autodestruct.
      2: intro; simpl; firstorder.
      generalize (Hframe (def v (I' * v2))).
      autodestruct.
      2:  repeat rewrite <- not_true_iff_false in *;
          repeat rewrite equal_dec_def in *;
          elim H0; reflexivity.
      clear H0.
      simpl.
      repeat rewrite equal_dec_def in *.
      rewrite <- H. clear H.
      rewrite <- (op_assoc v0).
      rewrite (op_commut v0).
      repeat rewrite op_assoc.
      intro Hre; rewrite Hre; clear Hre.
      destruct y.
      2: intro; simpl; firstorder.
      intro; simpl.
      repeat autodestruct; simpl; try contradiction;
      repeat rewrite <- not_true_iff_false in *;
      repeat rewrite equal_dec_def in *;
      rewrite H in *; clear H.
      2: elim H0; reflexivity.
      rewrite <- (op_assoc v4).
      rewrite (op_commut v4).
      repeat rewrite op_assoc.
      trivial.

    (* Share rule *)
    cut (share_fun I I' (def (I * I') p) == def I (p * I')).
    cut (share_fun I I' (def (I * I') q) == def I (q * I')).
    intro H; rewrite <- H. clear H.
    intro H; rewrite <- H. clear H.
    Focus 2.
       clear; compute -[equal_dec]; autodestruct.
       split; reflexivity.
       repeat rewrite <- not_true_iff_false in *;
       repeat rewrite equal_dec_def in *;
       elim H; reflexivity.
    Focus 2.
       clear; compute -[equal_dec]; autodestruct.
       split; reflexivity.
       repeat rewrite <- not_true_iff_false in *;
       repeat rewrite equal_dec_def in *;
       elim H; reflexivity.
    eapply (simulation_rule_fun2 (share_fun I I')); eauto.
    clear Hrg. clear IHHrg.
    destruct x.
    2: compute; firstorder.
    simpl.
    autodestruct.
    2: compute; firstorder.
    intros y a Hasat r.
    destruct r.
    2: compute; firstorder.
    simpl.
    autodestruct.
    2: compute; firstorder.
    repeat rewrite equal_dec_def in *.
    rewrite <- H0 in *. clear H0.
    rewrite H in *. clear H.
    generalize (Hasat (def (I * I') v2)). clear Hasat.
    simpl.
    autodestruct.
    2: repeat rewrite <- not_true_iff_false in *;
       repeat rewrite equal_dec_def in *;
       elim H; reflexivity.
    clear H.
    simpl.
    rewrite op_assoc.
    rewrite (op_commut v0 I').
    rewrite op_assoc.
    intros Hre. rewrite  Hre.
    clear Hre.
    destruct y.
    2: compute; firstorder.
    simpl.
    autodestruct.
    2: compute; firstorder.
    repeat rewrite equal_dec_def in *; rewrite H.
    clear H.
    simpl.
    autodestruct.
    2: repeat rewrite <- not_true_iff_false in *;
       repeat rewrite equal_dec_def in *;
       elim H; reflexivity.
    rewrite (op_commut v4 I').
    simpl.
    repeat rewrite op_assoc. reflexivity.
  Qed.
End AtomicSL.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

(* Why3 assumption *)
Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Axiom list_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (list a).
Existing Instance list_WhyType.
Implicit Arguments Nil [[a]].
Implicit Arguments Cons [[a]].

Parameter num_occ: forall {a:Type} {a_WT:WhyType a}, a -> (list a) -> Z.

Axiom num_occ_def : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)),
  match l with
  | Nil => ((num_occ x l) = 0%Z)
  | (Cons y r) => ((x = y) -> ((num_occ x l) = (1%Z + (num_occ x r))%Z)) /\
      ((~ (x = y)) -> ((num_occ x l) = (0%Z + (num_occ x r))%Z))
  end.

Axiom Num_Occ_NonNeg : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (0%Z <= (num_occ x l))%Z.

(* Why3 assumption *)
Fixpoint mem {a:Type} {a_WT:WhyType a} (x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.

Axiom Mem_Num_Occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)), (mem x l) <-> (0%Z < (num_occ x l))%Z.

(* Why3 assumption *)
Fixpoint infix_plpl {a:Type} {a_WT:WhyType a} (l1:(list a)) (l2:(list
  a)) {struct l1}: (list a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.

Axiom Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((infix_plpl l (Nil : (list a))) = l).

(* Why3 assumption *)
Fixpoint length {a:Type} {a_WT:WhyType a} (l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.

Axiom Length_nonnegative : forall {a:Type} {a_WT:WhyType a}, forall (l:(list
  a)), (0%Z <= (length l))%Z.

Axiom Length_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil : (list a))).

Axiom Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), ((length (infix_plpl l1
  l2)) = ((length l1) + (length l2))%Z).

Axiom mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x
  l2)).

Axiom mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)), (mem x l) -> exists l1:(list a), exists l2:(list a),
  (l = (infix_plpl l1 (Cons x l2))).

Axiom Append_Num_Occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), ((num_occ x (infix_plpl l1 l2)) = ((num_occ x
  l1) + (num_occ x l2))%Z).

(* Why3 assumption *)
Fixpoint reverse {a:Type} {a_WT:WhyType a} (l:(list a)) {struct l}: (list
  a) :=
  match l with
  | Nil => (Nil : (list a))
  | (Cons x r) => (infix_plpl (reverse r) (Cons x (Nil : (list a))))
  end.

Axiom reverse_append : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (x:a), ((infix_plpl (reverse (Cons x l1))
  l2) = (infix_plpl (reverse l1) (Cons x l2))).

Axiom reverse_cons : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a))
  (x:a), ((reverse (Cons x l)) = (infix_plpl (reverse l) (Cons x (Nil : (list
  a))))).

Axiom cons_reverse : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a))
  (x:a), ((Cons x (reverse l)) = (reverse (infix_plpl l (Cons x (Nil : (list
  a)))))).

Axiom reverse_reverse : forall {a:Type} {a_WT:WhyType a}, forall (l:(list
  a)), ((reverse (reverse l)) = l).

Axiom reverse_mem : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a))
  (x:a), (mem x l) <-> (mem x (reverse l)).

Axiom Reverse_length : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length (reverse l)) = (length l)).

Axiom reverse_num_occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), ((num_occ x l) = (num_occ x (reverse l))).

(* Why3 assumption *)
Definition permut {a:Type} {a_WT:WhyType a} (l1:(list a)) (l2:(list
  a)): Prop := forall (x:a), ((num_occ x l1) = (num_occ x l2)).

Axiom Permut_refl : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  (permut l l).

Axiom Permut_sym : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), (permut l1 l2) -> (permut l2 l1).

Axiom Permut_trans : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), (permut l1 l2) -> ((permut l2 l3) -> (permut
  l1 l3)).

Axiom Permut_cons : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (permut l1 l2) -> (permut (Cons x l1) (Cons x l2)).

Axiom Permut_swap : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a)
  (l:(list a)), (permut (Cons x (Cons y l)) (Cons y (Cons x l))).

Axiom Permut_cons_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), (permut (infix_plpl (Cons x l1) l2)
  (infix_plpl l1 (Cons x l2))).

Axiom Permut_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), (permut (infix_plpl (infix_plpl l1 l2) l3)
  (infix_plpl l1 (infix_plpl l2 l3))).

Axiom Permut_append : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (k1:(list a)) (k2:(list a)), (permut l1 k1) -> ((permut l2
  k2) -> (permut (infix_plpl l1 l2) (infix_plpl k1 k2))).

Axiom Permut_append_swap : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list
  a)) (l2:(list a)), (permut (infix_plpl l1 l2) (infix_plpl l2 l1)).

Axiom Permut_mem : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (permut l1 l2) -> ((mem x l1) -> (mem x l2)).

(* Why3 goal *)
Theorem Permut_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list
  a)) (l2:(list a)), (permut l1 l2) -> ((length l1) = (length l2)).
intros a a_WT l1 l2 h1.
Require Import Why3.
Ltac cvc := why3 "CVC4,1.4,".
generalize dependent l2.
induction l1; intros.
destruct l2.
trivial.
cvc.
pose (h2 := h1).
clearbody h2.
specialize (h1 a0).
assert (mem a0 l2) by cvc.
apply mem_decomp in H.
destruct H as [l3 [l4 H]].
assert (permut l1 (infix_plpl l3 l4)).
intro.
cvc.
cvc.
Qed.