(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)

Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
From Turing Require Import Lang.
From Turing Require Import Util.
Import LangNotations.
Import ListNotations.
Import Lang.Examples.
Open Scope lang_scope.
Open Scope char_scope.

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

(**

Show that any word that is in L4 is either empty or starts with "a".

 *)
Theorem ex1:
  forall w, L4 w -> w = [] \/ exists w', w = "a" :: w'.
Proof.
  intros.
  destruct H.
  destruct x.
  - Search (_>>_).
    apply pow_pow_in_inv in H.
    simpl in H.
    left.
    rewrite H.
    easy.
  - apply pow_pow_in_inv in H.
    simpl in H.
    right.
    exists (pow1 "a" x ++ "b" :: pow1 "b" x).
    apply H.
Qed.

(**

Show that the following word is accepted by the given language.

 *)
Theorem ex2:
  In ["a"; "b"; "b"; "a"] ("a" >> "b" * >> "a").
Proof.
  Search (_>>_).
  apply app_assoc_in_1.
  Search (_>>_).
  apply app_l_char_in.
  Search (_>>_).
  apply app_in with (w1:=["b";"b"]) (w2:=["a"]).
  - Search (_>>_).
    apply pow_to_star with (n:=2) .
    Search (In _ (_^^ _)).
    apply pow_char_in.
  - Search (In _ (_) ).
    apply char_in.
  - easy.
Qed.

(**

Show that the following word is rejected by the given language.

 *)
Theorem ex3:
  ~ In ["b"; "b"] ("a" >> "b" * >> "a").
Proof.
  intros s.
  Search (_>>_).
  apply app_assoc_in_2 in s.
  Search (_>>_).
  apply app_l_char_in_inv with (c:="a") in s.
  destruct s.
  destruct H.
  easy.
Qed.

(**

Show that the following language is empty.

 *)
Theorem ex4:
  "0" * >> {} == {}.
Proof.
 apply app_r_void_rw.
Qed.

(**

Rearrange the following terms. Hint use the distribution and absorption laws.

 *)
Theorem ex5:
  ("0" U Nil) >> ( "1" * ) == ( "0" >> "1" * ) U ( "1" * ).
Proof.
  unfold Equiv; intros.
  - rewrite <- app_union_distr_l.
    Search (Nil).
    rewrite app_l_nil_rw.
    reflexivity.
Qed.

(**

Show that the following langue only accepts two words.

 *)
Theorem ex6:
  ("0" >> "1" U "1" >> "0") == fun w => (w = ["0"; "1"] \/ w = ["1"; "0"]).
Proof. unfold Equiv.
  split; intros.
  - unfold Union, In, App in *.
    destruct H. destruct H as (x, (x0, H)).
    left.
    -- destruct H. rewrite H. inversion H0.
       unfold Char in *. rewrite H1. rewrite H2. reflexivity.
    -- right. destruct H as (x, (x0, (H, (H0, H1)))).
       unfold Char in *.
       rewrite H, H0, H1.
       reflexivity.
  - unfold In, Union, App in *. destruct H.
    -- left. exists ["0"], ["1"]. split.
       * rewrite H. reflexivity.
       * split.
          ** unfold Char; reflexivity.
          ** unfold Char; reflexivity.
    -- unfold In, Union, App. right. exists ["1"], ["0"]. split.
       * rewrite H. reflexivity.
       * split.
         ** unfold Char; reflexivity.
         ** unfold Char; reflexivity.
Qed.

Theorem ex7:
  "b" >> ("a" U "b" U Nil) * >> Nil == "b" >> ("b" U "a") *.
Proof.
    split;intros A.
   Search(_ >> _).
  - rewrite app_r_nil_rw in A.
    Search(_ U _).
    rewrite union_sym_rw in A.
     Search(_ U _).
    rewrite  star_union_nil_rw in A.
    Search(_ U _).
    rewrite  union_sym_rw in A.
    apply A.
   - rewrite app_r_nil_rw.
    rewrite union_sym_rw.
    rewrite star_union_nil_rw.
    rewrite union_sym_rw in A.
    apply A.
Qed.

Theorem ex8:
  (("b" >> ("a" U {}) ) U (Nil >> {} >> "c")* ) * == ("b" >> "a") *.
Proof.
  split;intros.
- rewrite union_r_void_rw in H.
  rewrite app_r_void_rw in H.
  rewrite app_l_void_rw in H.
  rewrite star_void_rw in H.
  rewrite union_sym_rw in H.
  rewrite star_union_nil_rw in H.
  apply H.
- rewrite union_r_void_rw.
  rewrite app_r_void_rw.
  rewrite app_l_void_rw.
  rewrite star_void_rw.
  rewrite union_sym_rw.
  rewrite star_union_nil_rw.
  apply H.
Qed.

Student
Divya Thota
Autograder Score
100.0 / 100.0


(* Add LoadPath "/". *)

Require Export poly_j.

Definition plus_fact : Prop := 2+2 = 4.
Check plus_fact.

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity. Qed.

Definition strange_prop1 : Prop :=
  (2+2 = 5) -> (99+26 = 42).

Definition strange_prop2 :=
  forall n, (ble_nat n 17 = true) -> (ble_nat n 99 = true).

Definition even (n:nat) : Prop :=
  evenb n = true.

Check even.
Check(even 4).
Check(even 3).

Definition even_n__even__SSn (n:nat) : Prop :=
  (even n) -> (even (S (S n))).

Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

Definition teen : nat -> Prop := between 13 19.

Definition true_for_zero (P:nat->Prop) : Prop :=
  P 0.

Definition true_for_n__true_for_Sn (P:nat->Prop) (n:nat) : Prop :=
  P n -> P (S n).

Definition preserved_by_S (P:nat->Prop) : Prop :=
  forall n', P n' -> P (S n').

Definition true_for_all_numbers (P:nat->Prop) : Prop :=
  forall n, P n.

Definition our_nat_induction (P:nat->Prop) : Prop :=
  (true_for_zero P) ->
  (preserved_by_S P) ->
  (true_for_all_numbers P).

Inductive good_day : day ->  Prop :=
  | gd_sat : good_day saturday
  | gd_sun : good_day sunday.

Theorem gds : good_day sunday.
Proof. apply gd_sun. Qed.

Inductive day_before : day -> day -> Prop :=
  | db_tue : day_before tuesday monday
  | db_wed : day_before wednesday tuesday
  | db_thu : day_before thursday wednesday
  | db_fri : day_before friday thursday
  | db_sat : day_before saturday friday
  | db_sun : day_before sunday saturday
  | db_mon : day_before monday sunday.

Inductive fine_day_for_singing : day -> Prop :=
  | fdfs_any : forall d:day, fine_day_for_singing d.

Theorem fdfs_wed : fine_day_for_singing wednesday.
Proof. apply fdfs_any. Qed.

Definition fdfs_wed' : fine_day_for_singing wednesday :=
  fdfs_any wednesday.

Check fdfs_wed.
Check fdfs_wed'.

Inductive ok_day : day -> Prop :=
  | okd_gd : forall d,
      good_day d ->
      ok_day d
  | okd_before : forall d1 d2,
      ok_day d2 ->
      day_before d2 d1 ->
      ok_day d1.

Definition okdw : ok_day wednesday :=
  okd_before wednesday thursday
    (okd_before thursday friday
       (okd_before friday saturday
         (okd_gd saturday gd_sat)
         db_sat)
       db_fri)
    db_thu.

Theorem okdw' : ok_day wednesday.
Proof.
  apply okd_before with (d2:=thursday).
    apply okd_before with (d2:=friday).
      apply okd_before with (d2:=saturday).
        apply okd_gd. apply gd_sat.
        apply db_sat.
      apply db_fri.
   apply db_thu. Qed.

Print okdw'.

Definition okd_before2 := forall d1 d2 d3,
  ok_day d3 ->
  day_before d2 d1 ->
  day_before d3 d2 ->
  ok_day d1.

Theorem okd_before2_valid : okd_before2.
Proof.
  unfold okd_before2.
  intros.
  generalize dependent H0.
  apply okd_before.
  generalize dependent H1.
  apply okd_before.
  apply H.
Qed.

Definition okd_before2_valid' : okd_before2 :=
  fun (d1 d2 d3  : day) =>
  fun (H : ok_day d3) =>
  fun (H0 : day_before d2 d1) =>
  fun (H1 : day_before d3 d2) =>
  okd_before d1 d2 (okd_before d2 d3 H H1) H0.

Print okd_before2_valid.

Check nat_ind.

Theorem mult_0_r' : forall n:nat,
  n*0 = 0.
Proof.
  apply nat_ind.
  Case "O". reflexivity.
  Case "S". simpl. intros n IHn. rewrite -> IHn.
    reflexivity. Qed.

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  apply nat_ind.
  Case "O". reflexivity.
  Case "S". intros. simpl. rewrite H. reflexivity.
Qed.

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

Check yesno_ind.

Inductive rgb : Type :=
  | red : rgb
  | green :rgb
  | blue : rgb.

Check rgb_ind.

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.

Inductive natlist1 : Type :=
  | nnil1 : natlist1
  | nsnoc1 : natlist1 -> nat -> natlist1.

Check natlist1_ind.

Inductive ExSet : Type :=
  | con1 : bool -> ExSet
  | con2 : nat -> ExSet -> ExSet.

Check ExSet_ind.

Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.
Check tree_ind.

Inductive mytype (X : Type) :=
  | constr1 : X -> mytype X
  | constr2 : nat -> mytype X
  | constr3 : mytype X -> nat -> mytype X.

Check mytype_ind.

Inductive foo (X Y : Type) :=
  | bar : X -> foo X Y
  | baz : Y -> foo X Y
  | quux : (nat -> foo X Y) -> foo X Y.

Check foo_ind.

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

Definition P_m0r' : nat->Prop :=
  fun n =>  n * 0 = 0.

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  Case "n = O". reflexivity.
  Case "n = S n'".
    unfold P_m0r. simpl. intros n' IHn'.
    apply IHn'. Qed.

Inductive ev: nat -> Prop :=
  | ev_0 : ev 0
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

Theorem four_ev' :
  ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

Definition four_ev : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

Definition ev_plus4 : forall n, ev n -> ev (4+n) :=
  fun(n : nat) => fun(p : ev n)
  => ev_SS (S (S n)) (ev_SS n p).
Theorem ev_plus4' : forall n,
  ev n -> ev (4+n).
Proof.
  intros.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

Theorem double_even : forall n,
  ev (double n).
Proof.
  intros.
  induction n as [| n'].
  Case "n = 0".
    simpl. apply ev_0.
  Case "n = S n'".
    simpl. apply ev_SS. apply IHn'.
Qed.

Theorem ev_minus2: forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'. Qed.

Theorem ev_even : forall n,
  ev n -> even n.
Proof.
  intros n E. induction E as [| n' E'].
  Case "E = ev_0".
    unfold even. reflexivity.
  Case "E = ev_SS n' E'".
    unfold even. apply IHE'. Qed.

Theorem ev_sum : forall n m,
  ev n -> ev m -> ev (n+m).
Proof.
  intros. induction H.
  simpl. apply H0. simpl. apply ev_SS. apply IHev. Qed.

Theorem SSev_ev : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E. inversion E as [| n' E']. apply E'.
Qed.

Theorem SSSSev_even : forall n,
  ev(S (S (S (S  n)))) -> ev n.
Proof.
  intros. inversion H. inversion H1. apply H3.
Qed.

Theorem even5_nonsense:
  ev 5 -> 2+2 = 9.
Proof.
  intros. inversion H. inversion H1. inversion H3.
Qed.

Theorem ev_minu2' : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E. inversion E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'.
Qed.

Theorem ev_ev_even : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros.
  induction H0. simpl in H. apply H. inversion H. apply IHev.
  apply H2.
Qed.

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
  intros.
  apply ev_ev_even with (m:=m+p) (n:=n+m).
  replace (n+m+(m+p)) with (n+p+double m).
  apply ev_sum.
  apply H0.
  apply double_even.
  rewrite double_plus.
  rewrite plus_swap.
  rewrite plus_swap with (n:=n+m).
  SearchAbout (_+_+_).
  rewrite <- plus_assoc.
  rewrite <- plus_assoc.
  replace (p+m) with (m+p).
  reflexivity.
  apply plus_comm.
  apply H.
Qed.

Inductive MyProp : nat -> Prop :=
  | MyProp1 : MyProp 4
  | MyProp2 : forall n:nat, MyProp n -> MyProp(4+n)
  | MyProp3 : forall n:nat, MyProp (2+n) -> MyProp n.

Theorem MyProp_ten : MyProp 10.
Proof.
  apply MyProp3. simpl.
  assert (12 = 4 + 8) as H12.
    Case "Proof of assertion". reflexivity.
  rewrite -> H12.
  apply MyProp2.
  assert (8 = 4 + 4) as H8.
    Case "Proof of assertion". reflexivity.
  rewrite -> H8.
  apply MyProp2.
  apply MyProp1.   Qed.

Theorem MyProp_0 : MyProp 0.
Proof.
  apply MyProp3.
  apply MyProp3.
  simpl.
  apply MyProp1.
Qed.

Theorem MyProp_plustwo : forall n:nat, MyProp n -> MyProp (S (S n)).
Proof.
  intros.
  apply MyProp3.
  apply MyProp2.
  apply H.
Qed.

Theorem MyProp_ev : forall n:nat,
  ev n -> MyProp n.
Proof.
  intros n E.
  induction E as [| n' E'].
  Case "E = ev_0".
    apply MyProp_0.
  Case "E = ev_SS n' E'".
    apply MyProp_plustwo. apply IHE'.  Qed.

Theorem ev_MyProp : forall n:nat,
  MyProp n -> ev n.
Proof.
  intros.
  induction H.
  Case "MyProp1".
    apply ev_SS.
    apply ev_SS.
    apply ev_0.
  Case "MyProp2".
    apply ev_SS.
    apply ev_SS.
    apply IHMyProp.
  Case "MyProp3".
    apply ev_minus2 in IHMyProp.
    simpl in IHMyProp.
    apply IHMyProp.
Qed.

Fixpoint true_upto_n__true_everywhere (n:nat) (f:nat->Prop) : Prop :=
  match n with
  | O => forall m : nat, f m
  | S n' => f n -> (true_upto_n__true_everywhere n' f)
  end.

Example true_upto_n_example :
    (true_upto_n__true_everywhere 3 (fun n => even n))
  = (even 3 -> even 2 -> even 1 -> forall m : nat, even m).
Proof. reflexivity.  Qed.

Check ev_ind.

Theorem ev_even' : forall n,
  ev n -> even n.
Proof.
  apply ev_ind.
  Case "ev_0". unfold even. reflexivity.
  Case "ev_SS". intros n' E' IHE'. unfold even. apply IHE'. Qed.

Check list_ind.
Check ev_ind.
Print MyProp.
Check MyProp_ind.

Theorem ev_MyProp' : forall n:nat,
  MyProp n -> ev n.
Proof.
  apply MyProp_ind.
  Case "MyProp1".
    apply ev_SS. apply ev_SS. apply ev_0.
  Case "MyProp2".
    intros. apply ev_SS. apply ev_SS. apply H0.
  Case "MyProp3".
    intros. apply ev_minus2 in H0. simpl in H0. apply H0.
Qed.

Module P.

(*hgoegeg*)

Inductive p : (tree nat) -> nat -> Prop :=
   | c1 : forall n, p (leaf _ n) 1
   | c2 : forall t1 t2 n1 n2,
            p t1 n1 -> p t2 n2 -> p (node _ t1 t2) (n1 + n2)
   | c3 : forall t n, p t n -> p t (S n).

End P.


Inductive day : Type :=
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day.

Definition next_weekday (d:day) : day :=
match d with
| monday => tuesday
| tuesday => wednesday
| wednesday => thursday
| thursday => friday
| friday => monday
| saturday => monday
| sunday => monday
end.

Inductive bool : Type :=
| true : bool
| false : bool.

Definition negb (b: bool) : bool :=
match b with
| true => false
| false => true
end.

Definition andb (b1:bool) (b2:bool) : bool :=
match b1 with
| true => b2
| false => false
end.

Definition orb (b1:bool) (b2:bool) : bool :=
match b1 with
| true => true
| false => b2
end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Infix "&&" := andb.

Infix "||" := orb.

Definition nandb (b1:bool) (b2:bool) : bool := (negb (andb b1 b2)).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool := (andb b1 (andb b2 b3)).

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Inductive nat : Type :=
| O : nat
| S : nat -> nat.

Definition pred (n : nat) : nat :=
match n with
| O => O
| S n' => n'
end.

Definition succ (n:nat) :nat :=
match n with
| O => (S O)
| S n' => S (S n')
end.


Inductive term : Type :=
| tmtrue : term
| tmfalse : term
| tmif : term -> term -> term -> term
| tmzero : term
| tmsucc : term -> term
| tmpred : term -> term
| tmiszero : term -> term.

Inductive type : Type := Bool | Nat.

Inductive is_numeric_val : term -> Prop :=
| N_Zero :
    is_numeric_val tmzero
| N_Succ : forall t,
    is_numeric_val t ->
    is_numeric_val (tmsucc t).

Inductive is_val : term -> Prop :=
| V_True :
    is_val tmtrue
| V_False :
    is_val tmfalse
| V_numericalval : forall t,
    is_numeric_val t ->
    is_val t.

Inductive subterm : term -> term -> Prop :=
| S_IfCond : forall t t1 t2,
    subterm t (tmif t t1 t2)
| S_IfTrue : forall t t1 t2,
    subterm t1 (tmif t t1 t2)
| S_IfFalse : forall t t1 t2,
    subterm t2 (tmif t t1 t2)
| S_Succ : forall t,
    subterm t (tmsucc t)
| S_Pred : forall t,
    subterm t (tmpred t)
| S_IsZero : forall t,
    subterm t (tmiszero t).

Inductive typed : term -> type -> Prop :=
| T_True :
    typed tmtrue Bool
| T_False :
    typed tmfalse Bool
| T_Zero :
    typed tmzero Nat
| T_If : forall t t1 t2 T,
    typed t Bool ->
    typed t1 T ->
    typed t2 T ->
    typed (tmif t t1 t2) T
| T_Succ : forall t,
    typed t Nat ->
    typed (tmsucc t) Nat
| T_Pred : forall t,
    typed t Nat ->
    typed (tmpred t) Nat
| T_IsZero : forall t,
    typed t Nat ->
    typed (tmiszero t) Bool.

Lemma subterm_typed : forall t T, typed t T -> forall s, subterm s t -> exists U, typed s U.
  intros t T t_typed s s_t_subterm.
  inversion s_t_subterm; subst; inversion t_typed.
  -exists Bool; assumption.
  -exists T; assumption.
  -exists T; assumption.
  -exists Nat; assumption.
  -exists Nat; assumption.
  -exists Nat; assumption.
Qed.

Lemma typed_bool : forall t, typed t Bool -> is_val t -> t = tmtrue \/ t = tmfalse.
  intros t H_type H_val.
  induction H_val.
  -left; reflexivity. (* t is true*)
  -right; reflexivity. (* t is false *)
  -inversion H. (* t is a numeric value (contradiction) *)
   +rewrite <- H0 in H_type.
    inversion H_type.
   +rewrite <- H1 in H_type.
    inversion H_type.
Qed.

Lemma typed_numericval : forall t, typed t Nat -> is_val t -> is_numeric_val t.
  intros t H_type H_val.
  induction H_val.
  -inversion H_type. (* t is true (contradiction) *)
  -inversion H_type. (* t is false (contradiction) *)
  -assumption. (* t is a numeric value *)
Qed.

Reserved Notation "x --> y" (at level 80, no associativity).

Inductive step : term -> term -> Prop :=
| E_IfTrue : forall t t',
    (tmif tmtrue t t') --> t
| E_IfFalse : forall t t',
    (tmif tmfalse t t') --> t'
| E_If : forall t t' t1 t2,
    (t --> t') ->
    ((tmif t t1 t2) --> (tmif t' t1 t2))
| E_Succ : forall t t',
    (t --> t') ->
    tmsucc t --> tmsucc t'
| E_Pred : forall t t',
    (t --> t') ->
    tmpred t --> tmpred t'
| E_PredZero :
    tmpred tmzero --> tmzero
| E_PredSucc : forall nv,
    is_numeric_val nv ->
    tmpred (tmsucc nv) --> nv
| E_IsZeroZero :
    tmiszero tmzero --> tmtrue
| E_IsZeroSucc : forall nv,
    is_numeric_val nv ->
    tmiszero (tmsucc nv) --> tmfalse
| E_IsZero : forall t t',
    t --> t' ->
    tmiszero t --> tmiszero t'

where "x --> y" := (step x y).

Ltac solve_by_inverts n :=
  match goal with
  | H : ?T |- _ =>
    match type of T with Prop =>
                         solve [
                             inversion H;
                             match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
    end
  end.
Ltac solve_by_invert := solve_by_inverts 1.

Definition relation (X : Type) := X -> X -> Prop.

Definition normal_form {X : Type} (R : relation X) (t : X) : Prop :=
  not (exists t', R t t').

Lemma numericval_no_eval : forall nv, is_numeric_val nv -> normal_form step nv.
  unfold normal_form.
  intros nv H.
  induction H.
  - unfold not. intro H. inversion H. inversion H0.
  - unfold not. intro H'. inversion H'. inversion H0.
    apply IHis_numeric_val.
    exists t'.
    assumption.
Qed.

Theorem value_is_nf : forall t, is_val t -> normal_form step t.
  intros t t_val.
  induction t_val.
  - unfold normal_form. unfold not. intro H'. inversion H'. inversion H.
  - unfold normal_form. unfold not. intro H'. inversion H'. inversion H.
  - apply (numericval_no_eval t H).
Qed.

Ltac find_eqn :=
  match goal with
  | IH: forall t, ?P t -> ?L = ?R, H: ?P ?X |- _ => rewrite (IH X H) in *
end.

Ltac find_succ :=
  match goal with
  | H1: is_numeric_val ?X, H2: ?X --> ?Y
    |- _ => destruct (value_is_nf _ (V_numericalval _ H1)); exists Y; assumption
  | H1: is_numeric_val ?X, H2: tmsucc ?X --> ?Y
    |- _ => inversion H2; find_succ
  end.

Lemma step_unique : forall t t1 t2, t --> t1 -> t --> t2 -> t1 = t2.
  intros t t' t'' t_step_t' t_step_t''.
  generalize dependent t''.
  induction t_step_t'; intros t'' t_step_t''; inversion t_step_t''; subst;
    try solve_by_invert; try find_eqn; try find_succ; auto.
Qed.

Theorem process : forall t T, typed t T -> is_val t \/ (exists t', t --> t').
  intros t T t_typed.
  induction t_typed.
  -left; constructor.
  -left; constructor.
  -left; constructor; constructor.
  -right.
   case IHt_typed1.
   +intro t_val.
    assert (t = tmtrue \/ t = tmfalse) as t_true_or_false.
    { apply (typed_bool t t_typed1 t_val). }
    case t_true_or_false.
    *intro t_true; exists t1; rewrite t_true; constructor.
    *intro t_false; exists t2; rewrite t_false; constructor.
   +intro t_process.
    destruct t_process as [t' t_process].
    exists (tmif t' t1 t2); constructor; assumption.
  -case IHt_typed.
   +intro t_val; left.
    constructor.
    constructor.
    apply (typed_numericval t t_typed t_val).
   +intro t_process; right.
    destruct t_process as [t' t_process].
    exists (tmsucc t'); constructor; assumption.
  -right.
   case IHt_typed.
   +intro t_val.
    assert (is_numeric_val t) as t_numeric.
    { apply (typed_numericval t t_typed t_val). }
    inversion t_numeric.
    *exists tmzero; constructor.
    *exists t0; constructor; assumption.
   +intro t_process.
    destruct t_process as [t' t_process].
    exists (tmpred t').
    apply (E_Pred t t' t_process).
  -case IHt_typed.
   +intro t_val; right.
    assert (is_numeric_val t) as t_numeric.
    { apply (typed_numericval t t_typed t_val). }
    inversion t_numeric.
    *exists tmtrue.
     constructor.
    *exists tmfalse.
     constructor; assumption.
   +intro t_process; right.
    destruct t_process as [t' t_process].
    exists (tmiszero t'); constructor; assumption.
Qed.

Hint Constructors typed.
Lemma numericval_nat : forall t, is_numeric_val t -> typed t Nat.
  intros t t_nv. induction t_nv; auto.
Qed.

Ltac find_process :=
  match goal with
  | Ht: typed ?X ?T, IH: forall t', ?X --> t' -> typed t' ?T, Hp: ?P ?X --> ?Y
                                                      |- _ => solve [ inversion Hp; constructor; auto ]
end.

Theorem preserve : forall t t' T, typed t T -> t --> t' -> typed t' T.
  intros t t' T t_typed t_process.
  generalize dependent t'.
  induction t_typed; intros t' t'_process; try solve_by_invert; try find_process; auto.
  - (* T_If *)
    inversion t'_process; try (rewrite <- H3; assumption).
    specialize (IHt_typed1 t'0).
    specialize (IHt_typed1 H3).
    apply (T_If t'0 t1 t2 T IHt_typed1 t_typed2 t_typed3).
  - (* T_Pred *)
    inversion t'_process; try constructor.
    + specialize (IHt_typed t'0). (* E_Pred *)
      specialize (IHt_typed H0). auto.
    +apply (numericval_nat t' H0). (* E_PredSucc *)
Qed.

Theorem preserve' : forall t t' T, typed t T -> t --> t' -> typed t' T.
  Hint Resolve numericval_nat.
  intros t t' T t_typed t_process.
  generalize dependent T.
  induction t_process; intros T t_typed; inversion t_typed; try constructor; auto.
Qed.


Require Import String.
Require Import List.
Require Import PeanoNat.
From mathcomp Require Import all_ssreflect.

(* length and app *)

Lemma length_app {A : Type}:
    forall l1 l2 : list A,
        length (l1 ++ l2) = length l1 + length l2.
Proof.
    move=> l1 l2; induction l1 as [|hd l1 HRec]; simpl.
    {
        rewrite add0n; trivial.
    }
    {
        rewrite addSn.
        rewrite HRec; reflexivity.
    }
Qed.

Lemma length_app_eq {A : Type}:
    forall l1 l2 : list A,
    forall i1 i2,
        length l1 = i1 -> length (l1 ++ l2) = i1 + i2 -> length l2 = i2.
Proof.
    move=> l1 l2; induction l1 as [|hd l1 HRec]; simpl.
    all: move=> i1 i2 <-.
    {
        rewrite add0n; trivial.
    }
    {
        rewrite addSn.
        move=> HEq; inversion HEq.
        refine (HRec _ _ _ _).
        + reflexivity.
        + assumption.
    }
Qed.

Lemma case_last {A : Type}: forall l : list A, {l = nil} + {exists l' last, l = l' ++ last::nil}.
Proof.
    induction l as [|hd tl HRec]; simpl; auto.
    right.
    destruct HRec as [->|[l' [last' ->]]].
    {
        exists nil; exists hd; simpl; reflexivity.
    }
    {
        exists (hd::l'); exists last'; simpl; reflexivity.
    }
Qed.

Lemma Forall_length_1_concat {A : Type}:
    forall l : list (list A),
        Forall (fun l2 => length l2 = 1) l -> length (concat l) = length l.
Proof.
    move=> l; induction l as [|hd l HRec]; simpl; trivial.
    move=> HForall.
    rewrite length_app.
    rewrite HRec.
    + apply Forall_inv in HForall; rewrite HForall; rewrite add1n; reflexivity.
    + apply Forall_inv_tail in HForall; assumption.
Qed.

Lemma leb_add_1_l:
    forall n, n + 1 <=? n  = false.
Proof.
    induction n; simpl; auto.
Qed.

Lemma String_append_length:
    forall (s1 s2 : string),
        String.length (s1 ++ s2)%string = String.length s1 + String.length s2.
Proof.
    intros s1 s2; induction s1; simpl.
    + reflexivity.
    + rewrite IHs1; reflexivity.
Qed.

(* list map is ss_reflect map *)
Theorem list_map_seq_map {A B : Type} (f : A -> B):
    forall l, List.map f l = [seq f i | i <- l].
Proof.
    move=> l; induction l as [|hd tl HRec]; simpl; trivial.
Qed.


Require Export Ensemble.

(* Section 3.1 *)
Definition Topology X cT := cT ⊂ cP(X) ∧
  X ∈ cT ∧ ∅ ∈ cT ∧ (∀ A B, A ∈ cT → B ∈ cT → A ∩ B ∈ cT) ∧
  (∀ cT1, cT1 ⊂ cT → ∪cT1 ∈ cT).

Definition Ordinary X := [X] ⋃ [∅].

Theorem Theorem3_1 : ∀ X, Ensemble X → Topology X (Ordinary X).
Proof with eauto.
  intros * Hxe. pose proof EmptySet as Hee. repeat split...
  - intros A Ha. apply ClaI; Ens. apply UnionIE in Ha as [];
    apply SingE in H; subst... intros x... intros z Hz; exfalso0.
  - apply UnionIE. left; apply ClaI...
  - apply UnionIE. right; apply ClaI...
  - unfold Ordinary. intros. apply IntSinEm...
  - intros. unfold Ordinary. apply EleUSinEm...
Qed.

Definition Discrete X := cP(X).

Theorem Theorem3_2 : ∀ X, Ensemble X → Topology X (Discrete X).
Proof with eauto.
  intros. repeat split. intros A Ha... apply ClaI... intros A...
  apply ClaI. Empt. intros A Ha; exfalso0.
  intros * Ha Hb. apply ClaE in Ha as []; apply ClaE in Hb as [].
  apply ClaI. apply InterEn... intros z Hz.
  apply InterIE in Hz as []... intros. apply ClaI. apply EleUAx.
  apply PowerP in H as []. unfold Discrete in H0. eapply SubAxI...
  intros x Hx. apply ClaE in Hx as [Hxe [A [Hx Ha]]].
  apply H0 in Ha. apply ClaE in Ha as []...
Qed.

(* Section 3.2 *)
Definition TNeigh x U X cT := Topology X cT ∧ x ∈ X ∧ U ⊂ X ∧
  ∃ V, V ∈ cT ∧ x ∈ V ∧ V ⊂ U.

Corollary TNeighP : ∀ x U X cT, Ensemble X →
  Topology X cT → x ∈ U → U ∈ cT → TNeigh x U X cT.
Proof with eauto.
  intros * Hxe Ht Hx Hu. split... assert (Hxx : U ⊂ X).
  { apply Ht in Hu. apply PowerIE in Hu... } split... split...
  exists U. repeat split... intros z...
Qed.

Definition TNeighS x X cT := \{λ U, TNeigh x U X cT \}.

Fact TNeighSIE : ∀ x U X cT,
  Ensemble X → TNeigh x U X cT ↔ U ∈ TNeighS x X cT.
Proof.
  split; intros. apply ClaI; auto. eapply SubAxI; eauto. apply H0.
  apply ClaE in H0. tauto.
Qed.

Definition TONeigh x U X cT := TNeigh x U X cT ∧ x ∈ U ∧ U ∈ cT.

Corollary TNeighP1 : ∀ x U X cT, Ensemble X → TNeigh x U X cT →
  ∃ V, TONeigh x V X cT ∧ V ⊂ U.
Proof.
  intros * Hxe [Ht [_ [Hv [V [Hvo [Hxv Huv]]]]]].
  exists V. split; auto. split. apply TNeighP; auto. tauto.
Qed.

(* Theorem3_3 *)
Lemma LeTh3_3 : ∀ U, U = ∪(\{λ t, ∃ x, x ∈ U ∧ t = [x]\}).
Proof with eauto.
  intro. AppE. apply EleUIE. exists [x]. split. apply SingI. Ens.
  apply ClaI. apply SingEn. Ens. exists x. split...
  apply EleUIE in H as [y [Hy Heq]].
  apply ClaE in Heq as [_ [z [Hz Heq]]].
  subst. apply SingE in Hy. subst... Ens.
Qed.

Definition Ux x U cT := ∪\{λ V, x ∈ U ∧ V ∈ cT ∧ x ∈ V ∧ V ⊂ U \}.

Theorem Theorem3_3 : ∀ U X cT, Ensemble X → Topology X cT → U ⊂ X →
  (U ∈ cT ↔ ∀ x, x ∈ U → U ∈ TNeighS x X cT).
Proof with eauto.
  intros * Hxe Ht Hsub. split; intros Hp.
  - intros * Hx. apply TNeighSIE... apply TNeighP...
  - destruct (classic (U = ∅)). subst; apply Ht.
    assert (H1 : ∪(\{λ t, ∃ x, x ∈ U ∧ t = [x]\}) ⊂
       ∪(\{λ t, ∃ x, x ∈ U ∧ t = Ux x U cT\})).
    { intros z Hz. apply EleUIE in Hz as [y [Hy Hz]].
      apply ClaE in Hz as [_ [x0 [Hx0 Hz]]]. subst...
      apply SingE in Hy; Ens. subst. assert (Hx0' := Hx0).
      apply Hp in Hx0. apply TNeighSIE in Hx0... apply EleUIE.
      exists (Ux x0 U cT). split. apply EleUIE. assert (Hn := Hx0).
      destruct Hx0 as [_ [_ [_ [V [Hv [Hx0 Hvu]]]]]].
      exists V. split... apply ClaI; Ens. apply ClaI...
      apply (SubAxI U). apply (SubAxI X)... intros z Hz.
      apply EleUIE in Hz as [A [Ha Hz]].
      apply ClaE in Hz as [_ [_ [_ [_ Hz]]]]... }
    assert (H2 : ∪(\{λ t, ∃ x, x ∈ U ∧ t = Ux x U cT\}) ⊂ U).
    { intros z Hz. apply EleUIE in Hz as [y [Hy Hz]].
      apply ClaE in Hz as [_ [t [Htu Hz]]]. subst... apply EleUIE in
        Hy as [e [Hz Hy]]. apply ClaE in Hy. apply Hy... }
    assert (Hg : U = ∪(\{λ t, ∃ x, x ∈ U ∧ t = Ux x U cT\})).
    { apply ReSyTrP... rewrite <- LeTh3_3 in H1... }
    rewrite Hg. apply Ht. intros V Hv.
    apply ClaE in Hv as [_ [x [Hx Heq]]]. subst.
    apply Ht. intros z Hz. apply ClaE in Hz; tauto.
Qed.

(* Theorem3_4 *)
Theorem Theorem3_4a : ∀ x X cT, Ensemble X → Topology X cT → x ∈ X →
  TNeighS x X cT ≠ ∅ ∧ (∀ U, U ∈ TNeighS x X cT → x ∈ U).
Proof with eauto.
  intros * Hxe Ht Hx. split.
  - assert (X ∈ TNeighS x X cT).
    { apply ClaI... split... split... split. intros z...
      exists X. split. apply Ht. split... intros z... }
    intro. rewrite H0 in H. exfalso0.
  - intros * Hu. apply TNeighSIE in Hu as [_[_[_[V [_[Hv Hsub]]]]]]...
Qed.

Theorem Theorem3_4b : ∀ x X cT, Ensemble X → Topology X cT → x ∈ X →
  (∀ U V, U ∈ TNeighS x X cT → V ∈ TNeighS x X cT →
  U ∩ V ∈ TNeighS x X cT).
Proof with eauto.
  intros * Hxe Ht Hx * Hu Hv.
  apply TNeighSIE in Hu as [_ [_ [Hux [U0 [Ho1 [Hu0 Hsub1]]]]]]...
  apply TNeighSIE in Hv as [_ [_ [Hvx [V0 [Ho2 [Hv0 Hsub2]]]]]]...
  assert (Huv : x ∈ U0 ∩ V0 ∧ U0 ∩ V0 ⊂ U ∩ V).
  { split. apply InterIE. tauto. intros z Hz.
    apply InterIE in Hz as [Hzu Hzv]. apply InterIE. split... }
  apply TNeighSIE... split... split... split. intros z Hz.
  apply InterIE in Hz as [Hz1 _]... exists (U0 ∩ V0).
  split; try apply Ht...
Qed.

Theorem Theorem3_4c : ∀ x X cT, Ensemble X → Topology X cT → x ∈ X →
  ∀ U V, U ∈ TNeighS x X cT → V ⊂ X → U ⊂ V → V ∈ TNeighS x X cT.
Proof with eauto.
  intros * Hxe Ht Hx * Hu Hv Hsub.
  apply TNeighSIE in Hu as [_ [_ [Hux [U0 [Hou [Hu0 Hsub1]]]]]]...
  apply TNeighSIE... split... split... split...
  exists U0. repeat split... eapply ReSyTrP...
Qed.

Theorem Theorem3_4d : ∀ x X cT, Ensemble X → Topology X cT → x ∈ X →
  ∀ U, U ∈ TNeighS x X cT → ∃ V, V ∈ TNeighS x X cT ∧ V ⊂ U ∧
  (∀ y, y ∈ V → V ∈ TNeighS y X cT).
Proof with eauto.
  intros * Hxe Ht Hx * Hu. assert (Hu' := Hu).
  apply TNeighSIE in Hu as [_ [_ [Hux [V [Hvo [Hvx Hsub]]]]]]...
  exists V. split. apply TNeighSIE... split... split... split.
  eapply ReSyTrP... exists V. split... split... intros z...
  split... apply Theorem3_3... eapply ReSyTrP...
Qed.

(* Section 3.3 *)
Definition Condensa x A X cT := Topology X cT ∧ A ⊂ X ∧ x ∈ X ∧
  ∀ U, TNeigh x U X cT → U ∩ (A - [x]) ≠ ∅.

Definition Derivaed A X cT := \{λ x, Condensa x A X cT \}.

Fact DerivaedIE : ∀ x A X cT, Condensa x A X cT ↔ x ∈ Derivaed A X cT.
Proof.
  split; intros. apply ClaI; auto. destruct H as [_ [_ [Hx _]]]. Ens.
  apply ClaE in H. tauto.
Qed.

Corollary DerivaedP : ∀ A X cT, Derivaed A X cT ⊂ X.
Proof. intros * x Hx. apply ClaE in Hx. apply Hx. Qed.

Corollary DerivaedP1 : ∀ x C X cT, Topology X cT → C ⊂ X → x ∈ X →
  x ∉ Derivaed C X cT → ∃ U, TNeigh x U X cT ∧ U ∩ (C - [x]) = ∅.
Proof with eauto.
  intros * Ht Hsub Hx Hp.
  destruct (classic (∃ U, TNeigh x U X cT ∧ U ∩ (C - [x]) = ∅))...
  elim Hp. apply ClaI. Ens. split... split... split...
Qed.

(* Theorem3_5 *)
Theorem Theorem3_5a : ∀ X cT,
  Ensemble X → Topology X cT → Derivaed ∅ X cT = ∅.
Proof with eauto.
  intros * Hxe Ht. AppE; [|exfalso0].
  apply DerivaedIE in H as [_ [_ [Hx Hp]]]. eapply TNeighP in Ht...
  apply Hp in Ht. elim Ht. AppE; [|exfalso0]. apply InterIE in H as
    [_ H]. apply SetminIE in H as []; tauto. apply Ht.
Qed.

Theorem Theorem3_5b : ∀ A B X cT, Ensemble X → Topology X cT →
  A ⊂ X → B ⊂ X → A ⊂ B → Derivaed A X cT ⊂ Derivaed B X cT.
Proof with eauto.
  intros * HXe Ht Ha Hb Hsub. intros x Hx.
  apply DerivaedIE in Hx as [_ [_ [Hx Hp]]]. apply DerivaedIE.
  split... split... split... intros U Hu. apply Hp in Hu.
  assert (U ∩ A - [x] ⊂ U ∩ B - [x]).
  { intros z Hz. apply InterIE in Hz as [Hz Hza].
    apply SetminIE in Hza as [Hza Hneq]. apply InterIE. split...
    apply SetminIE. split... }
  intro. rewrite H0 in H. assert (U ∩ A - [x] = ∅).
  { apply ReSyTrP... intros z Hz. exfalso0. } tauto.
Qed.

Theorem Theorem3_5c : ∀ A B X cT,
  Ensemble X → Topology X cT → A ⊂ X → B ⊂ X →
  Derivaed (A ⋃ B) X cT = Derivaed A X cT ⋃ Derivaed B X cT.
Proof with eauto.
  intros * HXe Ht Ha Hb. assert (A ⊂ A ⋃ B ∧ B ⊂ A ⋃ B).
  { split; intros x Hx; apply UnionIE... }
  destruct H as [Hsa Hsb]. assert (A ⋃ B ⊂ X).
  { intros z Hz. apply UnionIE in Hz as []... }
  eapply Theorem3_5b in Hsa... eapply Theorem3_5b in Hsb...
  AppE; revgoals. apply UnionIE in H0 as []...
  destruct (classic (x ∈ Derivaed A X cT ⋃ Derivaed B X cT))...
  assert (Hab : x ∉ Derivaed A X cT ∧ x ∉ Derivaed B X cT).
  { split; intro; elim H1; apply UnionIE... }
  clear H1; destruct Hab as [Hna Hnb]. assert (H0' := H0).
  apply DerivaedIE in H0' as [_ [_ [Hx _]]].
  apply DerivaedP1 in Hna as [U [Hun Hue]]...
  apply DerivaedP1 in Hnb as [V [Hvn Hve]]...
  set (U ∩ V) as D. assert (Hd : D ∩ ((A ⋃ B) - [x]) = ∅).
  { assert (H1 : D ∩ ((A ⋃ B) - [x]) = D ∩ ((A - [x]) ⋃ (B - [x]))).
    { assert ((A ⋃ B) - [x] = A - [x] ⋃ B - [x]).
      { AppE. apply SetminIE in H1 as [Hab H1].
        apply UnionIE in Hab as []; apply UnionIE.
        left; apply SetminIE... right; apply SetminIE...
        apply UnionIE in H1 as []; apply SetminIE in H1 as [H1 He];
        apply ClaI; Ens; split; auto; apply ClaI; Ens. }
      rewrite H1... }
    assert (H2 : D ∩ (A - [x] ⋃ B - [x]) =
      (D ∩ (A - [x])) ⋃ (D ∩ (B - [x]))).
    { apply DistribuLI... }
    assert (H3 : (D ∩ (A - [x])) ⋃ (D ∩ (B - [x])) ⊂
      (U ∩ (A - [x])) ⋃ (V ∩ (B - [x]))).
    { intros z Hz. apply UnionIE in Hz as []; apply UnionIE;
      apply InterIE in H3 as [H3 Hz]; apply InterIE in H3 as [Hu Hv].
      left; apply InterIE... right; apply InterIE... }
    assert (H4 : (U ∩ (A - [x])) ⋃ (V ∩ (B - [x])) = ∅).
    { rewrite Hue, Hve. AppE.
      apply UnionIE in H4 as []; exfalso0. exfalso0. }
    rewrite H1, H2. rewrite H4 in H3. apply ReSyTrP...
     intros z Hz; exfalso0. }
  assert (x ∉ Derivaed (A ⋃ B) X cT).
  { apply DerivaedIE in H0 as [_ [_ H0]]. assert (D ∈ TNeighS x X cT).
    { apply Theorem3_4b; try (apply ClaI); eauto; apply (SubAxI X _)...
      apply Hun. apply Hvn. }
    apply TNeighSIE in H1... apply H0 in H1; tauto. } tauto.
Qed.

Theorem Theorem2_4_1d : ∀ A X cT, Ensemble X → Topology X cT → A ⊂ X →
  Derivaed (Derivaed A X cT) X cT ⊂ A ⋃ Derivaed A X cT.
Proof with eauto.
  intros * HXe Ht Hsub x Hx.
  destruct (classic (x ∈ A ⋃ Derivaed A X cT))...
  apply UnionNE in H as [Hxa Hxd]. assert (Hx' := Hx).
  apply DerivaedIE in Hx as [_ [_ [Hx _]]].
  apply DerivaedP1 in Hxd as [U [Hun Hue]]...
  assert (U ∈ TNeighS x X cT). apply TNeighSIE...
  pose proof Theorem3_4d x X cT HXe Ht Hx as Hu.
  apply Hu in H as [V [Htv [Hvu Hp]]]; clear Hu. assert (V ⊂ X).
  { destruct Hun as [_ [_ [Hun _]]]. eapply ReSyTrP... }
  pose proof Theorem3_3 _ _ _ HXe Ht H.
  pose proof Hp as Hp'. apply H0 in Hp; clear H H0.
  assert (V ∩ A - [x] = ∅).
  { AppE; [| exfalso0]. assert (V ∩ A - [x] ⊂ U ∩ A - [x]).
    { intros z Hz. apply InterIE in Hz as []. apply InterIE. split... }
    apply H0 in H. rewrite Hue in H. exfalso0. }
  assert (V ∩ A = ∅). { apply (InterEqEmI x V A); Ens. }
  assert (∀ y, y ∈ V → y ∉ A).
  { intros * Hy Hn. assert (y ∈ V ∩ A). apply InterIE...
    rewrite H0 in H1... exfalso0. }
  assert (∀ y, y ∈ V → V ∩ A - [y] = ∅).
  { intros. AppE; [| exfalso0]. apply InterIE in H3 as [].
    apply SetminIE in H4 as []. apply H1 in H3... tauto. }
  assert (∀ y, y ∈ V → y ∉ Derivaed A X cT).
  { intros. intro. apply DerivaedIE in H4 as [_ [_ [_ H4]]].
    pose proof H3. apply H2 in H3. apply Hp' in H5.
    apply TNeighSIE in H5... apply H4 in H5. tauto. }
  assert (V ∩ Derivaed A X cT - [x] = ∅).
  { AppE; [| exfalso0]. apply InterIE in H4 as [].
    apply H3 in H4. apply SetminIE in H5 as []. tauto. }
  apply DerivaedIE in Hx' as [_ [_ [_ Hx']]]. apply TNeighSIE in Htv...
  apply Hx' in Htv. tauto.
Qed.

(* Section 3.4 *)
Definition Closed A X cT :=
  Topology X cT ∧ A ⊂ X ∧ Derivaed A X cT ⊂ A.

(* Theorem3_6 *)
Theorem Theorem3_6 : ∀ A X cT, Ensemble X → Topology X cT → A ⊂ X →
  Closed A X cT ↔ X - A ∈ cT.
Proof with eauto.
  intros * HXe Ht Hsub. pose proof (IncludP2 A X) as Hsub'.
  split; intros Hp.
  - destruct Hp as [_ [_ Hp]]. eapply Theorem3_3...
    intros * Hx. apply SetminIE in Hx as [Hx Hn].
    assert (x ∉ Derivaed A X cT). { intro. apply Hp in H; tauto. }
    apply DerivaedP1 in H as
      [U [[_ [_ [Hus [V [Hvo [Hvx Hvu]]]]]] Hue]]...
    apply (InterEqEmI x _ _) in Hue; Ens. assert (U ⊂ X - A).
    { intros z Hz. apply SetminIE. split... intro.
      assert (z ∈ U ∩ A). apply InterIE...
      rewrite Hue in H0. exfalso0. }
    apply TNeighSIE... split... split... split...
    exists V. split... split... eapply ReSyTrP...
  - assert (∀ x, x ∈ X-A → TNeigh x (X-A) X cT ∧ x ∉ Derivaed A X cT).
    { intros x Hx. apply (Theorem3_3 (X-A) _ _) in Ht...
      eapply Ht in Hp... apply TNeighSIE in Hp... split...
      intro. apply ClaE in H as [_ [_ [_ [_ H0]]]]. apply H0 in Hp.
      assert (X - A ∩ A - [x] = ∅).
      { AppE; [| exfalso0]. apply InterIE in H as [Hn H].
        apply SetminIE in Hn. apply SetminIE in H; tauto. } tauto. }
    split... split... intros x Hx. destruct (classic (x ∈ A))...
    assert (x ∈ X - A). { apply DerivaedIE in Hx as [_ [_ [Hx _]]].
      apply SetminIE... } apply H in H1 as [_ H1]; tauto.
Qed.

(* Theorem3_7 *)
Definition cF X cT := \{λ U, U ⊂ X ∧ X - U ∈ cT \}.

Fact cFIE : ∀ U X cT, Ensemble X → U ⊂ X ∧ X - U ∈ cT ↔ U ∈ cF X cT.
Proof.
  split; intros. apply ClaI; auto. apply (SubAxI X U); tauto.
  apply ClaE in H0. tauto.
Qed.

Corollary cFP : ∀ X cT, Ensemble X → cF X cT ⊂ cP(X).
Proof.
  intros * HXe U Hu. apply ClaE in Hu. apply PowerIE; tauto.
Qed.

Theorem Theorem3_7a : ∀ X cT, Ensemble X → Topology X cT →
  X ∈ cF X cT ∧ ∅ ∈ cF X cT.
Proof with eauto.
  intros * Hxe Ht. split.
  - apply cFIE... split. intros z... rewrite SetminId. apply Ht.
  - apply ClaI. Empt. split. intros z Hz; exfalso0.
    rewrite SetminEm. apply Ht.
Qed.

Theorem Theorem3_7b : ∀ A B X cT, Ensemble X → Topology X cT →
  A ∈ cF X cT → B ∈ cF X cT → A ⋃ B ∈ cF X cT.
Proof with eauto.
  intros * He Ht Ha Hb. apply cFIE in Ha as [Ha Hac]...
  apply cFIE in Hb as [Hb Hbc]... assert (X - A ∩ X - B ∈ cT).
  apply Ht... apply TwSetmin in Ha. apply TwSetmin in Hb.
  rewrite <- Ha, <- Hb.
  assert (X - (X - A) ⋃ X - (X - B) = X - (X - A ∩ X - B)).
  { AppE. rewrite TwDeMorgan; apply UnionIE;
    apply UnionIE in H0 as []... rewrite TwDeMorgan in H0... }
  rewrite H0. apply (cFIE _ X cT)... split. apply IncludP2.
  rewrite TwSetmin... intros z Hz. apply InterIE in Hz as [_ Hz].
  apply SetminIE in Hz; tauto.
Qed.

Theorem Theorem3_7c : ∀ cF1 X cT, Ensemble X →
  Topology X cT → cF1 ≠ ∅ → cF1 ⊂ cF X cT → ⋂cF1 ∈ cF X cT.
Proof with eauto.
  intros cF1 * HXe Ht Hne Hsub.
  set \{λ A, A ⊂ X ∧ X - A ∈ cF1 \} as cT1. assert (HcT : cT1 ⊂ cT).
  { intros A Ha. apply ClaE in Ha as [_ [Hsa Ha]]. apply Hsub in Ha.
    apply cFIE in Ha as [Hc Ha]... rewrite TwSetmin in Ha... }
  apply Ht in HcT. assert (H4 : (X - ∪cT1) ∈ cF X cT).
  { apply (cFIE _ X cT)... split. apply IncludP2.
    rewrite TwSetmin... apply Ht in HcT. apply PowerIE in HcT... }
  assert (H3 : (X - ∪(AAr X cF1)) = (X - ∪cT1)).
  { AppE; apply SetminIE in H as [Hx Hn]; apply SetminIE; split...
    - intro. elim Hn. apply EleUIE in H as [B [Hb Hbt]].
      apply ClaE in Hbt as [_ [Hbs Hb']]. apply EleUIE.
      exists (X - (X - B)). split. rewrite TwSetmin... apply AArI...
    - intro. elim Hn; clear Hn. apply EleUIE in H as [B [Hb Hbt]].
      pose proof Hbt. apply AArE in Hbt as [T [Hbt Heq]].
      apply EleUIE. exists B. split... apply ClaI... Ens. split; subst.
      apply IncludP2. rewrite TwSetmin... apply Hsub in Hbt.
      apply ClaE in Hbt; tauto. }
  rewrite DeMorganUI in H3; try apply AArP...
  assert (⋂ cF1 = ⋂ AAr X (AAr X cF1)).
  { AppE; apply ClaE in H as []; apply ClaI; auto; intros.
    - apply ClaE in H1 as [_ [B [Hb Heq]]]. apply ClaE in Hb as
        [_ [C [Hc Heq1]]]. apply H0. subst. rewrite TwSetmin...
      apply Hsub in Hc. apply ClaE in Hc; tauto.
    - assert (y ⊂ X). { apply Hsub in H1. apply ClaE in H1; tauto. }
      apply H0. apply ClaI. Ens. exists (X - y). split.
      apply (AArI X _  cF1)... rewrite TwSetmin... } rewrite H, H3...
Qed.


From Coq Require Import Arith.
Require Import Arith.

Require Import Psatz.

Fixpoint div2 (n : nat) : nat :=
  match n with
    | 0 => 0
    | 1 => 0
    | S (S m) => S (div2 m)
  end.

Theorem div2_n: forall n k, div2 (2 * n + k) = n + div2 (k).
Proof.
  intros.
  induction n.
  - reflexivity.
  - rewrite Nat.mul_comm.
    simpl.
    rewrite Nat.mul_comm.
    rewrite IHn.
    reflexivity.
Qed.

Fixpoint arith_sum (n : nat) : nat :=
  match n with
  | 0 => 0
  | S m => n + arith_sum m
  end.

Definition arith_formula2 (n : nat) : nat := div2 (n * (n + 1)).

Definition arith_formula (n : nat) : nat := div2 (n * (n + 1)).

Theorem arith_eq (n : nat) : arith_formula n = arith_sum n.
Proof.
  intros.
  induction n.
    compute.
    reflexivity.
    unfold arith_formula.
    simpl arith_sum.
    rewrite <- IHn.
    simpl Nat.add.
    simpl Nat.mul.
    rewrite Nat.mul_comm.
    simpl Nat.mul.
    rewrite Nat.mul_comm.
    rewrite Nat.add_assoc.
    rewrite (Nat.add_comm n 1).
    simpl Nat.add.
    simpl div2.
    f_equal.
    unfold arith_formula.
    assert (forall x y : nat, div2 (x + x + y) = x + div2 (y)).
      intros x y.
      induction x.
        simpl.
        reflexivity.
        simpl Nat.add.
        rewrite (Nat.add_comm x (S x)).
        simpl Nat.add.
        simpl div2.
        f_equal.
        assumption.
    rewrite H.
    f_equal.
    f_equal.
    rewrite (Nat.add_comm n 1).
    simpl Nat.add.
    reflexivity.
    Show Proof.
Qed.

Theorem arith_eq2 : forall (n : nat), arith_formula n = arith_sum n.
Proof.
  intros n.
  induction n.
    compute.
    reflexivity.
    simpl arith_sum.
    rewrite <- IHn.
    unfold arith_formula.
    simpl Nat.mul.
    rewrite (Nat.add_comm n 1).
    simpl Nat.add.
    simpl div2.
    f_equal.
    rewrite Nat.mul_comm.
    simpl Nat.mul.
    rewrite Nat.add_assoc.
    assert (forall x y : nat, div2 (x + x + y) = x + div2 y).
      intros x y.
      induction x.
      simpl.
      reflexivity.
      simpl Nat.add.
      rewrite (Nat.add_comm x (S x)).
      simpl Nat.add.
      simpl div2.
      f_equal.
      assumption.
    rewrite H.
    f_equal. f_equal.
    rewrite (Nat.mul_comm n (S n)).
    simpl Nat.mul.
    reflexivity.
    Show Proof.
Qed.

Theorem arith_eq3 : forall (n : nat), arith_formula n = arith_sum n.
Proof.
  intros n.
  induction n.
  - compute.
    reflexivity.
  - simpl.
    rewrite <- IHn.
    unfold arith_formula.
    rewrite Nat.add_comm.
    simpl.
    rewrite Nat.mul_comm.
    simpl.
    pose proof div2_n n.
    simpl "*" in H.
    rewrite Nat.add_0_r in H.
    rewrite Nat.add_assoc.
    rewrite (H (n + n * n)).
    f_equal.
    f_equal.
    f_equal.
    symmetry.
    rewrite Nat.mul_comm.
    rewrite Nat.add_comm.
    simpl.
    reflexivity.
Qed.
(*
Theorem div2_formula : forall (x : nat), exists (y : nat), 2 * y = x * (x + 1).
Proof.
  intros x.
  induction x.
    exists 0.
    simpl.
    reflexivity.
    simpl Nat.mul.
    rewrite (Nat.add_comm x 1).
    simpl Nat.add.
    rewrite (Nat.mul_comm x (S (S x))).
    simpl Nat.mul.
    simpl Nat.add.
    assert (p : nat).
      trivial.
    exists (x + (S p)).
    simpl Nat.add.
    rewrite Nat.add_comm.
    rewrite (Nat.add_comm x (S p)).
    simpl Nat.add.
    rewrite Nat.add_comm.
    simpl Nat.add.
    f_equal.
    f_equal.
    rewrite (Nat.add_comm p x).
    destruct IHx as [h H].
    simpl Nat.mul in H.
    rewrite (Nat.add_comm x 1) in H.
    simpl Nat.mul in H.
    rewrite Nat.mul_comm in H.
    simpl in H .
    rewrite <- H.
    rewrite (Nat.add_comm h 0).
    rewrite (Nat.add_comm).
    rewrite (Nat.add_comm (x + p) 0).
    simpl Nat.add.
    repeat rewrite Nat.add_assoc.
*)

Theorem div2_formula : forall (x : nat), exists (y : nat), 2 * y = x * (x + 1).
Proof.
  intros.
  assert (forall a : nat, exists b : nat, (a = 2 * b) \/ (S a = 2 * b)).
    intros.
    induction a.
    simpl.
    exists 0.
    left.
    simpl.
    reflexivity.
    destruct IHa as [b' H].
    destruct H as [H | H].
    exists (S b').
    right.
    rewrite (Nat.mul_comm).
    simpl Nat.mul.
    rewrite (Nat.mul_comm).
    rewrite <- H.
    reflexivity.
    exists b'.
    left.
    assumption.
  destruct (H x) as [b e].
  destruct e as [e | e].
    rewrite e.
    exists (b * (2 * b + 1)).
    rewrite Nat.mul_assoc.
    reflexivity.
    rewrite (Nat.add_comm).
    simpl Nat.add.
    rewrite e.
    rewrite (Nat.mul_comm).
    exists (b * x).
    rewrite Nat.mul_assoc.
    reflexivity.
  Show Proof.
Qed.

Theorem inducted_div2 (x y : nat) : div2 (2 * x + y) = x + div2 (y).
Proof.
  induction x.
    simpl.
    reflexivity.
    simpl Nat.add.
    rewrite (Nat.add_comm x 0).
    simpl Nat.add.
    rewrite (Nat.add_comm x (S x)).
    simpl Nat.add.
    simpl div2.
    f_equal.
    assert (x + x = 2 * x).
    simpl.
    rewrite (Nat.add_comm x 0).
    simpl.
    reflexivity.
    rewrite H.
    assumption.
Qed.

Definition even n := exists y,     2 * y = n.
Definition odd  n := exists y, 1 + 2 * y = n.

Theorem even_div2 (n : nat) : even n -> 2 * div2 n = n.
Proof.
  intros.
  unfold even in H.
  destruct H.
  rewrite <- H.
  assert (2 * x = 2 * x + 0); auto.
  rewrite H0 at 1.
  rewrite (inducted_div2 x).
  simpl div2.
  simpl.
  rewrite (Nat.add_comm x 0).
  simpl.
  rewrite (Nat.add_comm x 0).
  simpl.
  reflexivity.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) : natural := mult y (Succ x).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (z : natural) : natural := mult z (Succ y).


(* Exercise 101b *)

Require Import BenB.

Variables A B C D : Prop.

(* Double Contrapositive, give a constructive proof *)

Theorem exercise_101b : (A -> B) -> (~~A -> ~~B).
Proof.
imp_i a1.
imp_i a2.
neg_i B a3.
hyp a3.
imp_e A.
hyp a1.
neg_e' (~A) a4.
hyp a2.
hyp a4.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus (Succ Zero) y.


From Coq Require Import NArith Arith Lia List.

Local Open Scope list_scope.

Definition range (offset count: N)
: list N
:= let fix range' (countdown: nat)
   := match countdown with
      | O => nil
      | S k => cons (offset + count - 1 - N.of_nat k)%N
                    (range' k)
      end
   in range' (N.to_nat count).

Local Example range_example:
  range 5 3 = (5 :: 6 :: 7 :: nil)%N.
Proof.
trivial.
Qed.

Definition range_nat (offset count: nat)
: list N
:= let fix range' (countdown: nat)
   := match countdown with
      | O => nil
      | S k => cons (N.of_nat (offset + count - 1 - k))
                    (range' k)
      end
   in range' count.

Lemma range_nat_ok (offset count: nat):
  range_nat offset count = range (N.of_nat offset) (N.of_nat count).
Proof.
unfold range, range_nat.
rewrite Nat2N.id.
revert offset. induction count. { trivial. }
intro offset. cbn.
assert (IH := IHcount (S offset)). clear IHcount.
f_equal. { f_equal. lia. }
assert (EqLHS:
          forall t,
            (fix range' (countdown : nat) : list N :=
             match countdown with
             | 0 => nil
             | S k => (N.of_nat (offset + S count - 1 - k)) :: range' k
             end) t
              =
            (fix range' (countdown : nat) : list N :=
             match countdown with
             | 0 => nil
             | S k => (N.of_nat (S offset + count - 1 - k)) :: range' k
             end) t).
{
  clear IH. intro t.
  revert offset. induction t. { easy. }
  intro offset.
  f_equal. 2:apply IHt.
  f_equal. f_equal. lia.
}
rewrite EqLHS. clear EqLHS.
assert (EqRHS:
          forall t,
            (fix range' (countdown : nat) : list N :=
             match countdown with
             | 0 => nil
             | S k =>
                 (N.of_nat offset + N.pos (Pos.of_succ_nat count) - 1 - N.of_nat k)%N :: range' k
             end) t
              =
            (fix range' (countdown : nat) : list N :=
             match countdown with
             | 0 => nil
             | S k => (N.of_nat (S offset) + N.of_nat count - 1 - N.of_nat k)%N :: range' k
             end) t).
{
  clear IH. intro t.
  revert offset. induction t. { easy. }
  intro offset.
  f_equal. 2:apply IHt.
  f_equal. f_equal. lia.
}
rewrite EqRHS. clear EqRHS.
apply IH.
Qed.

Lemma range_via_nat (offset count: N):
  range offset count = range_nat (N.to_nat offset) (N.to_nat count).
Proof.
rewrite range_nat_ok.
now repeat rewrite N2Nat.id.
Qed.

Lemma range_cons (offset count: N):
  range offset (N.succ count) = offset :: range (N.succ offset) count.
Proof.
rewrite range_via_nat.
unfold range_nat.
revert offset. induction count; intros.
{
  cbn. replace (Pos.to_nat 1) with 1 by easy.
  f_equal. lia.
}
cbn. rewrite Pnat.Pos2Nat.inj_succ.
f_equal. { lia. }
match goal with
|- ?l _ = ?r _ =>
        enough (forall x, l x = r x) by easy
end.
intro x. induction x. { trivial. }
f_equal. { lia. }
apply IHx.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * This module proves the validity of
    - well-founded recursion (also known as course of values)
    - well-founded induction
    from a well-founded ordering on a given set *)

Set Implicit Arguments.

Require Import Notations.
Require Import Logic.
Require Import Datatypes.

(** Well-founded induction principle on [Prop] *)

Section Well_founded.

 Variable A : Type.
 Variable R : A -> A -> Prop.

 (** The accessibility predicate is defined to be non-informative *)
 (** (Acc_rect is automatically defined because Acc is a singleton type) *)

 Inductive Acc (x: A) : Prop :=
     Acc_intro : (forall y:A, R y x -> Acc y) -> Acc x.

 Lemma Acc_inv : forall x:A, Acc x -> forall y:A, R y x -> Acc y.
  destruct 1; trivial.
 Defined.

 Global Arguments Acc_inv [x] _ [y] _, [x] _ y _.

 (** A relation is well-founded if every element is accessible *)

 Definition well_founded := forall a:A, Acc a.

 (** Well-founded induction on [Set] and [Prop] *)

 Hypothesis Rwf : well_founded.

 Theorem well_founded_induction_type :
  forall P:A -> Type,
    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
  intros; apply Acc_rect; auto.
 Defined.

 Theorem well_founded_induction :
  forall P:A -> Set,
    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
  exact (fun P:A -> Set => well_founded_induction_type P).
 Defined.

 Theorem well_founded_ind :
  forall P:A -> Prop,
    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
  exact (fun P:A -> Prop => well_founded_induction_type P).
 Defined.

(** Well-founded fixpoints *)

 Section FixPoint.

  Variable P : A -> Type.
  Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.

  Fixpoint Fix_F (x:A) (a:Acc x) : P x :=
    F (fun (y:A) (h:R y x) => Fix_F (Acc_inv a h)).

  Scheme Acc_inv_dep := Induction for Acc Sort Prop.

  Lemma Fix_F_eq :
   forall (x:A) (r:Acc x),
     F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)) = Fix_F (x:=x) r.
  Proof.
   destruct r using Acc_inv_dep; auto.
  Qed.

  Definition Fix (x:A) := Fix_F (Rwf x).

  (** Proof that [well_founded_induction] satisfies the fixpoint equation.
      It requires an extra property of the functional *)

  Hypothesis
    F_ext :
      forall (x:A) (f g:forall y:A, R y x -> P y),
        (forall (y:A) (p:R y x), f y p = g y p) -> F f = F g.

  Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F r = Fix_F s.
  Proof.
   intro x; induction (Rwf x); intros.
   rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros.
   apply F_ext; auto.
  Qed.

  Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y).
  Proof.
   intro x; unfold Fix.
   rewrite <- Fix_F_eq.
   apply F_ext; intros.
   apply Fix_F_inv.
  Qed.

 End FixPoint.

End Well_founded.

(** Well-founded fixpoints over pairs *)

Section Well_founded_2.

  Variables A B : Type.
  Variable R : A * B -> A * B -> Prop.

  Variable P : A -> B -> Type.

  Section FixPoint_2.

  Variable
    F :
      forall (x:A) (x':B),
        (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x'.

  Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) : P x x' :=
    F
      (fun (y:A) (y':B) (h:R (y, y') (x, x')) =>
         Fix_F_2 (x:=y) (x':=y') (Acc_inv a (y,y') h)).

  End FixPoint_2.

  Hypothesis Rwf : well_founded R.

  Theorem well_founded_induction_type_2 :
   (forall (x:A) (x':B),
      (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x') ->
   forall (a:A) (b:B), P a b.
  Proof.
   intros; apply Fix_F_2; auto.
  Defined.

End Well_founded_2.

Notation Acc_iter   := Fix_F   (only parsing). (* compatibility *)
Notation Acc_iter_2 := Fix_F_2 (only parsing). (* compatibility *)

(* Added by Julien Forest on 13/11/20 *)
Section Acc_generator.
  Variable A : Type.
  Variable R : A -> A -> Prop.

  (* *Lazily* add 2^n - 1 Acc_intro on top of wf.
     Needed for fast reductions using Function and Program Fixpoint
     and probably using Fix and Fix_F_2
   *)
  Fixpoint Acc_intro_generator n (wf : well_founded R)  :=
    match n with
        | O => wf
        | S n => fun x => Acc_intro x (fun y _ => Acc_intro_generator n (Acc_intro_generator n wf) y)
    end.

End Acc_generator.


Theorem ex50: forall a b c : Prop,
              (a -> b) -> ((b -> c) -> (a -> c)).
Proof.
  intros. apply (H0 (H H1)).
Qed.

Theorem ex50_1: forall a b c : Prop,
                (a <-> b) -> ((b <-> c) -> (a <-> c)).
Proof.
  Require Import Coq.Program.Basics.
  intros. elim H. elim H0. intros. split.
  apply (compose H1 H3). apply (compose H4 H2).
Qed.

Theorem ex50_2: forall a b c : Prop,
                (a -> b) -> ((c -> a) -> (c -> b)).
Proof.
  intros. apply (H (H0 H1)).
Qed.

Theorem ex51: forall a b c : Prop,
              (a -> (b -> c)) <-> (b -> (a -> c)).
Proof.
  split. intros. apply (H H1 H0). intros.
  apply (H H1 H0).
Qed.

Theorem ex52: forall a b c : Prop,
              (a -> (b -> c)) <-> (a /\ b -> c).
Proof.
  split. intros. elim H0. assumption.
  intros. apply H. split. assumption. assumption.
Qed.

Theorem ex53: forall a b : Prop,
              ~a -> (a -> b).
Proof.
  intros. contradiction.
Qed.

Theorem ex53_1: forall a b : Prop,
                ((a -> b) -> a) -> a.
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. cut a. intro.
  contradiction. apply H. intro. contradiction.
Qed.

Theorem ex53_2: forall a b c : Prop,
                (((a -> b) -> c) -> (a -> b)) -> (a -> b).
Proof.
  Require Import Classical.
  intros. apply NNPP. intro. apply H1.
  apply H. intro. elim H1. cut b. intro.
  contradiction. apply (H2 H0). assumption.
Qed.

Theorem ex53_3: forall a b : Prop,
                ((((a -> b) -> a) -> a) -> a) -> a.
Proof.
  Require Import Classical.
  intros. apply NNPP. intro.
  apply H0. apply H. intro.
  apply H1. intro. apply NNPP. intro.
  apply H0. assumption.
Qed.

Theorem ex53_4: forall a b : Prop,
                ((((a -> b) -> a) -> a) -> b) -> b.
Proof.
  Require Import Coq.Program.Basics.
  intros. apply H. intros. apply H0. intro.
  refine (apply H (fun H0 => H1)).
Qed.

Theorem ex53_5: forall a b c : Prop,
                ((((((a -> b) -> c) -> c)
                 -> a) -> a) -> b) -> b.
Proof.
  intros. apply H. intros. apply H0. intros.
  apply H1. intros. apply H.
  intros. assumption.
Qed.

Theorem ex53_6: forall a b c d : Prop,
                ((((((((a -> b) -> c) -> c) -> d)
                    -> d) -> a) -> a) -> b) -> b.
Proof.
  intros. apply H. intros. apply H0. intros.
  apply H1. intros. apply H2. intros.
  apply H. intros. assumption.
Qed.

Theorem ex53_7: forall a b : Prop,
                ((a -> b) -> b) -> ((b -> a) -> a).
Proof.
  intros. apply NNPP. intro.
  apply H1. apply H0. apply H. intro. contradiction.
Qed.


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection between booleans and propositions                            *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics.
From SLF Require Export LibBool LibLogic.

Implicit Type P : Prop.
Implicit Type b : bool.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Reflection between booleans and propositions *)

(** - [istrue b] produces a proposition that is [True] if and only if
      the boolean [b] is equal to [true].

    - [isTrue P] produces a boolean expression that is [true] if and only
      if the proposition [P] is equal to [True]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Translation from booleans into propositions *)

(** Any boolean [b] can be viewed as a proposition through the
    relation [b = true]. *)

Coercion istrue (b : bool) : Prop := (b = true).

(** Specification *)

Lemma istrue_eq_eq_true : forall b,
  istrue b = (b = true).
Proof using. reflexivity. Qed.

Lemma istrue_true_eq :
  istrue true = True.
Proof using. rewrite istrue_eq_eq_true. extens*. Qed.

Lemma istrue_false_eq :
  istrue false = False.
Proof using. rewrite istrue_eq_eq_true. extens. iff; auto_false. Qed.

Global Opaque istrue.

(** Proving the goals [true] and [~ false] *)

Lemma istrue_true : istrue true. (* [true] *)
Proof using. reflexivity. Qed.

Lemma not_istrue_false : ~ (istrue false). (* ~ false. *)
Proof using. rewrite istrue_false_eq. intuition. Qed.

(** Equivalence of [false] and [False] *)

Lemma false_of_False :
  False ->
  false.
Proof using. intros K. false. Qed.

Lemma False_of_false :
  false ->
  False.
Proof using. intros K. rewrite~ istrue_false_eq in K. Qed.

(** Hints for proving [false] and [False] *)

Hint Resolve istrue_true not_istrue_false.

Hint Extern 1 (istrue false) =>
  apply false_of_False.

Hint Extern 1 (False) => match goal with
  | H: istrue false |- _ => apply (not_istrue_false H) end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Translation from propositions into booleans *)

(** The expression [isTrue P] evaluates to [true] if and only if
    the proposition [P] is [True]. *)

Definition isTrue (P : Prop) : bool :=
  If P then true else false.

(** Specification *)

Lemma isTrue_eq_if : forall P,
  isTrue P = If P then true else false.
Proof using. reflexivity. Qed.

Lemma isTrue_True :
  isTrue True = true.
Proof using. unfolds. case_if; auto_false~. Qed.

Lemma isTrue_False :
  isTrue False = false.
Proof using. unfolds. case_if; auto_false~. Qed.

Global Opaque isTrue.

(** Lemmas *)

Lemma isTrue_eq_true : forall P,
  P ->
  isTrue P = true.
Proof using. intros. rewrite isTrue_eq_if. case_if*. Qed.

Lemma isTrue_eq_false : forall P,
  ~ P ->
  isTrue P = false.
Proof using. intros. rewrite isTrue_eq_if. case_if*. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Extensionality for boolean equality, stated using [istrue] *)

Lemma bool_ext : forall b1 b2,
  (b1 <-> b2) ->
  b1 = b2.
Proof using.
  destruct b1; destruct b2; intros; auto_false.
  destruct H. false H; auto.
  destruct H. false H0; auto.
Qed.

Lemma bool_ext_eq : forall b1 b2,
  (b1 = b2) = (b1 <-> b2).
Proof using.
  intros. extens. iff M. { subst*. } { applys* bool_ext. }
Qed.

Instance Extensionality_bool : Extensionality bool.
Proof using. apply (Extensionality_make bool_ext). Defined.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Specification of boolean equality *)

Definition is_beq A (beq:A->A->bool) :=
  forall x y, beq x y = isTrue (x = y).

(* ********************************************************************** *)
(* ################################################################# *)
(** * Rewriting rules *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Rewriting rules for distributing [istrue] *)

Lemma istrue_isTrue_eq : forall P,
  istrue (isTrue P) = P.
Proof using. extens. rewrite isTrue_eq_if. case_if; auto_false*. Qed.

Lemma istrue_neg_eq : forall b,
  istrue (!b) = ~ (istrue b).
Proof using. extens. tautob. Qed.

Lemma istrue_and_eq : forall b1 b2,
  istrue (b1 && b2) = (istrue b1 /\ istrue b2).
Proof using. extens. tautob. Qed.

Lemma istrue_or_eq : forall b1 b2,
  istrue (b1 || b2) = (istrue b1 \/ istrue b2).
Proof using. extens. tautob. Qed.

(** Corollary *)

Lemma istrue_neg_isTrue : forall P,
  istrue (! isTrue P) = ~ P.
Proof using. intros. rewrite istrue_neg_eq. rewrite~ istrue_isTrue_eq. Qed.

(** [istrue] and conditionals *)

Lemma If_istrue : forall b A (x y : A),
    (If istrue b then x else y)
  = (if b then x else y).
Proof using. intros. case_if as C; case_if as D; auto. Qed.

Lemma istrue_If_eq : forall P b1 b2,
    istrue (If P then b1 else b2)
  = (If P then istrue b1 else istrue b2).
Proof using. extens. case_if*. Qed.

Lemma istrue_if_eq : forall b1 b2 b3,
    istrue (if b1 then b2 else b3)
  = (If istrue b1 then istrue b2 else istrue b3).
Proof using. intros. do 2 case_if; auto. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Rewriting rules for distributing [isTrue] *)

Lemma isTrue_istrue : forall b,
  isTrue (istrue b) = b.
Proof using. extens. rewrite* istrue_isTrue_eq. Qed.

Lemma isTrue_not : forall P,
  isTrue (~ P) = ! isTrue P.
Proof using. extens. do 2 rewrite isTrue_eq_if. do 2 case_if; auto_false*. Qed.

Lemma isTrue_and : forall P1 P2,
  isTrue (P1 /\ P2) = (isTrue P1 && isTrue P2).
Proof using. extens. do 3 rewrite isTrue_eq_if. do 3 case_if; auto_false*. Qed.

Lemma isTrue_or : forall P1 P2,
  isTrue (P1 \/ P2) = (isTrue P1 || isTrue P2).
Proof using. extens. do 3 rewrite isTrue_eq_if. do 3 case_if; auto_false*. Qed.

(** Corollary *)

Lemma isTrue_not_istrue : forall b,
  isTrue (~ istrue b) = !b.
Proof using. intros. rewrite isTrue_not. rewrite~ isTrue_istrue. Qed.

(** Simplification of equalities involving isTrue *)

Section IsTrueEqualities.

Ltac prove_isTrue_lemma :=
  intros; try extens; try iff; rewrite isTrue_eq_if in *; case_if; auto_false*.

Lemma true_eq_isTrue_eq : forall P,
  (true = isTrue P) = P.
Proof using. prove_isTrue_lemma. Qed.

Lemma isTrue_eq_true_eq : forall P,
  (isTrue P = true) = P.
Proof using. prove_isTrue_lemma. Qed.

Lemma false_eq_isTrue_eq : forall P,
  (false = isTrue P) = ~ P.
Proof using. prove_isTrue_lemma. Qed.

Lemma isTrue_eq_false_eq : forall P,
  (isTrue P = false) = ~ P.
Proof using. prove_isTrue_lemma. Qed.

Lemma isTrue_eq_isTrue_eq : forall P1 P2,
  (isTrue P1 = isTrue P2) = (P1 <-> P2).
Proof using.
  intros. extens. iff; repeat rewrite isTrue_eq_if in *;
  repeat case_if; auto_false*.
Qed.

End IsTrueEqualities.

(** [isTrue] and conditionals *)

Lemma if_isTrue : forall P A (x y : A),
    (if isTrue P then x else y)
  = (If P then x else y).
Proof using.
  intros. case_if as C; case_if as D; auto.
  { rewrite* isTrue_eq_true_eq in C. }
  { rewrite* isTrue_eq_false_eq in C. }
Qed.

Lemma isTrue_If : forall P1 P2 P3,
    isTrue (If P1 then P2 else P3)
  = If P1 then isTrue P2 else isTrue P3.
Proof using. extens. case_if*. Qed.

Lemma isTrue_If_eq_if_isTrue : forall P1 P2 P3,
    isTrue (If P1 then P2 else P3)
  = (if isTrue P1 then isTrue P2 else isTrue P3).
Proof using. intros. rewrite if_isTrue. rewrite~ isTrue_If. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lemmas for testing booleans *)

Lemma bool_inv_or : forall b,
  b \/ !b.
Proof using. tautob. Qed.

Lemma bool_inv_or_eq : forall b,
  b = true \/ b = false.
Proof using. tautob. Qed.

Lemma xor_inv_or : forall b1 b2,
  xor b1 b2 ->
     (b1 = true /\ b2 = false)
  \/ (b1 = false /\ b2 = true).
Proof using. tautob; auto_false*. Qed.

Arguments xor_inv_or [b1] [b2].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lemmas for normalizing [b = true] and [b = false] terms *)

Lemma bool_eq_true_eq : forall b,
  (b = true) = istrue b.
Proof using. extens. tautob. Qed.

Lemma bool_eq_false_eq : forall b,
  (b = false) = istrue (!b).
Proof using. extens. tautob. Qed.

Lemma true_eq_bool_eq : forall b,
  (true = b) = istrue b.
Proof using. extens. tautob. Qed.

Lemma false_eq_bool_eq : forall b,
  (false = b) = istrue (!b).
Proof using. extens. tautob. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics [rew_istrue] to distribute [istrue] *)

(** [rew_istrue] distributes [istrue]. It is useful to replace all
    boolean operators with corresponding logical operators. *)

Hint Rewrite istrue_true_eq istrue_false_eq istrue_isTrue_eq
  istrue_neg_eq istrue_and_eq istrue_or_eq
  If_istrue istrue_If_eq istrue_if_eq: rew_istrue.

Tactic Notation "rew_istrue" :=
  autorewrite with rew_istrue.
Tactic Notation "rew_istrue" "in" hyp(H) :=
  autorewrite with rew_istrue in H.
Tactic Notation "rew_istrue" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_istrue).
  (* autorewrite with rew_istrue in *. *)

Tactic Notation "rew_istrue" "~" :=
  rew_istrue; auto_tilde.
Tactic Notation "rew_istrue" "~" "in" hyp(H) :=
  rew_istrue in H; auto_tilde.
Tactic Notation "rew_istrue" "~" "in" "*" :=
  rew_istrue in *; auto_tilde.

Tactic Notation "rew_istrue" "*" :=
  rew_istrue; auto_star.
Tactic Notation "rew_istrue" "*" "in" hyp(H) :=
  rew_istrue in H; auto_star.
Tactic Notation "rew_istrue" "*" "in" "*" :=
  rew_istrue in *; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics [rew_isTrue] to distribute [isTrue] *)

(** [rew_isTrue] distributes [isTrue].
    This tactic is probably much less useful than [rew_istrue], since logical
    operators are often simpler to work with. *)

Hint Rewrite isTrue_True isTrue_False isTrue_istrue
  isTrue_not isTrue_and isTrue_or
  if_isTrue isTrue_If : rew_isTrue.

Tactic Notation "rew_isTrue" :=
  autorewrite with rew_isTrue.
Tactic Notation "rew_isTrue" "in" hyp(H) :=
  autorewrite with rew_isTrue in H.
Tactic Notation "rew_isTrue" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_isTrue).
  (* autorewrite with rew_isTrue in *. *)

Tactic Notation "rew_isTrue" "~" :=
  rew_isTrue; auto_tilde.
Tactic Notation "rew_isTrue" "~" "in" hyp(H) :=
  rew_isTrue in H; auto_tilde.
Tactic Notation "rew_isTrue" "~" "in" "*" :=
  rew_isTrue in *; auto_tilde.

Tactic Notation "rew_isTrue" "*" :=
  rew_isTrue; auto_star.
Tactic Notation "rew_isTrue" "*" "in" hyp(H) :=
  rew_isTrue in H; auto_star.
Tactic Notation "rew_isTrue" "*" "in" "*" :=
  rew_isTrue in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Tactics useful for program verification, when reasoning about
       the result of if-statements over boolean expressions, i.e.
       an expression of the form [b = ..] or [.. = b], which produces
       hypotheses of the form [true = ..] and [false = ..] or symmetric.
       It is used as post-treatment for tactic [case_if]. *)

Hint Rewrite
  true_eq_isTrue_eq isTrue_eq_true_eq
  false_eq_isTrue_eq isTrue_eq_false_eq
  isTrue_eq_isTrue_eq
  not_not_eq
  istrue_true_eq istrue_false_eq istrue_isTrue_eq
  istrue_neg_eq istrue_and_eq istrue_or_eq
  bool_eq_true_eq bool_eq_false_eq true_eq_bool_eq false_eq_bool_eq
  : rew_bool_eq.

Tactic Notation "rew_bool_eq" :=
  autorewrite with rew_bool_eq.
Tactic Notation "rew_bool_eq" "~" :=
  rew_bool_eq; auto_tilde.
Tactic Notation "rew_bool_eq" "*" :=
  rew_bool_eq; auto_star.

Tactic Notation "rew_bool_eq" "in" hyp(H) :=
  autorewrite with rew_bool_eq in H.
Tactic Notation "rew_bool_eq" "~" "in" hyp(H) :=
  rew_bool_eq in H; auto_tilde.
Tactic Notation "rew_bool_eq" "*" "in" hyp(H) :=
  rew_bool_eq in H; auto_star.

Tactic Notation "rew_bool_eq" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_bool_eq).
  (* autorewrite with rew_bool_eq in *. *)
Tactic Notation "rew_bool_eq" "~" "in" "*" :=
  rew_bool_eq; auto_tilde.
Tactic Notation "rew_bool_eq" "*" "in" "*" :=
  rew_bool_eq; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics extended for reflection *)

(** Extension of the tactic [case_if] to automatically performs
    simplification using [logics].

    For less aggressive introduction of [istrue], consider rewriting
    without the lemmas:
    [bool_eq_true_eq bool_eq_false_eq true_eq_bool_eq false_eq_bool_eq]
*)

Ltac case_if_post H ::=
  rew_bool_eq in H; tryfalse.

(** Extension of the tactic [test_dispatch] from LibLogic.v, so as to
    be able to call the tactic [tests] directly on boolean expressions *)

Ltac tests_bool_base E H1 H2 :=
  tests_prop_base (istrue E) H1 H2.

Ltac tests_dispatch E H1 H2 ::=
  match type of E with
  | bool => tests_bool_base E H1 H2
  | Prop => tests_prop_base E H1 H2
  | {_}+{_} => tests_ssum_base E H1 H2
  end.

(** Extension of the tactic [apply_to_head_of] (see LibTactics). *)

Ltac apply_to_head_of E cont ::=
  let go E := let P := get_head E in cont P in
  match E with
  | istrue ?A => go A
  | istrue (neg ?A) => go A
  | ?A = ?B => first [ go A | go B ]
  | ?A => go A
  end.

(* 2021-08-11 15:24 *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Ralph Matthes [+]                              *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation IRIT -- CNRS   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Wellfounded Permutation.

Require Import list_utils.

Set Implicit Arguments.

Section sorted.

  Variable (X : Type) (R : X -> X -> Prop).

  Inductive sorted : list X -> Prop :=
    | in_sorted_0 : sorted nil
    | in_sorted_1 : forall x l, Forall (R x) l -> sorted l -> sorted (x::l).

  Fact sorted_app l m : (forall x y, In x l -> In y m -> R x y) -> sorted l -> sorted m -> sorted (l++m).
  Proof.
    intros H H1 Hm; revert H1 H.
    induction 1 as [ | x l H1 H2 IH2 ]; intros H3; simpl; auto.
    constructor.
    + apply Forall_app; auto.
      apply Forall_forall; intros; apply H3; simpl; auto.
    + apply IH2; intros; apply H3; simpl; auto.
  Qed.

  Variable (f : X -> X) (Hf : forall x y, R x y -> R (f x) (f y)).

  Fact sorted_map l : sorted l -> sorted (map f l).
  Proof.
    induction 1 as [ | x l H1 H2 IH2 ]; simpl; constructor; auto.
    apply Forall_forall.
    rewrite Forall_forall in H1.
    intros y; rewrite in_map_iff.
    intros (? & ? & ?); subst; auto.
  Qed.

End sorted.

Fact sorted_mono X (R S : X -> X -> Prop) l : (forall x y, In x l -> In y l -> R x y -> S x y) -> sorted R l -> sorted S l.
Proof.
  intros H1 H2; revert H2 H1.
  induction 1 as [ | x l H1 H2 IH2 ]; intros H3.
  + constructor.
  + constructor.
    * revert H1; do 2 rewrite Forall_forall.
      intros H1 y Hy; apply H3; simpl; auto.
    * apply IH2; intros ? ? ? ?; apply H3; simpl; auto.
Qed.

Section list_has_dup.

  Variable (X : Type).

  Implicit Types (l m : list X).

  Inductive list_has_dup : list X -> Prop :=
    | in_list_hd0 : forall l x, In x l -> list_has_dup (x::l)
    | in_list_hd1 : forall l x, list_has_dup l -> list_has_dup (x::l).

  Fact list_hd_cons_inv x l : list_has_dup (x::l) -> In x l \/ list_has_dup l.
  Proof. inversion 1; subst; auto. Qed.

  Fact list_has_dup_app_left l m : list_has_dup m -> list_has_dup (l++m).
  Proof. induction l; simpl; auto; constructor 2; auto. Qed.

  Fact list_has_dup_app_right l m : list_has_dup l -> list_has_dup (l++m).
  Proof.
    induction 1; simpl.
    + constructor 1; apply in_or_app; left; auto.
    + constructor 2; auto.
  Qed.

  Fact perm_list_has_dup l m : l ~p m -> list_has_dup l -> list_has_dup m.
  Proof.
    induction 1 as [ | x l m H1 IH1 | x y l | ]; auto;
      intros H; apply list_hd_cons_inv in H.
    + destruct H as [ H | H ].
      * apply Permutation_in with (1 := H1) in H.
        apply in_list_hd0; auto.
      * apply in_list_hd1; auto.
    + destruct H as [ [ H | H ] | H ]; subst.
      * apply in_list_hd0; left; auto.
      * apply in_list_hd1, in_list_hd0; auto.
      * apply list_hd_cons_inv in H.
        destruct H as [ H | H ].
        - apply in_list_hd0; right; auto.
        - do 2 apply in_list_hd1; auto.
  Qed.

  Fact list_has_dup_eq_duplicates m: list_has_dup m <-> exists x aa bb cc, m = aa++x::bb++x::cc.
  Proof.
    split.
    + induction 1 as [ m x Hm | m x _ IHm ].
      - apply in_split in Hm.
        destruct Hm as (bb & cc & Hm).
        exists x, nil, bb, cc; subst; auto.
      - destruct IHm as (y & aa & bb & cc & IHm).
        exists y, (x::aa), bb, cc; subst; auto.
    + intros (x & aa & bb & cc & Hm).
      subst m.
      apply list_has_dup_app_left.
      constructor 1; apply in_or_app; right.
      constructor 1; reflexivity.
  Qed.

End list_has_dup.

Section sorted_no_dup.

  Variables (X : Type) (R : X -> X -> Prop) (HR : forall x, ~ R x x).

  Lemma sorted_no_dup l : sorted R l -> ~ list_has_dup l.
  Proof.
    induction 1 as [ | x l H1 H2 IH2 ]; intros H.
    + inversion H.
    + apply list_hd_cons_inv in H.
      destruct H as [ H | H ]; try tauto.
      rewrite Forall_forall in H1; firstorder.
  Qed.

End sorted_no_dup.

Section no_dup_sorted_with_ineq.

  Variables (X : Type).

  Let R := fun (x y: X) => x <> y.

  (** for this specific relation, not having duplicates is equivalent to being sorted: *)

  Lemma no_dup_sorted_with_ineq l: sorted R l <-> ~ list_has_dup l.
  Proof.
    split.
    * apply sorted_no_dup; intros ? []; trivial.
    * induction l as [ | x l IHl].
      - constructor.
      - intros H; constructor.
        + rewrite Forall_forall.
          intros y Hy ?; subst.
          apply H.
          constructor 1; trivial.
        + apply IHl; contradict H.
          constructor 2; trivial.
  Qed.

End no_dup_sorted_with_ineq.

Section no_dups_eq_perm.

  Variables (X : Type).

  Lemma no_dups_eq_perm (l m : list X) :
        (forall x, In x l <-> In x m)
     -> ~ list_has_dup l
     -> ~ list_has_dup m
     -> l ~p m.
  Proof.
    revert m; induction l as [ | x l IH ]; intros m H1 H2 H3.
    * destruct m as [ | y m ].
      + constructor.
      + exfalso; apply (H1 y); simpl; auto.
    * assert (In x m) as Hm.
      { apply H1; simpl; auto. }
      apply in_split in Hm.
      destruct Hm as (m1 & m2 & ?); subst.
      assert (~ In x l) as H4.
      { contradict H2; constructor 1; auto. }
      assert (~ In x m1) as H5.
      { contradict H3.
        apply in_split in H3.
        destruct H3 as (p1 & p2 & ?); subst.
        apply list_has_dup_eq_duplicates.
        exists x,p1,p2,m2; rewrite app_ass; auto. }
      assert (~ In x m2) as H6.
      { contradict H3.
        apply in_split in H3.
        destruct H3 as (p1 & p2 & ?); subst.
        apply list_has_dup_eq_duplicates.
        exists x,m1,p1,p2; auto. }
      apply Permutation_cons_app, IH.
      + intros y; split.
        - intros G1.
          generalize (proj1 (H1 y) (or_intror G1)).
          intros G2.
          apply in_app_or in G2.
          apply in_or_app.
          destruct G2 as [|[|]]; subst; tauto.
        - intros G1.
          generalize (proj2 (H1 y)); intros G2.
          apply in_app_or in G1.
          destruct G2; subst; try tauto.
          apply in_or_app; simpl; tauto.
      + contradict H2; constructor 2; auto.
      + contradict H3.
        apply perm_list_has_dup with (1 := Permutation_middle _ _ _).
        constructor 2; auto.
  Qed.

End no_dups_eq_perm.

Section sorted_perm.

  Variables (X : Type) (R S : X -> X -> Prop) (l m : list X)
            (Hlm : forall x, In x l <-> In x m)
            (HR : forall x, ~ R x x)
            (HS : forall x, ~ S x x)
            (Hl : sorted R l) (Hm : sorted S m).

  Theorem sorted_perm : l ~p m.
  Proof.
    apply no_dups_eq_perm; auto.
    + apply sorted_no_dup with (1 := HR); trivial.
    + apply sorted_no_dup with (1 := HS); trivial.
  Qed.

End sorted_perm.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.Crypto.
Require Import FCF.RndNat.
Require Import FCF.NotationV1.

Definition Bernoulli(r : Rat) : Comp bool :=
  match r with
    | RatIntro n d =>
      v <-$ RndNat d; ret (if (lt_dec v n) then true else false)
  end.

Theorem Bernoulli_correct :
  forall (r : Rat),
    r <= 1 ->
    Pr[Bernoulli r] == r.

  unfold Bernoulli.
  intuition.
  destruct r.

  rewrite RndNat_seq.

  rewrite (sumList_filter_partition (fun z => if (lt_dec z n) then true else false)).
  eapply eqRat_trans.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply ratAdd_eqRat_compat.

  eapply sumList_all.
  intros.
  destruct ( lt_dec a n).
  simpl.
  destruct ( EqDec_dec bool_EqDec true true).
  eapply eqRat_refl.
  intuition.
  apply filter_In in H0.
  intuition.
  exfalso.
  destruct (lt_dec a n); intuition.

  eapply sumList_0.
  intros.
  apply filter_In in H0.
  intuition.
  destruct (lt_dec a n); simpl in *.
  discriminate.
  destruct (EqDec_dec bool_EqDec false true); intuition.

  rewrite allNatsLt_filter_lt.
  rewrite <- ratAdd_0_r.
  rewrite ratMult_1_r.
  rewrite allNatsLt_length.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms.
  omega.
  unfold posnatMult, posnatToNat, natToPosnat.
  destruct p.
  omega.

  eapply rat_le_1_if; trivial.

Qed.

Theorem Bernoulli_wf :
  forall r,
    well_formed_comp (Bernoulli r).

  intuition.
  unfold Bernoulli.
  destruct r.
  wftac.

Qed.

Theorem Bernoulli_correct_complement :
  forall (r : Rat),
    r <= 1 ->
    evalDist (Bernoulli r) false ==
    ratSubtract 1 r.

  intuition.
  eapply eqRat_trans.
  eapply evalDist_complement.
  eapply Bernoulli_wf.
  eapply ratSubtract_eqRat_compat; intuition.
  eapply Bernoulli_correct.
  trivial.
Qed.


Require Export XR_R.
Require Export XR_Rle.
Require Export XR_Rle_antisym.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2.
Proof.
intros x y.
split.
{
  intros [ hxy hyx ].
  apply Rle_antisym.
  { exact hxy. }
  { exact hyx. }
}
{
  intro heq.
  subst y.
  split.
  { unfold "<=". right. reflexivity. }
  { unfold "<=". right. reflexivity. }
}
Qed.


Require Import univalenceSolutions.

Section category.

  Record caty:=
    {obj:Type;
     arr:Type;
     s:arr->obj;
     t:arr->obj;
     e:obj->arr;
     t_section:
       forall x:obj,
         t(e(x)) = x;
     s_section:
       forall x:obj,
         x = s(e(x));
     comp:
       forall g f:arr,
         t(f)=s(g) -> arr;
     s_comp:
       forall g f:arr,
       forall H:t(f)=s(g),
         s(f) = s(comp g f H);
     t_comp:
       forall g f:arr,
       forall H:t(f)=s(g),
         t(comp g f H) = t(g);
     left_id:
       forall g:arr, forall m:obj,
           forall H:t(e(m)) = s(g),
           comp g (e(m)) H = g;
     right_id:
       forall g:arr, forall m:obj,
           forall H:t(g) = s(e(m)),
             comp (e(m)) g H = g;
     assoc:
       forall h g f:arr,
       forall H:t(f)=s(g),
       forall K:t(g)=s(h),
         comp (comp h g K) f (eq_trans H (s_comp h g K)) = comp h (comp g f H) (eq_trans (t_comp g f H) K)
    }.

  Arguments t {c}.
  Arguments s {c}.
  Arguments e {c}.
  Arguments comp {c}.
  Arguments t_section {c}.
  Arguments s_section {c}.
  Arguments s_comp {c}.
  Arguments t_comp {c}.
  Arguments left_id {c}.
  Arguments right_id {c}.
  Arguments assoc {c}.

  Record hom {C:caty} (a b:obj C):=
    {arrow:>arr C;
     source:(s(arrow)=a);
     target:(t(arrow)=b)}.

  Lemma s_hom {C:caty} {a b:obj C} (f:hom a b):
    s(f) = a.
  Proof.
    apply source. Defined.

  Lemma t_hom {C:caty} {a b:obj C} (f:hom a b):
    t(f) = b.
  Proof.
    apply target. Defined.

  Definition comp_hom {C:caty} {a b c:obj C}
             (g:hom b c) (f:hom a b):arr C.
  Proof.
    apply (comp g f). rewrite t_hom. rewrite s_hom. reflexivity.
    Defined.

  Definition isIso {C:caty} (f:arr C):=
    exists g:arr C, exists (H:t(f)=s(g)), exists (K:t(g)=s(f)),
          (comp g f H) = e(s(f)) /\ (comp f g K) = e(s(g)).

  Definition iso {C:caty} (a b:obj C):=
    exists f:arr C,
      (s(f) = a)/\(t(f) = b)/\(isIso f).

  Lemma idToIso {C:caty} (a b:obj C):
    (Id a b) -> iso a b.
  Proof.
    intros. unfold iso. induction X. exists (e(x)).
    split.
    - apply eq_sym. apply s_section.
    - split.
      -- apply t_section.
      -- unfold isIso. exists (e(x)).
         exists (eq_trans (t_section x) (s_section x)).
         exists (eq_trans (t_section x) (s_section x)).
         split.
         --- rewrite (s_section x). rewrite left_id.
             rewrite <- s_section. rewrite <- s_section.
             reflexivity.
         --- rewrite (s_section x). rewrite left_id.
             rewrite <- s_section. rewrite <- s_section.
             reflexivity.
  Defined.

  Axiom caty_univalence:
    forall {C:caty} (a b:obj C),
      IsEquiv(idToIso a b).

End category.

Arguments t {c}.
Arguments s {c}.
Arguments e {c}.
Arguments comp {c}.
Arguments t_section {c}.
Arguments s_section {c}.
Arguments s_comp {c}.
Arguments t_comp {c}.
Arguments left_id {c}.
Arguments right_id {c}.
Arguments assoc {c}.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  mult (Succ y) (Succ x).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) (z : natural) (x : natural)
  : natural := plus z (mult x z).


Require Export Dm_nex.
Require Export Dm_alln.
Section ml.
Theorem Dm_nexe: forall A:Set -> Prop,
(~ exists x:Set, A x) <-> forall x:Set, ~ A x.
Proof.
split.
apply Dm_nex.
apply Dm_alln.
Qed.
End ml.

Check Dm_nexe.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (z : natural) (lf2 : natural)
  : natural := mult lf1 (Succ Zero).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) (lf1 : natural) (y : natural)
  : natural := plus Zero (mult y x).


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Definition(s):
    Deterministic Simple Stack Machines
*)

Require Import List.
Require Import Relation_Operators.

Definition stack : Set := list bool.
Definition state : Set := nat.
(* configuration: left stack, state, right stack *)
Definition config : Set := stack * state * stack.
(* direction: true = move left, false = move right *)
Definition dir : Set := bool.
(* stack symbol: true = 1, false = 0 *)
Definition symbol : Set := bool.
(* instruction:
  (x, y, a, b, true ) = ax -> by
  (x, y, b, a, false ) = xb -> ay *)
Definition instruction : Set := state * state * symbol * symbol * dir.
(* simple stack machine: list of instructions *)
Definition ssm : Set := list instruction.

Inductive step (M : ssm) : config -> config -> Prop :=
  (* transition AaxB -> AybB *)
  | step_l (x y: state) (a b: symbol) (A B: stack) :
    In (x, y, a, b, true) M -> step M (a::A, x, B) (A, y, b::B)
  (* transition AxbB -> AayB *)
  | step_r (x y: state) (a b: symbol) (A B: stack) :
    In (x, y, b, a, false) M -> step M (A, x, b::B) (a::A, y, B).

(* step is functional *)
Definition deterministic (M: ssm) := forall (X Y Z: config), step M X Y -> step M X Z -> Y = Z.

(* deterministic simple stack machine *)
Definition dssm := { M : ssm | deterministic M }.

(* reflexive transitive closure of step *)
Definition reachable (M: ssm) : config -> config -> Prop := clos_refl_trans config (step M).


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype prime.
From mathcomp Require Import div ssralg poly polydiv polyorder ssrnum zmodp polyrcf.

Set Implicit Arguments.
Unset Strict Implicit.

Import GRing.Theory. (*Num.Theory Num.Def.*)
Import Pdiv.Idomain.

Open Scope ring_scope.

Section more_deriv.

Lemma derivXsubCexpSn : forall (R : idomainType) (c : R) (n : nat),
   (('X-c%:P) ^+(n.+1))^`() = (n.+1)%:R *: ('X-c%:P) ^+ n.
Proof.
move=> R c; elim=> [|m Hm]; first by rewrite scaler_nat expr0 expr1 derivXsubC.
rewrite exprSr derivM derivXsubC Hm -scalerAl -exprSr mulr1 scaler_nat -mulrSr.
by rewrite -scaler_nat.
Qed.

Lemma derivXsubCexpn : forall (R : idomainType) (c : R) (n : nat),
   (0 < n)%N -> (('X-c%:P) ^+n)^`() = n%:R *: ('X-c%:P) ^+ (n.-1).
Proof. by move=> R c; elim=> [|m Hm H] //=; rewrite derivXsubCexpSn. Qed.

End more_deriv.

Section poly_simple_roots.

Variable R : idomainType.
Hypothesis HR : [char R] =i pred0.

Lemma mu_x_gcdp : forall (p : {poly R}) (x : R), (p != 0) -> (root p x) ->
   \mu_x (gcdp p p^`()) == (\mu_x p) .-1.
Proof.
move=> p x Hp zero_x.
(*about p*)
have [q Hq Hpp] := (@mu_spec R p x Hp).
(*mu x > 0*)
have Hmu : ((\mu_x p)%R > 0)%N by rewrite mu_gt0.
(*about p'*)
have Hpderiv : (deriv p) =
   ('X - x%:P) ^+ (\mu_x p).-1 * ((\mu_x p)%:R *: q + ('X-x%:P) * (deriv q)).
  by rewrite mulrDr mulrA -exprSr prednK // -scalerCA -derivXsubCexpn //
     -derivM mulrC {1}Hpp.
(**********)
rewrite eq_sym -muP.
  apply/andP; split.
(*(X-x)^m-1 divides pgcd*)
    rewrite dvdp_gcd.
    apply/andP; split.
(*(X-x)^m-1 divides p*)
      by rewrite {2}Hpp -(@prednK (\mu_x p)) // exprS mulrA; apply dvdp_mulIr.
(*(X-x)^m-1 divides p'*)
    by rewrite Hpderiv; apply dvdp_mulIl.
(*(X-x)^m doesn't divide pgcd*)
  rewrite prednK // dvdp_gcd negb_and.
  apply/orP; right.
(*(X-x)^m doesn't divide p'*)
  rewrite Hpderiv -{1}(@prednK (\mu_x p)) // exprSr dvdp_mul2l.
(*(X-x) doesn't divide the remaining factor of p'*)
    rewrite dvdp_addl; last by apply dvdp_mulr.
    rewrite (@eqp_dvdr _  q ((\mu_x p)%:R *: q) ('X -x%:P)).
      by rewrite dvdp_XsubCl.
    apply eqp_scale.
    have/charf0P ->:= HR.
    by rewrite -lt0n //.
  by rewrite -size_poly_gt0 size_exp_XsubC prednK //.
by rewrite gcdp_eq0 negb_and Hp.
Qed.

Lemma mu_gcdp_eq1 : forall (p : {poly R}) (x : R), (p != 0) -> root p x ->
   (\mu_x (divp p (gcdp p p^`())) == 1)%N.
Proof.
move=> p x Hp zero_x.
rewrite -(@eqn_add2r ((\mu_x)%R p)) (@addnC 1%N _) addn1
  -{1}(@prednK ((\mu_x)%R p)) ?mu_gt0 //.
rewrite addnS -(eqP (mu_x_gcdp Hp zero_x)) -mu_mul.
  rewrite divpK ?mu_mulC //; last by apply dvdp_gcdl.
  by apply lc_expn_scalp_neq0.
rewrite divpK.
  rewrite -size_poly_gt0 -mul_polyC size_Cmul ?size_poly_gt0 //.
  by apply lc_expn_scalp_neq0.
by apply dvdp_gcdl.
Qed.

Lemma same_roots_1 : forall (p : {poly R}) (x : R), root p x ->
   root (divp p (gcdp p p^`())) x.
Proof.
move=> p x zero_x.
case h: (p==0).
  by move/eqP: h => H; move : zero_x; rewrite H deriv0 gcd0p div0p.
move/negbT: h => H; rewrite -mu_gt0.
  by move/eqP : (mu_gcdp_eq1 H zero_x) => ->.
rewrite divpN0; first by apply: leq_gcdpl.
by move/negPf : H => H; rewrite gcdp_eq0 H.
Qed.

Lemma same_roots_2 : forall (p : {poly R}) (x : R),
   root (divp p (gcdp p p^`())) x -> root p x.
Proof.
move=> p x zero_x.
rewrite -(@rootZ R x (lead_coef (gcdp p p^`()) ^+ scalp (R:=R) p
   (gcdp p p^`())) p).
  rewrite -divpK.
    by rewrite rootM zero_x.
  by apply dvdp_gcdl.
by apply lc_expn_scalp_neq0.
Qed.

Lemma gcdp_simple_roots : forall (p : {poly R}) (x : R), (p != 0) ->
   root (divp p (gcdp p p^`())) x ->
   (\mu_x (divp p (gcdp p p^`())) == 1)%N.
Proof.
by move=> p x Hp zero_x; apply (mu_gcdp_eq1 Hp); apply same_roots_2.
Qed.
(*p!=0 beause of mu_polyC.*)

End poly_simple_roots.


Fixpoint factorial (n:nat) : nat :=
    match n with
    | 0 => 1
    | S n => mult (plus n 1) (factorial n)
    end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.


From mathcomp Require Import ssreflect.

Require Import set_notations.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section UniqueExample.
  Variable U:Type.
  Import SetNotations.

  Goal forall (A B: Ensemble U),
      (exists! x, x ∈ A) ->
                  (forall (x:U),(x∈ A) -> (x ∈ B)) -> exists x, (x∈ A) /\ (x ∈ B).
  Proof.
    move => A B H H0.
    destruct H.
    unfold unique in H.
    exists x.
    inversion H.
    split.
    apply H1.
    apply H0.
    apply H1.
  Qed.

End UniqueExample.


From mathcomp Require Import all_ssreflect.

(******************************************************************************)
(*                                                                            *)
(* f is a strictly increasing function such that f (f n) = 3 n                *)
(* does it exist an n0 such that f n0 = 2022                                  *)
(*                                                                            *)
(******************************************************************************)

Section PuzzleFF.

Variable f : nat -> nat.

Hypothesis monof : {mono f : m n / m < n}.

Lemma leqfD a b : f a + b <= f (a + b).
Proof.
elim: b a => [a|b IH a]; first by rewrite !addn0.
by rewrite !addnS (leq_ltn_trans (IH a)) //= monof.
Qed.

Lemma leqf2D a b c : f (a + c) <= b + c -> f a <= b.
Proof.
elim: c => [|c IH fLb]; first by rewrite !addn0.
apply: IH.
by rewrite -ltnS -addnS (leq_trans _ fLb) // monof addnS.
Qed.

Lemma eqf2D a b c : f (a + b) = f a + b -> c <= b -> f (a + c) = f a + c.
Proof.
elim: c => [|c IH  fabE cLb]; first by by rewrite !addn0.
have facE : f (a + c) = f a + c by apply: IH => //; apply: ltnW.
apply/eqP; rewrite eqn_leq leqfD andbT.
apply: leqf2D (_ : _ <= _ + (b - c.+1)).
by do 2 rewrite -addnA (subnKC cLb) ?fabE.
Qed.

Lemma leqnfn n : n <= f n.
Proof.
by elim: n => // n IH; apply: leq_ltn_trans IH _; rewrite monof.
Qed.

Hypothesis ffE : forall n, f (f n) = 3 * n.

Lemma ltnfn n : 0 < n -> n < f n.
Proof.
move=> n_gt0.
have := leqnfn n; rewrite leq_eqVlt; case: eqP => // nE _.
have : f n = 3 * n by rewrite [in LHS]nE ffE.
move=> /eqP; rewrite -nE -{1}(mul1n n) eqn_mul2r.
by case: (n) n_gt0.
Qed.

Lemma leqfn3n n : f n <= 3 * n.
Proof. by rewrite -ltnS -monof ffE (leqnfn (S (3 * n))). Qed.

Lemma ltfn3n n : 0 < n -> f n < 3 * n.
Proof.
move=> n_gt0.
have := leqfn3n n; rewrite leq_eqVlt; case: eqP => // fnE _.
have : 3 * n < f (3 * n) by apply: ltnfn; rewrite muln_gt0.
by rewrite -[in X in _ < X -> _]fnE ffE ltnn.
Qed.

Lemma f1E : f 1 = 2.
Proof.
by apply/eqP; rewrite eqn_leq ltnfn // -ltnS ltfn3n.
Qed.

Lemma f2E : f 2 = 3.
Proof. by rewrite -[in LHS]f1E ffE. Qed.

Lemma f3nE n : f (3 ^ n) = 2 * 3 ^ n /\ f (2 * 3 ^ n) = 3 ^ (S n).
Proof.
elim: n => [|n [IH1 IH2]]; first by rewrite f1E f2E.
have f3SnE : f (3 ^ n.+1) = 2 * 3 ^ n.+1 .
  by rewrite -[in LHS]IH2 ffE mulnC -mulnA expnS [3 * _]mulnC.
by split => //; rewrite -f3SnE ffE !expnS.
Qed.

Fact f1293E : f 1293 = 2022.
Proof.
destruct (f3nE 6) as [H1 H2].
rewrite -[2022]/(2 * 3 ^ 6 + (2022 - 2 * (3 ^ 6))).
rewrite -{1}[1293]/(3 ^ 6 + (2022 - 2 * (3 ^ 6))).
rewrite -[X in _ = X + _]H1.
apply: eqf2D (_ : _ = _ + 3 ^ 6) _ => //.
by rewrite -[3 ^ 6 + 3 ^ 6]/(2 * 3 ^ 6) H2 H1.
Qed.

End PuzzleFF.