From Coq Require Import Program.
From QuickChick Require Import QuickChick.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path order.
Global Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Sorting algorithms *)

(* Insertion sort *)
Module Insertion.
Section InsertionSort.

Variable T : eqType.
Variable leT : rel T.
Implicit Types x y z : T.
Implicit Types s t u : seq T.

(* insert an element e into a sorted list s *)
Fixpoint insert e s : seq T :=
    if s is x :: s' then
        if leT e x then
            e :: s
        else
            x :: (insert e s')
    else [:: e].

(* sort input list s *)
Fixpoint sort s : seq T :=
    if s is x :: s' then
        insert x (sort s')
    else
        [::].

Fail Fixpoint sorted' s : bool :=
    if s is x1 :: x2 :: s' then
        leT x1 x2 && (sorted' (x2 :: s'))
    else true.
Fixpoint sorted' s : bool :=
    if s is x1 :: ((x2 :: s') as tail) then
        leT x1 x2 && (sorted' tail)
    else true.

Print sorted.
Print path.

Lemma sorted_cons x s :
    sorted leT (x :: s) -> sorted leT s.
Proof.
move=> //= ; case: s=> //= e s; move/andP; by case.
Qed.

Definition fake_sort s : seq T := [::].

Lemma sorted_fake_sort s : sorted leT (fake_sort s).
Proof. done. Qed.

Print perm_eq.
Print permP.

(* sorted (sort s) /\ perm_eq s (sort s) *)
Lemma sort_sorted s :
    sorted leT (sort s).
Proof.
elim: s=> [// | x s IHs /=].
Abort.

Lemma insert_sorted e s :
    sorted leT s ->
    sorted leT (insert e s).
Proof.
elim: s=> [// | x1 s IHs].
move=> /=.
move=> path_x1_s.
case: ifP=> [e_le_x1 | e_gt_x1].
- by rewrite /= e_le_x1 path_x1_s.
Abort.

Print total.
Hypothesis leT_total : total leT.

Lemma insert_sorted e s :
    sorted leT s ->
    sorted leT (insert e s).
Proof.
elim: s=> [// | x1 s IHs].
move=> /= path_x1_s.
case: ifP=> [e_le_x1 | e_gt_x1].
- by rewrite /= e_le_x1 path_x1_s.
have:= leT_total e x1.
rewrite {}e_gt_x1.
move=> /= x1_le_e.
move: path_x1_s=> {}/path_sorted/IHs.
case: s=> [|x2 s]; first by rewrite /= x1_le_e.
move=> /=.
case: ifP.
move=> /= -> /= path_x2_s.
by apply/andP.
Abort. (* again... *)

Lemma insert_path z e s :
    leT z e ->
    path leT z s ->
    path leT z (insert e s).
Proof.
elim: s z=> [/= | x1 s IHs] z; first by move=> ->.
move=> z_le_e /=.
case/andP=> z_le_x1 path_x1_s.
case: ifP.
- by rewrite /= z_le_e path_x1_s => ->.
move=> /= e_gt_x1.
rewrite z_le_x1.
have:= leT_total e x1.
rewrite {}e_gt_x1 /= => x1_le_e.
exact: IHs.
Qed.

Lemma insert_sorted e s :
    sorted leT s ->
    sorted leT (insert e s).
Proof.
rewrite /sorted.
case: s=> // x s.
move=> /=.
case: ifP; first by move=> /= ->->.
move=> e_gt_x.
apply: insert_path.
have:= leT_total e x.
by rewrite e_gt_x /=.
Qed.

Lemma sort_sorted s :
    sorted leT (sort s).
Proof.
elim: s=> [// | x s IHs /=].
by apply: insert_sorted.
Qed.

End InsertionSort.

Arguments sort {T} _ _.
Arguments insert {T} _ _ _.

Section SortIsPermutation.
Variable T : eqType.
Variable leT : rel T.

Lemma count_insert p e s :
    count p (insert leT e s) = p e + count p s.
Proof.
by elim: s=> //= x s; case: ifP=> _ //= -> ; rewrite addnCA.
Qed.

Print perm_eql.
Lemma perm_sort s : perm_eql (sort leT s) s.
Proof.
Search _ (perm_eq ?s1 =1 perm_eq ?s2).
apply/permPl/permP.
elim: s=> //= x s IHs p.
by rewrite count_insert IHs.
Qed.

Lemma mem_sort s : sort leT s =i s.
Proof. by apply: perm_mem; rewrite perm_sort. Qed.

Lemma sort_uniq s : uniq (sort leT s) = uniq s.
Proof. by apply: perm_uniq; rewrite perm_sort. Qed.

End SortIsPermutation.

Section SortProperties.

Variable T : eqType.
Variable leT : rel T.

Lemma sorted_sort s :
    sorted leT s -> sort leT s = s.
Proof.
elim: s=> //= x1 s IHs S.
move: (S) => {}/sorted_cons/IHs /= ->.
move: S=> /=.
case: s=> //= x2 s.
by case/andP=> ->.
Qed.

End SortProperties.
End Insertion.

(* Merge sort *)
Module Merge.

Section MergeSortDef.

Context {disp : unit} {T : orderType disp}.
Implicit Types s t : seq T.

Fixpoint split s : seq T * seq T :=
    match s with
    | [::] => (s, s)
    | [:: x] => (s, [::])
    | [:: x, y & s] =>
        let '(t1, t2) := split s in
        (x :: t1, y :: t2)
    end.
Arguments split : simpl nomatch.
Lemma split_lt1 s2 s1 s :
    1 < size s ->
    split s = (s1, s2) ->
    (size s1 < size s).
Proof.
Admitted.
Lemma split_lt2 s1 s2 s :
    1 < size s ->
    split s = (s1, s2) ->
    (size s2 < size s).
Proof.
Admitted.

Fail Fixpoint merge s t : seq T :=
    match s, t with
    | [::], _ => t
    | _, [::] => s
    | x :: s', y :: t' =>
        if (x <= y)%O then x :: merge s' t else y :: merge s t'
    end.

(*|
Nested `fix`-combinator idiom
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|*)

Fixpoint merge s t : seq T :=
    let fix merge_s t :=
        match s, t with
        | [::], _ => t
        | _, [::] => s
        | x :: s', y :: t' =>
            if (x <= y)%O
            then x :: merge s' t
            else y :: merge_s  t'
        end
    in merge_s t.

Fail Fixpoint sort s : seq T :=
    match s with
    | [::] => s
    | [:: _] => s
    | _ => let '(s1, s2) := split s in merge (sort s1) (sort s2)
  end.

Print Typing Flags.
Unset Guard Checking.
Print Typing Flags.

Fixpoint sort_unguarded s : seq T :=
    match s with
    | [::] => s
    | [:: _] => s
    | _ => let '(s1, s2) := split s in
            merge (sort_unguarded s1) (sort_unguarded s2)
  end.
Print Assumptions sort_unguarded.
Set Guard Checking.

Program Fixpoint sort s {measure (size s)} : seq T :=
    match s with
    | [::] => s
    | [:: _] => s
    | _ => let '(s1, s2) := split s in
            merge (sort s1) (sort s2)
    end.
Next Obligation.
apply/ltP; rewrite (@split_lt1 s2) //.
by case: s sort H0 H Heq_anonymous=> // x1 [] // _ _ /(_ x1).
Qed.
Next Obligation.
apply/ltP; rewrite (@split_lt2 s1) //.
by case: s sort H0 H Heq_anonymous=> // x1 [] // _ _ /(_ x1).
Qed.
Next Obligation. done. Qed.

End MergeSortDef.

(* Example: using orderType instances *)
Section MergeSortTest.

Compute merge [:: 1; 3; 5] [:: 2; 4; 6].
Compute sort_unguarded [:: 6; 4; 2; 1; 1; 5].
Compute sort [:: 6; 4; 2; 1; 1; 5].

End MergeSortTest.

Section MergeSortCorrect.

Context {disp : unit} {T : orderType disp}.
Implicit Types s t : seq T.

(*| (Optional) exercise |*)
Lemma sort_sorted s :
  sorted (<=%O) (sort s).
Proof.
Admitted.

End MergeSortCorrect.
End Merge.

Section AccFrom.

Variable (p : pred nat).

Inductive acc_from i : Prop :=
| AccNow of p i
| AccLater of acc_from i.+1.

End AccFrom.

About acc_from_ind.

Section SimpleExamples.

Goal acc_from (fun n => n == 42) 0.
Proof.
do 42 apply: AccLater.
by apply: AccNow.
Qed.

Goal acc_from (fun n => n == 42) 43 -> False.
Proof.
elim.
Abort.

Goal acc_from (fun n => n == 42) 43 -> False.
Proof.
fix inacc 1.
Show Proof.
case=> //.
Abort.

Lemma inacc_from43 :
    forall x, 42 < x -> acc_from (fun n => n == 42) x -> False.
Proof.
fix inacc 3.
Show Proof.
move=> x x_gt42.
case=> [/eqP E|].
- by rewrite E in x_gt42.
apply: inacc.
by apply: (ltn_trans x_gt42).
Qed.

End SimpleExamples.

Section Find.

Variable p : pred nat.

Lemma find_ex :
    (exists n, p n) -> {m | p m}.
Proof.
move=> exp.
have: acc_from p 0.
case: exp=> n.
rewrite -(addn0 n).
elim: n 0=> [| n IHn] j.
by left.
rewrite addSnnS.
right.
by apply: IHn.

move: 0.
fix find_ex 2=> m IHm.
case pm: (p m).
- by exists m.
apply: find_ex m.+1 _.
case: IHm.
by rewrite pm.
done.
Defined.


(* TPPmark2019 solution by Mitsuharu Yamamato *)
From mathcomp Require Import all_ssreflect.

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

Section TPPmark2019.

Section Definitions.

(* Problem 1 *)

Variant direction := left | right.

Variables (state symbol : finType).

Record turing_machine :=
  TuringMachine {
      transition : state -> symbol -> option (state * symbol * direction);
      initial : state;
    }.

Definition cyclic_tape : Type := symbol * seq symbol.
Definition configuration : Type := state * cyclic_tape.

(* Problem 2 *)

Variable m : turing_machine.

Definition step (c : configuration) : option configuration :=
  let: (q, (x, s)) := c in
  if m.(transition) q x is Some (q', x', d)
  then Some (q', match d with
                 | left =>  (last x' s, belast x' s)
                 | right => (head x' s, behead (rcons s x'))
                 end)
  else None.

(* Problem 3 *)

Definition halts (t : cyclic_tape) :=
  exists n, iter n (obind step) (Some (m.(initial), t)) = None.

Definition reachable (c c': configuration) :=
  exists n, iter n (obind step) (Some c) = Some c'.

End Definitions.

(* Problem 4 *)

Section ZeroClear.

Variant zcstate := zcinit0 | zcinit1 | zcinit2 | zcinit3
                   | zcforw0 | zcforw1 | zcback0.

Variant zcsymbol := zc0 | zc1.

Definition zctrans q x :=
  match q, x with
  | zcinit0, _   => Some (zcinit1, zc1, right)
  | zcinit1, zc1 => Some (zcinit2, zc0, left)
  | zcinit1, _   => Some (zcforw0, zc1, right)
  | zcinit2, zc1 => Some (zcinit3, zc1, right)
  | zcinit2, _   => None
  | zcinit3, _   => Some (zcforw0, zc1, right)
  | zcforw0, zc1 => Some (zcforw1, zc0, right)
  | zcforw0, _   => Some (zcforw0, zc0, right)
  | zcforw1, zc1 => Some (zcback0, zc1, left)
  | zcforw1, _   => Some (zcforw0, zc0, right)
  | zcback0, zc1 => Some (zcinit2, zc0, left)
  | zcback0, _   => Some (zcback0, zc0, left)
  end.

Definition zcstate2o (q : zcstate) : 'I_7 :=
  match q with
  | zcinit0 => inord 4 | zcinit1 => inord 3 | zcinit2 => inord 2
  | zcinit3 => inord 1 | zcforw0 => inord 0
  | zcforw1 => inord 6 | zcback0 => inord 5
  end.

Definition o2zcstate (o : 'I_7) : option zcstate :=
  match val o with
  | 4 => Some zcinit0 | 3 => Some zcinit1 | 2 => Some zcinit2
  | 1 => Some zcinit3 | 0 => Some zcforw0
  | 6 => Some zcforw1 | 5 => Some zcback0
  | _ => None
  end.

Lemma pcan_zcstateo7 : pcancel zcstate2o o2zcstate.
Proof. by case; rewrite /o2zcstate /= inordK. Qed.

Definition zcstate_eqMixin := PcanEqMixin pcan_zcstateo7.
Canonical zcstate_eqType := EqType zcstate zcstate_eqMixin.
Definition zcstate_choiceMixin := PcanChoiceMixin pcan_zcstateo7.
Canonical zcstate_choiceType := ChoiceType zcstate zcstate_choiceMixin.
Definition zcstate_countMixin := PcanCountMixin pcan_zcstateo7.
Canonical zcstate_countType := CountType zcstate zcstate_countMixin.
Definition zcstate_finMixin := PcanFinMixin pcan_zcstateo7.
Canonical zcstate_finType := FinType zcstate zcstate_finMixin.

Definition zcsymbol2b (x : zcsymbol) : bool :=
  match x with | zc0 => false | zc1 => true end.

Definition b2zcsymbol (b : bool) : zcsymbol :=
  if b then zc1 else zc0.

Lemma can_zcsymbolb : cancel zcsymbol2b b2zcsymbol.
Proof. by case. Qed.

Definition zcsymbol_eqMixin := CanEqMixin can_zcsymbolb.
Canonical zcsymbol_eqType := EqType zcsymbol zcsymbol_eqMixin.
Definition zcsymbol_choiceMixin := CanChoiceMixin can_zcsymbolb.
Canonical zcsymbol_choiceType := ChoiceType zcsymbol zcsymbol_choiceMixin.
Definition zcsymbol_countMixin := CanCountMixin can_zcsymbolb.
Canonical zcsymbol_countType := CountType zcsymbol zcsymbol_countMixin.
Definition zcsymbol_finMixin := CanFinMixin can_zcsymbolb.
Canonical zcsymbol_finType := FinType zcsymbol zcsymbol_finMixin.

Definition zc := {| transition := zctrans; initial := zcinit0 |}.

(* Problem 5 *)

Definition zcconfig := configuration [finType of zcstate] [finType of zcsymbol].

Fixpoint trace {state symbol : finType}
         (m : turing_machine state symbol) c fuel :=
  if fuel is fuel'.+1 then
    c :: if step m c is Some c' then trace m c' fuel' else [::]
  else [::].

Definition zcweight (c : zcconfig) :=
  let: (q, (x, s)) := c in
  (count_mem zc1 (match q with
                 | zcinit0 => zc1 :: if s is _ :: s' then zc1 :: s' else [::]
                 | zcinit1 => zc1 :: s
                 | zcinit2 =>   x :: if s is _ :: s' then zc1 :: s' else [::]
                 | zcinit3 => zc1 :: s
                 | _       =>   x :: s
                 end) * (ord_max : returnType zcstate2o).+1
   + zcstate2o q) * (size s).+1
  + match q with
    | zcforw0 => size s - index zc1 (rev s)
    | zcback0 => index zc1 (rev (behead (rcons s x)))
    | _       => 0
    end.

Compute let c := (zcinit0, (zc0, [:: zc0; zc1; zc0; zc1; zc1]))
        in trace zc c (zcweight c).
     (* = [:: (zcinit0, (zc0, [:: zc0; zc1; zc0; zc1; zc1])); *)
     (*       (zcinit1, (zc0, [:: zc1; zc0; zc1; zc1; zc1])); *)
     (*       (zcforw0, (zc1, [:: zc0; zc1; zc1; zc1; zc1])); *)
     (*       (zcforw1, (zc0, [:: zc1; zc1; zc1; zc1; zc0])); *)
     (*       (zcforw0, (zc1, [:: zc1; zc1; zc1; zc0; zc0])); *)
     (*       (zcforw1, (zc1, [:: zc1; zc1; zc0; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc1; zc1; zc1; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc1; zc1; zc1; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc0; zc1; zc1; zc1])); *)
     (*       (zcback0, (zc1, [:: zc0; zc0; zc0; zc1; zc1])); *)
     (*       (zcinit2, (zc1, [:: zc0; zc0; zc0; zc0; zc1])); *)
     (*       (zcinit3, (zc0, [:: zc0; zc0; zc0; zc1; zc1])); *)
     (*       (zcforw0, (zc0, [:: zc0; zc0; zc1; zc1; zc1])); *)
     (*       (zcforw0, (zc0, [:: zc0; zc1; zc1; zc1; zc0])); *)
     (*       (zcforw0, (zc0, [:: zc1; zc1; zc1; zc0; zc0])); *)
     (*       (zcforw0, (zc1, [:: zc1; zc1; zc0; zc0; zc0])); *)
     (*       (zcforw1, (zc1, [:: zc1; zc0; zc0; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc1; zc1; zc0; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc1; zc1; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc0; zc1; zc1; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc0; zc0; zc1; zc1])); *)
     (*       (zcback0, (zc1, [:: zc0; zc0; zc0; zc0; zc1])); *)
     (*       (zcinit2, (zc1, [:: zc0; zc0; zc0; zc0; zc0])); *)
     (*       (zcinit3, (zc0, [:: zc0; zc0; zc0; zc0; zc1])); *)
     (*       (zcforw0, (zc0, [:: zc0; zc0; zc0; zc1; zc1])); *)
     (*       (zcforw0, (zc0, [:: zc0; zc0; zc1; zc1; zc0])); *)
     (*       (zcforw0, (zc0, [:: zc0; zc1; zc1; zc0; zc0])); *)
     (*       (zcforw0, (zc0, [:: zc1; zc1; zc0; zc0; zc0])); *)
     (*       (zcforw0, (zc1, [:: zc1; zc0; zc0; zc0; zc0])); *)
     (*       (zcforw1, (zc1, [:: zc0; zc0; zc0; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc1; zc0; zc0; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc1; zc0; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc0; zc1; zc0; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc0; zc0; zc1; zc0])); *)
     (*       (zcback0, (zc0, [:: zc0; zc0; zc0; zc0; zc1])); *)
     (*       (zcback0, (zc1, [:: zc0; zc0; zc0; zc0; zc0])); *)
     (*       (zcinit2, (zc0, [:: zc0; zc0; zc0; zc0; zc0]))] *)
     (* : seq (configuration zcstate_finType zcsymbol_finType) *)

Compute let c := (zcinit0, (zc0, [::]))
        in trace zc c (zcweight c).
     (* = [:: (zcinit0, (zc0, [::])); (zcinit1, (zc1, [::])); *)
     (*       (zcinit2, (zc0, [::]))] *)
     (* : seq (configuration zcstate_finType zcsymbol_finType) *)

Compute let c := (zcinit0, (zc0, [:: zc1]))
        in trace zc c (zcweight c).
     (* = [:: (zcinit0, (zc0, [:: zc1])); (zcinit1, (zc1, [:: zc1])); *)
     (*       (zcinit2, (zc1, [:: zc0])); (zcinit3, (zc0, [:: zc1])); *)
     (*       (zcforw0, (zc1, [:: zc1])); (zcforw1, (zc1, [:: zc0])); *)
     (*       (zcback0, (zc0, [:: zc1])); (zcback0, (zc1, [:: zc0])); *)
     (*       (zcinit2, (zc0, [:: zc0]))] *)
     (* : seq (configuration zcstate_finType zcsymbol_finType) *)

(* Problem 6 *)

(*
(zcinit0, ..* )
  . -> (zcinit1, 1, right)
    .\..* = .*
    next: (zcinit1, .*1) = (zcinit1, 1) | (zcinit1, .+1)

(zcinit1, 1)
  0 -> (zcforw0, 1, right)
    0\1 = {}
  1 -> (zcinit2, 0, left)
    1\1 = ""
    next: (zcinit2, 0) <= (zcinit2, 0+)
(zcinit1, .+1)
  0 -> (zcforw0, 1, right)
    0\.+1 = .*1
    next: (zcforw0, .*11) <= (zcforw0, .*110* )
  1 -> (zcinit2, 0, left)
    1\.+1 = .*1
    next: (zcinit2, 10.* )

(zcinit2, 10.* )
  0 -> accept
    0\10.* = {}
  1 -> (zcinit3, 1, right)
    1\10.* = 0.*
    next: (zcinit3, 0.*1)
(zcinit2, 0+ )
  0 -> accept
    0\0+ = 0*
  1 -> (zcinit3, 1, right)
    1\0+ = {}

(zcinit3, 0.*1)
  . -> (zcforw0, 1, right)
    .\.+1 = .*1
    next: (zcforw0, .*11) <= (zcforw0, .*110* )

(zcforw0, 110* )
  0 -> (zcforw0, 0, right)
    0\110* = {}
  1 -> (zcforw1, 0, right)
    1\110* = 10*
    next: (zcforw1, 10+)
(zcforw0, .+110* )
  0 -> (zcforw0, 0, right)
    0\.+110* = .*110*
    next: (zcforw0, .*110+) = (zcforw0, 110* ) | (zcforw0, .+110* )
  1 -> (zcforw1, 0, right)
    1\.+110* = .*110*
    next: (zcforw1, .*110+) = (zcforw1, 110+) | (zcforw1, .+110+)

(zcforw1, 110+)
  0 -> (zcforw0, 0, right)
    0\110+ = {}
  1 -> (zcback0, 1, left)
    1\110+ = 10+
    next: (zcback0, 0110* ) <= (zcback0, 0.*110* )
(zcforw1, .+110+)
  0 -> (zcforw0, 0, right)
    0\.+110+ = .*110+
    next: (zcforw0, .*1100+) <= (zcforw0, 110* ) | (zcforw0, .+110* )
  1 -> (zcback0, 1, left)
    1\.+110+ = .*110+
    next: (zcback0, 01.*110* ) <= (zcback0, 0.*110* )
(zcforw1, 10+)
  0 -> (zcforw0, 0, right)
    0\10+ = {}
  1 -> (zcback0, 1, left)
    1\10+ = 0+
    next: (zcback0, 010* ) <= (zcback0, 0+10* )

(zcback0, 0.*110* )
  0 -> (zcback0, 0, left)
    0\0.*110* = .*110* = .*110+|.*11
    next: (zcback0, 00.*110* ) <= (zcback0, 0.*110* )
    next: (zcback0, 10.*1)
  1 -> (zcinit2, 0, left)
    1\0.*110* = {}
(zcback0, 0+10* )
  0 -> (zcback0, 0, left)
    0\0+10* = 0*10* = 0*10+ | 0*1
    next: (zcback0, 00+10* ) <= (zcback0, 0+10* )
    next: (zcback0, 10+)
  1 -> (zcinit2, 0, left)
    1\0+10* = {}
(zcback0, 10.*1)
  0 -> (zcback0, 0, left)
    0\10.*1 = {}
  1 -> (zcinit2, 0, left)
    1\10.*1 = 0.*1
    next: (zcinit2, 100.* ) <= (zcinit2, 10.* )
(zcback0, 10+)
  0 -> (zcback0, 0, left)
    0\10+ = {}
  1 -> (zcinit2, 0, left)
    1\10+ = 0+
    next: (zcinit2, 00+) <= (zcinit2, 0+)
*)

Variant zcinv : zcconfig -> Prop :=
| ZCInvInit0 x s                (* ..* *)
  : zcinv (zcinit0, (x,   s))
| ZCInvInit1A                   (* 1 *)
  : zcinv (zcinit1, (zc1, [::]))
| ZCInvInit1B x s               (* .+1 *)
  : zcinv (zcinit1, (x,   rcons s zc1))
| ZCInvInit2A s                 (* 10.* *)
  : zcinv (zcinit2, (zc1, zc0 :: s))
| ZCInvInit2B n                 (* 0+ *)
  : zcinv (zcinit2, (zc0, nseq n zc0))
| ZCInvInit3 s                  (* 0.*1 *)
  : zcinv (zcinit3, (zc0, rcons s zc1))
| ZCInvForw0A n                 (* 110* *)
  : zcinv (zcforw0, (zc1, zc1 :: nseq n zc0))
| ZCInvForw0B x s n             (* .+110* *)
  : zcinv (zcforw0, (x,   s ++ zc1 :: zc1 :: nseq n zc0))
| ZCInvForw1A n                 (* 110+ *)
  : zcinv (zcforw1, (zc1, zc1 :: nseq n.+1 zc0))
| ZCInvForw1B x s n             (* .+110+ *)
  : zcinv (zcforw1, (x,   s ++ zc1 :: zc1 :: nseq n.+1 zc0))
| ZCInvForw1C n                 (* 10+ *)
  : zcinv (zcforw1, (zc1, nseq n.+1 zc0))
| ZCInvBack0A s n               (* 0.*110* *)
  : zcinv (zcback0, (zc0, s ++ zc1 :: zc1 :: nseq n zc0))
| ZCInvBack0B n1 n2             (* 0+10* *)
  : zcinv (zcback0, (zc0, nseq n1 zc0 ++ zc1 :: nseq n2 zc0))
| ZCInvBack0C s                 (* 10.*1 *)
  : zcinv (zcback0, (zc1, zc0 :: rcons s zc1))
| ZCInvBack0D n                 (* 10+ *)
  : zcinv (zcback0, (zc1, nseq n.+1 zc0)).

Lemma rcons_nseq (T : Type) n (x : T) : rcons (nseq n x) x = x :: nseq n x.
Proof. by rewrite -cats1 cat_nseq /ncons -iterSr. Qed.

Lemma last_nseq (T : Type) n (x : T) : last x (nseq n x) = x.
Proof. by move: (lastI x (nseq n x)); rewrite -rcons_nseq => /rcons_inj []. Qed.

Lemma belast_nseq (T : Type) n (x : T) : belast x (nseq n x) = nseq n x.
Proof. by move: (lastI x (nseq n x)); rewrite -rcons_nseq => /rcons_inj []. Qed.

Lemma zcinv_invariant c : zcinv c ->
                          if step zc c is Some c' then zcinv c' else True.
Proof.
  case=> [x [|x1 s]||[] [|x s]|s||[|x1 s]|n|[] [|x s] n
          |n|[] [|x s] n|n|s [|n]|n1 [|n2]|s|n] //=; try by constructor.
  - exact: (ZCInvInit2B 0).
  - exact: (ZCInvForw0A 0).
  - by rewrite -!cats1 -catA /=; apply: (ZCInvForw0B _ _ 0).
  - by rewrite last_rcons; constructor.
  - exact: (ZCInvForw0A 0).
  - by rewrite -!cats1 -catA /=; apply: (ZCInvForw0B _ _ 0).
  - by rewrite rcons_nseq; constructor.
  - by rewrite rcons_nseq; apply: (ZCInvForw0A _.+1).
  - by rewrite rcons_cat !rcons_cons rcons_nseq; apply: (ZCInvForw0B _ _ _.+1).
  - by rewrite rcons_nseq; constructor.
  - by rewrite rcons_cat !rcons_cons rcons_nseq; constructor.
  - by rewrite last_nseq belast_nseq; apply: (ZCInvBack0A [::]).
  - by rewrite rcons_nseq; apply: (ZCInvForw0A _.+2).
  - by rewrite rcons_cat !rcons_cons rcons_nseq; apply: (ZCInvForw0B _ _ _.+2).
  - by rewrite last_nseq belast_nseq; apply: (ZCInvBack0A [:: _]).
  - rewrite -rcons_nseq last_cat belast_cat /= last_rcons belast_rcons.
    by rewrite -cat1s -[last _ _ :: _]cat1s !catA; constructor.
  - by rewrite last_nseq belast_nseq; apply: (ZCInvBack0B 0).
  - by rewrite last_cat belast_cat /= -cat1s catA !cats1 -lastI; constructor.
  - rewrite -rcons_nseq last_cat belast_cat /= last_rcons belast_rcons.
    by rewrite -cat1s -[last _ _ :: _]cat1s !catA; constructor.
  - by rewrite cats1 last_rcons belast_rcons; constructor.
  - rewrite -rcons_nseq last_cat belast_cat /= last_nseq belast_nseq.
    rewrite last_rcons belast_rcons -cat1s catA cats1 rcons_nseq.
    by rewrite -[_ :: _]/(nseq _.+1 _); constructor.
  - by rewrite last_rcons belast_rcons; constructor.
  - by rewrite last_nseq belast_nseq; apply: (ZCInvInit2B _.+1).
Qed.

Theorem zc_partially_correct t c :
  reachable zc (zc.(initial), t) c ->
  step zc c = None ->
  let: (q, (x, s)) := c in x = zc0 /\ forall y, y \in s -> y = zc0.
Proof.
  move=> c_reach.
  suff: zcinv c.
  { case=> [||[]|||||[]||[]|||||] // [|n] _; split=> // y; rewrite mem_nseq.
    by case: eqP. }
  case: c_reach => n; elim: n => [|n IHn] /= in c *.
  - by case: t c => x s [q [x' s']] [<- <- <-]; constructor.
  - set it := iter _ _ _; case E: it => [c'|] //= step_some.
    by move/IHn/zcinv_invariant: E; rewrite step_some.
Qed.

Lemma zcinv_tape_short_init q x :
  zcinv (q, (x, [::])) -> q \in [:: zcinit0; zcinit1; zcinit2].
Proof.
  by case E: _ / => [? ?||? ?|||[|? ?]||_ [|? ?]||_ [|? ?]||[|? ?]|[|?]||] //=;
     case: E => ->; rewrite !inE eqxx ?orbT.
Qed.

Lemma zcweight_decreasing c :
  zcinv c -> if step zc c is Some c' then zcweight c' < zcweight c else true.
Proof.
  case: c => q [x [| y s]];
    first by move/zcinv_tape_short_init; rewrite !inE => /or3P [] /eqP ->;
             [ |case: x..]; rewrite /= ?inordK.
  case: q; [ |case: x|case: x| |case: x..]; rewrite /= ?inordK // => inv.
  - (* zcinit0 -> zcinit1 *)
    rewrite size_rcons -cats1 count_cat [count_mem _ _ + _]addnC !addn0.
    by rewrite ltn_mul2r ltn_add2l.
  - (* zcinit1 -> zcforw0 *)
    rewrite size_rcons -cats1 count_cat [count_mem _ _ + _]addnC addnCA.
    rewrite !addn0 [(_ + 3) * _]mulnDl ltn_add2l.
    rewrite (leq_ltn_trans (leq_subr _ _)) // -{1}[_.+1]addn0 mulSn.
    by rewrite leq_add2l.
  - (* zcinit1 -> zcinit2 *)
    rewrite size_belast -[(y == _) + _]/(count_mem _ (_ :: _)) [y :: s]lastI.
    rewrite -cats1 count_cat /= !addn0 addnCA [_ + count_mem _ _]addnC.
    by rewrite ltn_mul2r ltn_add2l.
  - (* zcinit2 -> zcinit3 *)
    rewrite size_rcons -cats1 count_cat [count_mem _ _ + _]addnC !addn0.
    by rewrite ltn_mul2r ltn_add2l.
  - (* zcinit3 -> zcforw0 *)
    rewrite size_rcons -cats1 count_cat /= !addn0 [_ + 1]addnC addnCA.
    by rewrite [(_ + 1) * _]mulnDl mul1n ltn_add2l rev_cat.
  - (* zcforw0 -> zcforw0 *)
    rewrite add0n -cats1 count_cat size_cat /= !addn0 addn1 ltn_add2l.
    rewrite rev_cat /= rev_cons -cats1 index_cat mem_rev ifT.
    + by rewrite ltn_sub2l // ltnS (leq_trans (index_size _ _)) // size_rev.
    + case E: _ / inv => [|||||||? [|? s1] n|||||||] //; case: E => _ _ ->.
      * by rewrite inE.
      * by rewrite mem_cat inE eqxx orbT.
  - (* zcforw0 -> zcforw1 *)
    rewrite size_rcons -cats1 count_cat /= !addn0 [1 + _]addnC.
    rewrite !mulnDl mul1n -[_ + 7 * _ + _]addnA ltn_add2l.
    by rewrite (leq_trans _ (leq_addr _ _)) // ltn_mul2r.
  - (* zcforw1 -> zcforw0 *)
    rewrite size_rcons -cats1 count_cat /= !addn0 add0n [(_ + 6) * _]mulnDl.
    by rewrite ltn_add2l (leq_ltn_trans (leq_subr _ _)) // leq_pmull.
  - (* zcforw1 -> zcback0 *)
    rewrite size_belast -[(y == _) + _]/(count_mem _ (_ :: _)) [y :: s]lastI.
    rewrite -cats1 count_cat /= !addn0 addnCA [(_ == zc1) + _]addnC.
    rewrite -{3}[6]/(5 + 1) [_ + (5 + 1)]addnA [(_ + 1) * _]mulnDl ltn_add2l.
    by rewrite cats1 -lastI (leq_ltn_trans (index_size _ _)) ?size_rev ?mul1n.
  - (* zcback0 -> zcback0 *)
    rewrite size_belast -[(y == _) + _]/(count_mem _ (_ :: _)) [y :: s]lastI.
    rewrite -cats1 count_cat /= addn0 [(_ == zc1) + _]addnC ltn_add2l.
    rewrite -cats1 !rev_cat /=.
    case E: _ / inv => [|||||||||||s1 [|n]|n1 [|n2]||] //; case: E.
    + by rewrite lastI -cat1s catA cats1 => /rcons_inj [_ ->].
    + rewrite -rcons_nseq; case: s1 => [|x s1] /= [-> ->] /=.
      * rewrite last_rcons /= !rev_cons rev_rcons belast_rcons rev_cons.
        by rewrite -!cats1 -catA /= !index_cat; case: ifP.
      * rewrite last_cat belast_cat /= last_rcons belast_rcons /=.
        rewrite -/([:: _; _] ++ (zc1 :: nseq _ _)) catA.
        rewrite -/([:: _] ++ (zc1 :: rcons _ _)) catA.
        rewrite !rev_cat !index_cat !mem_rev !inE !eqxx !orTb.
        by rewrite -cats1 -cat_cons rev_cat.
    + by rewrite lastI cats1 => /rcons_inj [_ ->].
    + rewrite -rcons_nseq; case: n1 => [|n1] /= [-> ->].
      * rewrite last_rcons belast_rcons /= rev_rcons rev_cons /=.
        rewrite -cats1 index_cat addn0; case: ifP => //= _.
        move: (index_size zc1 (rev (nseq n2 zc0))); rewrite leq_eqVlt.
        by rewrite index_mem mem_rev mem_nseq andbF orbF => /eqP ->.
      * rewrite last_cat belast_cat /= last_rcons belast_rcons /=.
        rewrite -/([:: _] ++ (zc1 :: nseq _ _)) catA.
        rewrite -/(_ ++ (zc1 :: rcons _ _)).
        rewrite !rev_cat !index_cat !mem_rev !inE !eqxx !orTb.
        by rewrite -cats1 -cat_cons rev_cat.
  - (* zcback0 -> zcinit2 *)
    rewrite size_belast addn0 -[(y == _) + _]/(count_mem _ (y :: s)) lastI.
    rewrite -cats1 count_cat /= addn0 addnCA [(_ == zc1) + _]addnC.
    by rewrite (leq_trans _ (leq_addr _ _)) // ltn_mul2r ltn_add2l.
Qed.

Theorem zc_halts t : halts zc t.
Proof.
  have: zcinv (zc.(initial), t) by case: t; constructor.
  rewrite /halts; move: zc.(initial) => q.
  elim: zcweight {-2}q {-2}t (leqnn (zcweight (q, t))) => {q t} [|w IHw] q t.
  - move=> weight_le_0 /zcweight_decreasing.
    by case: zcweight weight_le_0 => // _; case E: step => // _; exists 1.
  - move=> zcw_le_w1 inv; move: (zcweight_decreasing inv).
    case E: step => [[q' t']|]; last by exists 1.
    move/zcinv_invariant: inv; rewrite E => inv.
    move/leq_trans/(_ zcw_le_w1); rewrite ltnS => /IHw/(_ inv) [n].
    by rewrite -E => <-; exists n.+1; rewrite iterSr.
Qed.

End ZeroClear.

End TPPmark2019.


Require Export XR_R.
Require Export XR_INR.
Require Export XR_Rplus_0_l.

Local Open Scope R_scope.

Lemma S_INR : forall n:nat, INR (S n) = INR n + R1.
Proof.
  intro n.
  destruct n as [ | n ].
  {
    simpl.
    rewrite Rplus_0_l.
    reflexivity.
  }
  {
    simpl.
    reflexivity.
  }
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)         *)
(************************************************************************)

Require Import Mult.
Require Import Compare_dec.
Require Import Wf_nat.

Local Open Scope nat_scope.

Implicit Types a b n q r : nat.

Inductive diveucl a b : Set :=
  divex : forall q r, b > r -> a = q * b + r -> diveucl a b.

Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n.
Proof.
  induction m as (m,H0) using gt_wf_rec.
  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
  destruct (H0 (m - n)) as (q,r,Hge0,Heq); auto with arith.
  apply divex with (S q) r; trivial.
  simpl; rewrite <- plus_assoc, <- Heq; auto with arith.
  apply divex with 0 m; simpl; trivial.
Defined.

Lemma quotient :
  forall n,
    n > 0 ->
    forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
Proof.
  induction m as (m,H0) using gt_wf_rec.
  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
  destruct (H0 (m - n)) as (q & Hq); auto with arith; exists (S q).
  destruct Hq as (r & Heq & Hgt); exists r; split; trivial.
  simpl; rewrite <- plus_assoc, <- Heq; auto with arith.
  exists 0; exists m; simpl; auto with arith.
Defined.

Lemma modulo :
  forall n,
    n > 0 ->
    forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
Proof.
  induction m as (m,H0) using gt_wf_rec.
  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
  destruct (H0 (m - n)) as (r & Hr); auto with arith; exists r.
  destruct Hr as (q & Heq & Hgt); exists (S q); split; trivial.
  simpl; rewrite <- plus_assoc, <- Heq; auto with arith.
  exists m; exists 0; simpl; auto with arith.
Defined.


(*************************************************************************)
(**                                                                      *)
(** * Typing: preservation and progress                                  *)
(**                                                                      *)
(*************************************************************************)

Require Import Coq.Strings.String.
Require Import Metalib.Metatheory.
Require Import Stlc.Definitions.
Import StlcNotations.

Require Import Stlc.Lemmas.

Require Import Stlc.Lec1.
(* Lemmas from Lec1 that are useful for today's homework: *)
Check subst_var.
Check typing_to_lc_exp.

(*************************************************************************)
(** * Typing contexts *)
(*************************************************************************)

(** We represent contexts as association lists (lists of pairs of
    keys and values) whose keys are [atom]s.   *)

(** For STLC, contexts bind [atom]s to [typ]s.  We define an
    abbreviation [ctx] for the type of these contexts.

    Lists are defined in Coq's standard library, with the constructors
    [nil] and [cons].  The list library includes the [::] notation
    for cons as well as standard list operations such as append, map,
    and fold. The infix operation "++" is list append.

    The Metatheory library extends this reasoning by instantiating the
    AssocList library to provide support for association lists whose
    keys are [atom]s.  Everything in this library is polymorphic over
    the type of objects bound in the context.  Look in AssocList
    for additional details about the functions and predicates that we
    mention below.  *)

(** Context equality *)

(** When reasoning about contexts, we often need to talk about
    bindings in the "middle" of a context. Therefore, it is common
    for lemmas and definitions to use list append in their statements.
    Unfortunately, list append is associative, so two Coq expressions may
    denote the same context even though they are not equal.

    The tactic [simpl_env] reassociates all concatenations of
    contexts to the right.  *)

Lemma append_assoc_demo : forall (E0 E1 E2 E3:ctx),
  E0 ++ (E1 ++ E2) ++ E3 = E0 ++ E1 ++ E2 ++ E3.
Proof.
  intros.
  auto. (* Does nothing. *)
  simpl_env.
  reflexivity.
Qed.

(** To make contexts easy to read, instead of building them from
    [nil] and [cons], we prefer to build them from the following
    components:
      - [nil]: The empty list.
      - [one]: Lists consisting of exactly one item.
      - [++]:  List append.
*)

(** The simpl_env tactic actually puts lists built from only nil, one
    and [++] into a "normal form". This process reassociates all appends
    to the right, removes extraneous nils and converts cons to singleton
    lists with an append.
*)

Lemma simpl_env_demo : forall (x y:atom) (T1 T2:typ) (E F:ctx),
   ([(x, T1)] ++ nil) ++ (y,T2) :: (nil ++ E) ++ F =
   [(x,T1)] ++ [(y, T2)] ++ E ++ F.
Proof.
   intros.
   (* simpl_env puts the left side into the normal form. *)
   simpl_env.
   reflexivity.
Qed.

(** Context operations. *)

(** The ternary predicate [binds] holds when a given binding is
    present somewhere in a context.
*)

Lemma binds_demo : forall (x:atom) (T:typ) (E F:ctx),
  binds x T (E ++ [(x, T)] ++ F).
Proof.
  auto.
Qed.

(** The function [dom] computes the domain of a context, returning a
    finite set of [atom]s. Note that we cannot use Coq's equality for
    finite sets, we must instead use a defined relation [=] for atom
    set equality.  *)

Lemma dom_demo : forall (x y : atom) (T : typ),
  dom [(x, T)] [=] singleton x.
Proof.
  auto.
Qed.

(** The unary predicate [uniq] holds when each atom is bound at most
    once in a context.
*)

Lemma uniq_demo : forall (x y : atom) (T : typ),
  x <> y -> uniq ([(x,T)] ++ [(y, T)]).
Proof.
  auto.
Qed.

(*************************************************************************)
(** * Typing relation and cofinite quantification *)
(*************************************************************************)

(** The typing relation in the STLC definition states the typing rule for
    abstractions in a particular way.

<<
typing_abs
     : forall (L : atoms) (G : ctx) (T1 : typ) (e : exp) (T2 : typ),
       (forall x : atom,
        x `notin` L -> typing ([(x, T1)] ++ G) (open e (var_f x)) T2) ->
       typing G (abs e) (typ_arrow T1 T2)
>>

   To show that abstractions are well-typed, we must show that the body
   of the abstraction is well-typed for any choice of variable, except
   those from some unspecified set `L`.

   This type of rule differs from the quantification in the
   [lc_abs] rule (which does not restrict the variables at all) or
   the [lc_abs_exists] version (which only applies for one particular
   variable. We call this version "co-finite" quantification.

   To see why this version is necessary, we will start with a more
   traditional version of the rules that only uses a single variable
   in the abs rule and then see what goes wrong.
   (We say that the [typing_e] judgement below uses "exists-fresh"
   quantification in the abs rule.)

*)

Inductive typing_e : ctx -> exp -> typ -> Prop :=
  | typing_e_var : forall E (x : atom) T,
      uniq E ->
      binds x T E ->
      typing_e E (var_f x) T
  | typing_e_abs : forall x E e T1 T2,
      x `notin` dom E \u fv_exp e ->
      typing_e ([(x, T1)] ++ E) (e ^ x) T2 ->
      typing_e E (abs e) (typ_arrow T1 T2)
  | typing_e_app : forall E e1 e2 T1 T2,
      typing_e E e1 (typ_arrow T1 T2) ->
      typing_e E e2 T1 ->
      typing_e E (app e1 e2) T2.
Hint Constructors typing_e.

(*************************************************************************)
(** ** Weakening  *)
(*************************************************************************)

(** Weakening states that if an expression is typeable in some
    context, then it is typeable in any well-formed extension of
    that context.  This property is needed to prove the
    substitution lemma.

    As stated below, this lemma is not directly proveable.  The
    natural way to try proving this lemma proceeds by induction on the
    typing derivation for [e].
*)

Lemma typing_weakening_0 : forall E F e T,
  typing_e E e T ->
  uniq (F ++ E) ->
  typing_e (F ++ E) e T.
Proof.
  intros E F e T H J.
  induction H; auto.
  - Case "typing_abs".
    apply (typing_e_abs x).
    (* ... stuck here ... *)
Abort.

(** We are stuck in the [typing_abs] case because the induction
    hypothesis [IHtyping_e] applies only when we weaken the context at its
    head.  In this case, however, we need to weaken the context in
    the middle; compare the conclusion at the point where we're stuck
    to the hypothesis [H], which comes from the given typing derivation.

    We can obtain a more useful induction hypothesis by changing the
    statement to insert new bindings into the middle of the
    context, instead of at the head.  However, the proof still
    gets stuck, as can be seen by examining each of the cases in
    the proof below.

    Note: To view subgoal n in a proof, use the command "[Show n]".
    To work on subgoal n instead of the first one, use the command
    "[Focus n]".
*)

Lemma typing_weakening_strengthened_0 : forall (E F G : ctx) e T,
  typing_e (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing_e (G ++ F ++ E) e T.
Proof.
  intros E F G e T H J.
  induction H.
  Case "typing_var".
    (* The G0 looks strange in the [typing_var] case. *)
  Focus 2.
  Case "typing_abs".
    (* The [typing_abs] case still does not have a strong enough IH. *)
Abort.

(** The hypotheses in the [typing_var] case include a context
    [G0] that that has no relation to what we need to prove.  The
    missing fact we need is that [G0 = (G ++ E)].

    The problem here arises from the fact that Coq's [induction]
    tactic lets us only prove something about all typing derivations.
    While it's clear to us that weakening applies to all typing
    derivations, it's not clear to Coq, because the context is
    written using concatenation.  The [induction] tactic expects that
    all arguments to a judgement are variables.  So we see [E0] in the
    proof instead of [(G ++ E)].

    The solution is to restate the lemma.  For example, we can prove

<<
  forall E F E' e T, typing E' e T ->
  forall G, E' = G ++ E -> uniq (G ++ F ++ E) -> typing (G ++ F ++ E) e T.
>>

    The equality gets around the problem with Coq's [induction]
    tactic.  The placement of the [(forall G)] quantifier gives us a
    sufficiently strong induction hypothesis in the [typing_abs] case.

    However, we prefer not to state the lemma in the way shown above,
    since it is not as readable as the original statement.  Instead,
    we use a tactic to introduce the equality within the proof itself.
    The tactic [(remember t as t')] replaces an object [t] with the
    identifier [t'] everywhere in the goal and introduces an equality
    [t' = t] into the context.  It is often combined with [generalize
    dependent], as illustrated below.
*)

Lemma typing_weakening_strengthened_1 :  forall (E F G : ctx) e T,
  typing_e (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing_e (G ++ F ++ E) e T.
Proof.
  intros E F G e T H.
  remember (G ++ E) as E'.
  generalize dependent G.
  induction H; intros G0 Eq Uniq; subst.
  - Case "typing_var". auto.
  - Case "typing_abs".
    eapply (typing_e_abs x).
    (* STILL STUCK! *)
Abort.

Print typing_abs.

(** At this point, we are very close. However, there is still one issue. We
    cannot show that [x] is fresh for the weakened context [F].

    This is the difficulty with the definition of [typing_e]. As in the local
    closure judgement, the induction hypotheses is not strong enough in the
    [abs] case.

    However, this time, we take a slightly different solution, with the
    cofinite quantification of the [typing_abs] rule.

<<
| typing_abs :
    forall (L : atoms) (G : ctx) (T1 : typ) (e : exp) (T2 : typ),
    (forall x, x `notin` L -> typing ([(x, T1)] ++ G) (e ^ x) T2) ->
    typing (abs e) (typ_arrow T1 T2) >>
>>

   The advantage of this definition is that it is easier to derive
   the "exists-fresh" version of the rule
   [typing_e_abs] as a lemma, than the version we used in [lc_exp].
   (See below, we prove this lemma after we show substitution.) At the same
   time, this version of the rule is sufficiently expressive to complete
   the proof of weakening.

*)

(** *** Exercise [typing_weakening_strengthened]

    Complete the proof below, using the [typing] relation from [Definitions.v].

    HINTS:

       - The [typing_var] case follows from [binds_weaken], the
         weakening lemma for the [binds] relation.

       - The [typing_abs] case follows from the induction
         hypothesis, but the [apply] tactic may be unable to unify
         things as you might expect.

           -- You'll need to specify the set to avoid with
              (L := dom (G0 ++ F ++ E) \u L)).

           -- In order to apply the induction hypothesis, use
              [rewrite_env] to reassociate the list operations.

           -- After applying the induction hypothesis, use
              [simpl_env] to use [uniq_push].

           -- Here, use [auto] to solve facts about finite sets of
              atoms, since it will simplify the [dom] function behind
              the scenes.  [fsetdec] does not work with the [dom]
              function.

       - The [typing_app] case follows directly from the induction
         hypotheses.
  *)

Lemma typing_weakening_strengthened :  forall (E F G : ctx) e T,
  typing (G ++ E) e T ->
  uniq (G ++ F ++ E) ->
  typing (G ++ F ++ E) e T.
Proof.
  intros E F G e T H.
  remember (G ++ E) as E'.
  generalize dependent G.
  induction H; intros G0 Eq Uniq; subst.
 (* FILL IN HERE *)
 Admitted.

(** *** Demo [typing_weakening]

    We can now prove our original statement of weakening.  The only
    interesting step is the use of the rewrite_env tactic.
*)

Lemma typing_weakening : forall (E F : ctx) e T,
    typing E e T ->
    uniq (F ++ E) ->
    typing (F ++ E) e T.
Proof.
  intros E F e T H J.
  rewrite_env (nil ++ F ++ E).
  apply typing_weakening_strengthened; auto.
Qed.

(*************************************************************************)
(** ** Substitution *)
(*************************************************************************)

(** Having proved weakening, we can now prove the usual substitution
    lemma, which we state both in the form we need and in the
    strengthened form needed to make the proof go through.

<<
  typing_subst_simple : forall E e u S T z,
    typing ([(z,S)] ++ E) e T ->
    typing E u S ->
    typing E ([z ~> u] e) T

  typing_subst : forall E F e u S T z,
    typing (F ++ [(z,S)] ++ E) e T ->
    typing E u S ->
    typing (F ++ E) ([z ~> u] e) T
>>

    The proof of the strengthened statement proceeds by induction on
    the given typing derivation for [e].  The most involved case is
    the one for variables; the others follow from the induction
    hypotheses.
*)

(** *** Exercise [typing_subst_var_case]

    Below, we state what needs to be proved in the [typing_var] case
    of the substitution lemma.  Fill in the proof.

    Proof sketch: The proof proceeds by a case analysis on [(x == z)],
    i.e., whether the two variables are the same or not.

      - If [(x = z)], then we need to show [(typing (F ++ E) u T)].
        This follows from the given typing derivation for [u] by
        weakening and the fact that [T] must equal [S].

      - If [(x <> z)], then we need to show [(typing (F ++ E) x T)].
        This follows by the typing rule for variables.

    HINTS: Lemmas [binds_mid_eq], [uniq_remove_mid],
    and [binds_remove_mid] are useful.

  *)

Lemma typing_subst_var_case : forall (E F : ctx) u S T (z x : atom),
  binds x T (F ++ [(z,S)] ++ E) ->
  uniq (F ++ [(z,S)] ++ E) ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] (var_f x)) T.
Proof.
  intros E F u S T z x H J K.
  simpl.
 (* FILL IN HERE *) Admitted.

(** *** Exercise [typing_subst]

    Complete the proof of the substitution lemma. The proof proceeds
    by induction on the typing derivation for [e].  The initial steps
    should use [remember as] and [generalize dependent] in a manner
    similar to the proof of weakening.

   HINTS:
      - Use the lemma proved above for the [typing_var] case.

      - The [typing_abs] case follows from the induction hypothesis.
          -- Use [simpl] to simplify the substitution.

          -- In order to use the induction hypothesis, use [subst_var]
             to push the substitution under the opening operation.

          -- Recall the lemma [typing_to_lc_exp] and the [rewrite_env]
             and [simpl_env] tactics.

      - The [typing_app] case follows from the induction hypotheses.
        Use [simpl] to simplify the substitution.
*)

Lemma typing_subst : forall (E F : ctx) e u S T (z : atom),
  typing (F ++ [(z,S)] ++ E) e T ->
  typing E u S ->
  typing (F ++ E) ([z ~> u] e) T.
Proof.
(* FILL IN HERE *) Admitted.

(** *** Exercise [typing_subst_simpl]

    Complete the proof of the substitution lemma stated in the form we
    need it.  The proof is similar to that of [typing_weakening].

    HINT: You'll need to use [rewrite_env] to prepend [nil],
    and [simpl_env] to simplify nil away.
*)

Lemma typing_subst_simple : forall (E : ctx) e u S T (z : atom),
  typing ([(z,S)] ++ E) e T ->
  typing E u S ->
  typing E ([z ~> u] e) T.
Proof.
(* FILL IN HERE *) Admitted.

(*************************************************************************)
(** * Type soundness *)
(*************************************************************************)

(*************************************************************************)
(** ** Preservation *)
(*************************************************************************)

(** *** Recommended Exercise [preservation]

    Complete the proof of preservation.  In this proof, we proceed by
    induction on the given typing derivation.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.

    Proof sketch: By induction on the typing derivation for [e].

      - [typing_var] case: Variables don't step.

      - [typing_abs] case: Abstractions don't step.

      - [typing_app] case: By case analysis on how [e] steps. The
        [step_beta] case is interesting, since it follows by the
        substitution lemma.  The others follow directly from the
        induction hypotheses.
*)

  (* HINTS:

       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.

       - Use [inversion] to perform case analyses and to rule out
         impossible cases.

       - In the [step_beta] subcase of the [typing_app] case:

          -- Use [inversion] on a typing judgement to obtain a
             hypothesis about when the body of the abstraction is
             well-typed.

          -- Use [subst_exp_intro] to rewrite the [open] operation
             into an [open] followed by a [subst].  You'll need to
             pick a fresh variable first using the
             [pick fresh x for S] tactic.

  *)

Lemma preservation : forall (E : ctx) e e' T,
  typing E e T ->
  step e e' ->
  typing E e' T.
Proof.
  intros E e e' T H.
  generalize dependent e'.
  induction H; intros e' J.
(* FILL IN HERE *) Admitted.

(*************************************************************************)
(** ** Progress *)
(*************************************************************************)

(** *** Exercise [progress]

    Complete the proof of the progress lemma.  The induction
    hypothesis has already been appropriately generalized by the given
    proof fragment.

    Proof sketch: By induction on the typing derivation for [e].

      - [typing_var] case: Can't happen; the empty context doesn't
        bind anything.

      - [typing_abs] case: Abstractions are values.

      - [typing_app] case: Applications reduce.  The result follows
        from an exhaustive case analysis on whether the two components
        of the application step or are values and the fact that a
        value must be an abstraction.
*)

  (* HINTS:

       - Use [auto] and [eauto], especially with [;], to solve
         "uninteresting" subgoals.

       - Use [inversion] to rule out impossible cases.

       - The lemma [typing_to_lc_exp] will be useful for reasoning
         about local closure.

       - In the [typing_app] case:

          -- Use [destruct] to perform a case analysis on the
             conclusions of the induction hypotheses.

          -- Use [inversion] on a [value] judgement to determine that
             the value must be an abstraction.
  *)

Lemma progress : forall e T,
  typing nil e T ->
  is_value e \/ exists e', step e e'.
Proof.
  intros e T H.

  (* It will be useful to have a "non-destructed" form of the given
     typing derivation, since [induction] takes apart the derivation
     it is called on. *)
  assert (typing nil e T); auto.

  (* [remember nil as E] fails here because [nil] takes an implicit
     argument that Coq is unable to infer.  By prefixing [nil] with
     [@], we can supply the argument to nil explicitly. *)
  remember (@nil (atom * typ)) as E.

  induction H; subst.

(* FILL IN HERE *) Admitted.

(*************************************************************************)
(** * Tactic support *)
(*************************************************************************)

(** When picking a fresh var or applying a rule that uses cofinite
    quantification, choosing a set of vars to be fresh for can be
    tedious.  In practice, it is simpler to use a tactic to choose the
    set to be as large as possible.

    The tactic [gather_atoms] is used to collect together all the
    atoms in the context.  It relies on an auxiliary tactic,
    [gather_atoms_with] (from MetatheoryAtom), which maps a function
    that returns a finite set of atoms over all hypotheses with the
    appropriate type.
*)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  constr:(A `union` B `union` C `union` D).

(** A number of other, useful tactics are defined by the Metatheory
    library, and each depends on [gather_atoms].  By redefining
    [gather_atoms], denoted by the [::=] in its definition below, we
    automatically update these tactics so that they use the proper
    notion of "all atoms in the context."

    For example, the tactic [(pick fresh x)] chooses an atom fresh for
    "everything" in the context.  It is the same as [(pick fresh x for
    L)], except where [L] has been computed by [gather_atoms].

*)

(*************************************************************************)
(** * Renaming *)
(*************************************************************************)

(** Substitution and weakening together give us a property we call
   renaming: (see [typing_rename below] that we can change the name
   of the variable used to open an expression in a typing
   derivation. In practice, this means that if a variable is not
   "fresh enough" during a proof, we can use this lemma to rename it
   to one with additional freshness constraints.

   Renaming is used below to show the correspondence between the
   exists-fresh version of the rules with the cofinite version, and
   also to show that typechecking is decidable.
*)

(** However, before we prove renaming, we need an auxiliary lemma about
    typing judgments which says that terms are well-typed only in
    unique contexts.
*)

Lemma typing_uniq : forall E e T,
  typing E e T -> uniq E.
Proof.
  intros E e T H.
  induction H; auto.
  - Case "typing_abs".
    pick fresh x.
    assert (uniq ([(x, T1)] ++ G)); auto.
    solve_uniq.
Qed.

(** Demo: the proof of renaming.

   Note that this proof does not proceed by induction: even if we add
   new typing rules to the language, as long as the weakening and
   substution properties hold we can use this proof.
*)
Lemma typing_rename : forall (x y : atom) E e T1 T2,
  x `notin` fv_exp e ->
  y `notin` dom E ->
  typing ([(x, T1)] ++ E) (e ^ x) T2 ->
  typing ([(y, T1)] ++ E) (e ^ y) T2.
Proof.
  intros x y E e T1 T2 Fr1 Fr2 H.
  destruct (x == y).
  - Case "x = y".
    subst; eauto.
  - Case "x <> y".
    assert (J : uniq ([(x, T1)] ++ E)).
      eapply typing_uniq; eauto.
    assert (J' : uniq E).
      inversion J; eauto.
    rewrite (@subst_exp_intro x); eauto.
    rewrite_env (nil ++ [(y, T1)] ++ E).
    apply typing_subst with (S := T1).
    simpl_env.
    + SCase "(open x s) is well-typed".
      apply typing_weakening_strengthened. eauto. auto.
    + SCase "y is well-typed".
      eapply typing_var; eauto.
Qed.

(*************************************************************************)
(** ** Exists-Fresh Definition *)
(*************************************************************************)

(** The use of cofinite quantification may make some people worry that we
    are not formalizing the "right" language. Below, we show that
    the "exists-fresh" version of the rules is the same as the cofinite
    version. *)

Lemma typing_abs_exists : forall E e T1 T2 (x : atom),
      x `notin` dom E \u fv_exp e ->
      typing ([(x,T1)] ++ E) (e ^ x) T2 ->
      typing E (abs e) (typ_arrow T1 T2).
Proof.
  intros.
  apply typing_abs with (L := dom E \u fv_exp e).
  intros y Fr.
  apply typing_rename with (x:=x); auto.
Qed.

(** *** Exercise [exists_cofinite] *)

Lemma exists_cofinite : forall E e T,
    typing_e E e T -> typing E e T.
Proof.
  (* FILL IN HERE *) Admitted.

(** *** Exercise [cofinite_exists] *)

Lemma cofinite_exists : forall G e T,
    typing G e T -> typing_e G e T.
Proof. (* FILL IN HERE *) Admitted.

(***********************************************************************)
(** ** Additional Exercises                                            *)
(***********************************************************************)

(** *** Challenge Exercise [fv_in_dom]

   We also want a property that states that the free variables of well-typed
   terms are contained within the domain of their typing contexts.

 *)
Lemma fv_in_dom : forall G e T,
    typing G e T -> fv_exp e [<=] dom G.
Proof.
  (* FILL IN HERE *) Admitted.


Add LoadPath "." as OPAT.
Require Import OPAT.doit3 OPAT.aula3 OPAT.aula9 OPAT.aula10 OPAT.aula11 OPAT.doit9.

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b  ->
     beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H.  Qed.

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
  true = beq_nat n 5  ->
  true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.  Qed.

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  - (* n = O *) simpl. intros eq. destruct m as [| m'].
    + (* m = O *) reflexivity.
    + (* m = S m' *) inversion eq.
  - (* n = S n' *) intros eq. destruct m as [| m'].
    + (* m = O *) inversion eq.
    + (* m = S m' *) apply f_equal.
      Abort.

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  - (* n = O *) simpl. intros m eq. destruct m as [| m'].
    + (* m = O *) reflexivity.
    + (* m = S m' *) inversion eq.
  - (* n = S n' *) simpl.
    intros m eq.
    destruct m as [| m'].
    + (* m = O *) simpl.
      inversion eq.
    + (* m = S m' *)
      apply f_equal.
      apply IHn'. inversion eq. reflexivity. Qed.

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  - (* m = O *) simpl. intros eq. destruct n as [| n'].
    + (* n = O *) reflexivity.
    + (* n = S n' *) inversion eq.
  - (* m = S m' *) intros eq. destruct n as [| n'].
    + (* n = O *) inversion eq.
    + (* n = S n' *) apply f_equal.
Abort.

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'].
    + (* n = O *) reflexivity.
    + (* n = S n' *) inversion eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'].
    + (* n = O *) inversion eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. inversion eq. reflexivity.
Qed.

Definition square n := n * n.

Lemma mult_comm : forall n m,
    n * m = m * n.
Proof.
    Admitted.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl.
  unfold square.
  rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
  { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity.
Qed.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    - (* beq_nat n 3 = true *) reflexivity.
    - (* beq_nat n 3 = false *) destruct (beq_nat n 5).
      + (* beq_nat n 5 = true *) reflexivity.
      + (* beq_nat n 5 = false *) reflexivity.
      Qed.

Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3).
  (* stuck... *)
Abort.


Require Import Lia List PeanoNat Permutation.
Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

(* induction principle wrt. a decreasing measure f *)
(* example: elim /(measure_ind length) : l. *)
Lemma measure_ind {X : Type} (f : X -> nat) (P : X -> Prop) :
  (forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  apply : well_founded_ind.
  apply : Wf_nat.well_founded_lt_compat. move => *. by eassumption.
Qed.
Arguments measure_ind {X}.

Lemma prod_nat_nat_eq_dec (x y : nat * nat) : {x = y} + {x <> y}.
Proof. by do ? decide equality. Qed.

Lemma eq_or_inf {X: Type} : (forall (x y: X), {x = y} + {x <> y}) ->
  forall (x y: X) P, (x = y) \/ P -> (x = y) + P.
Proof.
  move=> H x y P. case: (H x y).
  - move=> ??. by left.
  - move=> ??. right. tauto.
Qed.

Lemma iter_plus {X} (f : X -> X) (x : X) n m : Nat.iter (n + m) f x = Nat.iter m f (Nat.iter n f x).
Proof.
  elim: m; first by rewrite Nat.add_0_r.
  move=> m /= <-. by have ->: n + S m = S n + m by lia.
Qed.

Lemma Exists_sig {X : Type} P (HP : (forall x, {P x} + {~ P x})) (L : list X) :
  Exists P L -> { x | In x L /\ P x}.
Proof.
  elim: L. { by move=> /Exists_nil. }
  move=> x L IH /Exists_cons H.
  have [/IH|?] := Exists_dec P L HP.
  - move=> [y [? ?]]. exists y. by split; [right|].
  - exists x. by split; [left|tauto].
Qed.

Lemma list_sum_map_le {X: Type} f g (L: list X) :
  (forall x, f x <= g x) ->
  list_sum (map f L) <= list_sum (map g L).
Proof.
  move=> Hfg. elim: L; first done.
  move=> x L IH /=. have := Hfg x. lia.
Qed.

Lemma list_sum_map_lt {X: Type} {f g} {L: list X} {x} :
  (forall x, f x <= g x) ->
  In x L -> f x < g x ->
  list_sum (map f L) < list_sum (map g L).
Proof.
  move=> Hfg + H'fg. elim: L; first done.
  move=> y L IH /= [->|].
  - have := list_sum_map_le f g L Hfg. lia.
  - move=> /IH. have := Hfg y. lia.
Qed.

Lemma oiter_None {X : Type} (f : X -> option X) k : Nat.iter k (obind f) None = None.
Proof. elim: k; [done | by move=> /= ? ->]. Qed.

Lemma obind_oiter {X : Type} (f : X -> option X) k x :
  obind f (Nat.iter k (obind f) (Some x)) = Nat.iter k (obind f) (f x).
Proof. elim: k; [done|by move=> k /= ->]. Qed.

Lemma NoDup_map_ext {X Y : Type} (f : X -> Y) (l : list X) :
  (forall x1, In x1 l -> forall x2, In x2 l -> f x1 = f x2 -> x1 = x2) -> NoDup l -> NoDup (map f l).
Proof.
  elim: l. { move=> *. by constructor. }
  move=> x l IH /= H /NoDup_cons_iff [Hxl] /IH {}IH. constructor.
  - move=> /in_map_iff [x'] [/H] ? Hx'l. have ? : x' = x by tauto.
    subst x'. exact: (Hxl Hx'l).
  - apply: IH. move=> x1 Hx1l x2 Hx2l /H. tauto.
Qed.

Lemma nth_error_seq {i start len} :
  i < len -> nth_error (seq start len) i = Some (start + i).
Proof.
  elim: len i start; first by lia.
  move=> len IH [|i] start.
  { move=> ?. congr Some. lia. }
  move=> ?. rewrite /= IH; first by lia.
  congr Some. lia.
Qed.

(* variant of the pigeonhole principle *)
Lemma pigeonhole {X : Type} (L L' : list X) :
  incl L L' -> length L' < length L -> not (NoDup L).
Proof.
  move=> ?? HL. suff: length L = length L' by lia.
  apply /Permutation_length /NoDup_Permutation_bis; by [|lia].
Qed.

Section DiscreteList.

Context {X : Type} (X_eq_dec : forall (x y : X), {x = y} + {x <> y}).

Lemma not_NoDup_consE {x} {l: list X} : (not (NoDup (x :: l))) -> In x l \/ not (NoDup l).
Proof using X_eq_dec.
  have [?|?] := In_dec X_eq_dec x l.
  { move=> ?. by left. }
  move=> Hxl. right => Hl. apply: Hxl.
  by constructor.
Qed.

Lemma not_NoDupE {l : list X} : not (NoDup l) ->
  exists '(i, j), i < j < length l /\ nth_error l i = nth_error l j.
Proof using X_eq_dec.
  elim: l. { move=> H. exfalso. apply: H. by constructor. }
  move=> x l IH.
  move=> /not_NoDup_consE [|].
  - move=> /(@In_nth_error X) [j] Hj.
    have ? : not (length l <= j).
    { move=> /nth_error_None. by rewrite Hj. }
    exists (0, S j) => /=. split; [lia|done].
  - move=> /IH [[i j]] [? ?].
    exists (S i, S j) => /=. split; [lia|done].
Qed.

Lemma not_inclE (L L' : list X) : (not (incl L L')) -> { x | In x L /\ not (In x L')}.
Proof using X_eq_dec.
  elim: L. { move=> H. exfalso. by apply: H. }
  move=> x L IH /=.
  have [|?] := In_dec X_eq_dec x L'.
  - move=> ? HxLL'. have /IH [y [? ?]] : ~ incl L L'.
    { move=> H. apply: HxLL'. by move=> y /= [<-|/H]. }
    exists y. tauto.
  - move=> _. exists x. tauto.
Qed.

(* explicit duplicates in a mapped sequence *)
Lemma dup_seq (f : nat -> X) start len :
  not (NoDup (map f (seq start len))) ->
  exists '(i, j), f i = f j /\ (start <= i /\ i < j /\ j < start+len).
Proof using X_eq_dec.
  move=> /not_NoDupE [[i j]]. rewrite map_length seq_length.
  move=> [? H]. exists (start+i, start+j). split; last lia.
  move: H. rewrite ?nth_error_map ?nth_error_seq; [lia|lia|].
  by move=> [].
Qed.

End DiscreteList.


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

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

Compute (next_weekday friday).
(* ==> monday : day *)
Compute (next_weekday (next_weekday saturday)).
(* ==> tuesday : day *)

Example test_next_weekday_ok:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.

Example test_next_weekday_error:
  (next_weekday (next_weekday saturday)) = thursday.
Proof. simpl. reflexivity. Qed.


(**  **)

(*** showcase: showcase of feature of the translation ***)
From MetaCoq.Translations Require Import param_all.
Unset Strict Unquote Universe Mode.

MetaCoq Run Derive Translations for nat.
(** Derived natᵗ=natᴬᴬ, natᴬᴱ, natᴱᴬ, and natᴱ=natᴱᴱ. **)
Print natᵗ. (** natᴬᴬ **) (** True **)
Print natᴬᴱ. (** True **)
Print natᴱᴬ. (** False **)
Print natᴱ. (** natᴱᴱ **) (** False **)
(**
Inductive natᵗ : nat -> Set :=
	Oᵗ : natᵗ 0 | Sᵗ : forall H : nat, natᵗ H -> natᵗ (S H)

natᴬᴱ = fun _ : nat => True
	 : nat -> Prop

natᴱᴬ = fun _ : nat => False
	 : nat -> Prop

Inductive natᴱ : nat -> Set :=  Sᴱ0 : forall H : nat, natᴱ H -> natᴱ (S H)
**)

MetaCoq Run Derive Translations for list.
(** Derived listᵗ=listᴬᴬ, listᴬᴱ, listᴱᴬ, and listᴱ=listᴱᴱ. **)
Print listᵗ. (** listᴬᴬ **) (** for all a:A holds A^t **)
Print listᴬᴱ. (** =listEE **)
Print listᴱᴬ. (** =liftAA **)
Print listᴱ. (** listᴱᴱ **) (** at least one element fulfills the predicate **)
(**
Inductive listᵗ (A : Type) (Aᵗ : A -> Type) : list A -> Type :=
	nilᵗ : listᵗ A Aᵗ nil
  | consᵗ : forall H : A,
            Aᵗ H -> forall H0 : list A, listᵗ A Aᵗ H0 -> listᵗ A Aᵗ (H :: H0)

listᴬᴱ =
fun (A : Type) (Aᴱ : A -> Type) (H : list A) => listᴱ A Aᴱ H
	 : forall A : Type, (A -> Type) -> list A -> Type

listᴱᴬ =
fun (A : Type) (Aᴱ : A -> Type) (H : list A) => listᵗ A Aᴱ H
	 : forall A : Type, (A -> Type) -> list A -> Type

Inductive listᴱ (A : Type) (Aᴱ : A -> Type) : list A -> Type :=
	consᴱ0 : forall (H : A) (H0 : list A), Aᴱ H -> listᴱ A Aᴱ (H :: H0)
  | consᴱ1 : forall (H : A) (H0 : list A),
             listᴱ A Aᴱ H0 -> listᴱ A Aᴱ (H :: H0)
**)

Print HintDb existtranslated.

Open Scope type.
Definition iffT (A:Type) (B:Type) := (A->B) * (B->A).
Notation "A <-> B" := (iffT A B) : type_scope.

Inductive In {X} (x:X) : list X -> Type :=
| inB xs: In x (x::xs)
| inS y xs: In x xs -> In x (y::xs).

(** exists <-> one element in the list exists satifying P **)
Goal forall (X:Type) (P:X->Type) (xs:list X), listᴱᴱ X P xs <-> {x & In x xs * P x}.
Proof.
    split;intros H.
    - induction H as [|? ? ? (?&?&?)].
      + exists a;split;[apply inB|assumption].
      + exists x;split;[now apply inS|assumption].
    - destruct H as (?&H&?). induction H.
      + constructor 1;assumption.
      + now constructor 2.
Qed.

(** forall <-> all elements in the list fulfill P **)
Goal forall (X:Type) (P:X->Type) (xs:list X), listᴬᴬ X P xs <-> forall x, In x xs -> P x.
Proof.
    split;intros H.
    - induction H as [|? ? ? ? IH];[easy|].
      intros x G. inversion G;subst;[assumption|].
      now apply IH.
    - induction xs.
      + constructor.
      + constructor.
        * apply H; constructor.
        * now apply IHxs;intros;apply H;constructor.
Qed.

MetaCoq Run Derive Translations for prod.
(** Derived prodᵗ=prodᴬᴬ, prodᴬᴱ, prodᴱᴬ, and prodᴱ=prodᴱᴱ. **)
Print prodᵗ. (** prodᴬᴬ **) (** each element fullfills its predicate **)
Print prodᴬᴱ.
Print prodᴱᴬ.
Print prodᴱ. (** prodᴱᴱ **) (** one of the elements fulfills its predicate **)
(**
Inductive
prodᵗ (A : Type) (Aᵗ : A -> Type) (B : Type) (Bᵗ : B -> Type)
  : A * B -> Type :=
	pairᵗ : forall H : A,
            Aᵗ H -> forall H0 : B, Bᵗ H0 -> prodᵗ A Aᵗ B Bᵗ (H, H0)

prodᴬᴱ =
fun (A : Type) (Aᴱ : A -> Type) (B : Type) (Bᴱ : B -> Type) (H : A * B) =>
(prodᴱ A Aᴱ B (fun _ : B => False) H * prodᴱ A (fun _ : A => False) B Bᴱ H)%type
	 : forall A : Type,
       (A -> Type) -> forall B : Type, (B -> Type) -> A * B -> Type

prodᴱᴬ =
fun (A : Type) (Aᴱ : A -> Type) (B : Type) (Bᴱ : B -> Type) (H : A * B) =>
(prodᵗ A Aᴱ B (fun _ : B => True) H + prodᵗ A (fun _ : A => True) B Bᴱ H)%type
	 : forall A : Type,
       (A -> Type) -> forall B : Type, (B -> Type) -> A * B -> Type

Inductive
prodᴱ (A : Type) (Aᴱ : A -> Type) (B : Type) (Bᴱ : B -> Type)
  : A * B -> Type :=
	pairᴱ0 : forall (H : A) (H0 : B), Aᴱ H -> prodᴱ A Aᴱ B Bᴱ (H, H0)
  | pairᴱ1 : forall (H : A) (H0 : B), Bᴱ H0 -> prodᴱ A Aᴱ B Bᴱ (H, H0)
**)

Goal forall X Y Px Py x y, prodᴬᴬ X Px Y Py (x,y) <-> (Px x * Py y).
Proof.
    split;inversion_clear 1.
    - split;assumption.
    - constructor;assumption.
Qed.

Goal forall X Y Px Py x y, prodᴱᴱ X Px Y Py (x,y) <-> (Px x + Py y).
Proof.
    split;inversion_clear 1.
    - now left.
    - now right.
    - now constructor 1.
    - now constructor 2.
Qed.

Inductive List (X:Set) : Set := Nil | Cons (x:X) (xs:List X).
MetaCoq Run Derive ∃∃ for List.
Inductive rose (X:Type) : Set := tree (h:List (rose X)).
MetaCoq Run Derive ∃∃ for rose.
Print roseᴱ.
(**
Inductive roseᴱ (X : Type) (Xᴱ : X -> Type) : rose X -> Set :=
	treeᴱ0 : forall h : List (rose X),
             Listᴱ (rose X) (roseᴱ X Xᴱ) h -> roseᴱ X Xᴱ (tree X h)
**)

(** more tests for the new ∃∃ in param_exists_test.v **)


(** A library of Bellantoni-Cook functions on bitstrings without numerical interpretation *)

Require Import Bool Arith Even List.
Require Import BellantoniCook.Lib BellantoniCook.Bitstring BellantoniCook.BC.

(** * Swapping of two arguments

  - arities: (2, 0)
*)

Definition inv_e (e : BC) : BC :=
  comp 2 0 e (proj 2 0 1 :: proj 2 0 0 :: nil) nil.

(** * Conversion from arities (1, 1) to (2, 0) *)

Definition from_11_to_20 (e : BC) : BC :=
  comp 2 0 e (proj 2 0 0 :: nil) (proj 2 0 1 :: nil).

Lemma from_11_to_20_correct e v1 v2 :
  sem e [v1] [v2] = sem (from_11_to_20 e) [v1 ; v2] nil.
Proof.
 intros; simpl; trivial.
Qed.

(** * Concatenation of bitstrings

  - arities: (1, 1)
*)

Definition app_e : BC :=
  rec (proj 0 1 0)
      (comp 1 2 (succ false) nil ((proj 1 2 1) :: nil))
      (comp 1 2 (succ true) nil ((proj 1 2 1) :: nil)).

Lemma app_correct v1 v2 :
  sem app_e [v1] [v2] = v1 ++ v2.
Proof.
 induction v1; simpl in *; trivial.
 intros; rewrite IHv1.
 case a; trivial.
Qed.

(** * constant function *)

Program Fixpoint constant (v:bs) : { e : BC | arities e = ok_arities 0 0 /\ sem e nil nil = v } :=
  match v with
  | nil => BC.zero
  | b :: v' => BC.comp 0 0 (BC.succ b) nil [constant v']
  end.

Next Obligation.
simpl.
tauto.
Qed.

Next Obligation.
simpl.
intros bs_to_BC v b v' Hv.
subst v.
destruct (bs_to_BC v') as [e [H1 H2] ].
simpl.
rewrite H1, H2.
tauto.
Defined.

(** * Recursion on the length of a bitstring, i.e., ignoring the value 0 or 1 of bits *)

Definition rec2 g h := rec g h h.

Lemma rec2_correct v1 v2 g h0 h1 :
  unary (hd nil v1) = true ->
  sem (rec g h0 h1) v1 v2 = sem (rec2 g h1) v1 v2.
Proof.
 intros; simpl; revert H.
 induction (hd nil v1); simpl; trivial; intros.
 rewrite andb_true_iff in H.
 decompose [and] H; clear H.
 destruct a.
 rewrite IHl; trivial; tauto.
 unfold id in H0; discriminate.
Qed.

Lemma rec2_simpl g h i z l1 l2 :
  sem (rec2 g h) ((i :: z) :: l1) l2 = sem h (z :: l1) (sem_rec (sem g) (sem h) (sem h) z l1 l2 :: l2).
Proof. intros; simpl; case i; trivial. Qed.

Lemma rec2_sem_rec g h z l1 l2 :
  sem (rec2 g h) (z :: l1) l2 = sem_rec (sem g) (sem h) (sem h) z l1 l2.
Proof.  intros; simpl; trivial. Qed.

Definition cond2 n s x g h0 h1 : BC :=
  comp n s
    cond nil [
      x;
      g;
      comp n s h0
        (map (proj n 0) (seq 0 n))
        (comp n s pred nil [x] :: map (proj n s) (seq n s));
      comp n s h1
        (map (proj n 0) (seq 0 n))
        (comp n s pred nil [x] :: map (proj n s) (seq n s))
    ].

Lemma arities_cond2 n s x g h0 h1
  (Hx : arities x = ok_arities n s)
  (Hg : arities g = ok_arities n s)
  (Hh0 : arities h0 = ok_arities n (S s))
  (Hh1 : arities h1 = ok_arities n (S s)) :
  arities (cond2 n s x g h0 h1) = ok_arities n s.
Proof.
simpl.
rewrite Hx, Hg, Hh0, Hh1.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
do 2 rewrite map_length, seq_length.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H1
end.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H2
end.
simpl.
do 2 rewrite <- beq_nat_refl.
reflexivity.
rewrite forallb_forall_conv in H2.
destruct H2 as [e [H2 H3] ].
rewrite in_map_iff in H2.
destruct H2 as [p [H2 H4] ].
rewrite in_seq_iff in H4.
subst e.
simpl in H3.
case_eq (n + s).
intro H5.
contradict H5.
omega.
intros q H5.
rewrite H5 in H3.
case_eq (leb p q); intro H6.
rewrite H6 in H3.
simpl in H3.
do 2 rewrite <- beq_nat_refl in H3.
discriminate H3.
rewrite leb_iff_conv in H6.
contradict H6.
omega.
rewrite forallb_forall_conv in H1.
destruct H1 as [e [H1 H2] ].
rewrite in_map_iff in H1.
destruct H1 as [p [H1 H3] ].
rewrite in_seq_iff in H3.
subst e.
simpl in H2.
case_eq (n + 0).
intro H4.
contradict H4.
omega.
intros q H4.
rewrite H4 in H2.
case_eq (leb p q); intro H5.
rewrite H5 in H2.
simpl in H2.
rewrite <- beq_nat_refl in H2.
discriminate H2.
rewrite leb_iff_conv in H5.
contradict H5.
omega.
Qed.

Definition cond2_correct n s x g h0 h1 vnl vsl :
  length vnl = n ->
  length vsl = s ->
  sem (cond2 n s x g h0 h1) vnl vsl =
  match sem x vnl vsl with
  | nil => sem g vnl vsl
  | true  :: _ => sem h0 vnl (tl (sem x vnl vsl) :: vsl)
  | false :: _ => sem h1 vnl (tl (sem x vnl vsl) :: vsl)
  end.
Proof.
intros Hn Hs.
simpl.
destruct (sem x vnl vsl) as [ | [ | ] v]; simpl.
reflexivity.
rewrite map_proj_seq_normal.
rewrite map_proj_seq_safe.
f_equal.
subst n.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vnl) at 2.
apply firstn_app.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
rewrite map_proj_seq_normal.
rewrite map_proj_seq_safe.
f_equal.
subst n.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vnl) at 2.
apply firstn_app.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
Qed.

(** * Recursion with one function [h] taking [i] instead of two function [h]_[i] *)

Definition rec1 n s g h :=
  rec
    g
    (comp (S n) (S s) h
      (comp (S n) 0 (succ false) nil [proj (S n) 0 0] ::
       map (proj (S n) 0)     (seq 1     n))
      (map (proj (S n) (S s)) (seq (S n) (S s))))
    (comp (S n) (S s) h
      (comp (S n) 0 (succ true) nil [proj (S n) 0 0] ::
       map (proj (S n) 0)     (seq 1     n))
      (map (proj (S n) (S s)) (seq (S n) (S s)))).

Lemma sem_rec_false g h0 h1 vnl vsl v :
  sem (rec g h0 h1) ((false :: v) :: vnl) vsl =
  sem h0 (v :: vnl) (sem (rec g h0 h1) (v :: vnl) vsl :: vsl).
Proof.
reflexivity.
Qed.

Lemma sem_rec_true g h0 h1 vnl vsl v :
  sem (rec g h0 h1) ((true :: v) :: vnl) vsl =
  sem h1 (v :: vnl) (sem (rec g h0 h1) (v :: vnl) vsl :: vsl).
Proof.
reflexivity.
Qed.

Lemma rec1_arities n s g h
  (Hg : arities g = ok_arities n s)
  (Hh : arities h = ok_arities (S n) (S s)) :
  arities (rec1 n s g h) = ok_arities (S n) s.
Proof.
simpl.
rewrite Hg, Hh.
simpl.
do 2 rewrite map_length, seq_length.
do 2 rewrite <- beq_nat_refl.
simpl.
rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H1
end.
simpl.
case_eq (n + S s).
intro H2.
contradict H2.
omega.
intros p H2.
case_eq (leb n p); intro H3.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H4
end.
do 4 rewrite <- beq_nat_refl.
simpl.
reflexivity.
rewrite forallb_forall_conv in H4.
destruct H4 as [e [H4 H5] ].
rewrite in_map_iff in H4.
destruct H4 as [q [H4 H6] ].
rewrite in_seq_iff in H6.
subst e.
simpl in H5.
case_eq (leb q (n + S s)); intro H7.
rewrite H7 in H5.
simpl in H5.
do 2 rewrite <- beq_nat_refl in H5.
discriminate H5.
rewrite leb_iff_conv in H7.
contradict H7.
omega.
rewrite leb_iff_conv in H3.
contradict H3.
omega.
rewrite forallb_forall_conv in H1.
destruct H1 as [e [H1 H2] ].
rewrite in_map_iff in H1.
destruct H1 as [q [H1 H3] ].
rewrite in_seq_iff in H3.
subst e.
simpl in H2.
case_eq (leb q (n+0)); intro H4.
rewrite H4 in H2.
simpl in H2.
rewrite <- beq_nat_refl in H2.
discriminate H2.
rewrite leb_iff_conv in H4.
contradict H4.
omega.
Qed.

Fixpoint sem_rec1
  (g h:BC)(v : bs)(vnl vsl : list bs) {struct v} :=
  match v with
    | nil => sem g vnl vsl
    | _::v' => sem h (v::vnl) (sem_rec1 g h v' vnl vsl :: vsl)
  end.

Lemma rec1_correct n s g h vnl vsl :
  length vnl = S n ->
  length vsl = s ->
  sem (rec1 n s g h) vnl vsl =
  sem_rec1 g h (hd nil vnl) (tl vnl) vsl.
Proof.
intros Hn Hs.
destruct vnl as [ | v vnl].
reflexivity.
simpl in Hn.
induction v as [ | b v IH].
reflexivity.
simpl sem_rec1.
simpl hd in IH.
simpl tl in IH.
rewrite <- IH.
clear IH.
unfold rec1.
case b.
rewrite sem_rec_true.
match goal with
| |- context [sem (rec ?g ?h0 ?h1) ?vnl ?vsl] =>
    set (e0 := sem (rec g h0 h1) vnl vsl)
end.
rewrite sem_comp, map_map.
f_equal.
rewrite map_cons.
f_equal.
replace (S n) with (n+1) by omega.
rewrite map_proj_seq_normal_gen by (simpl; omega).
erewrite firstn_map_nth by (simpl; omega).
instantiate (1:=nil).
rewrite <- seq_shift, map_map; simpl.
apply map_nth_seq.
omega.
rewrite <- (
  map_map
    (proj (S n) (S s))
    (fun e => sem e (v :: vnl) (e0 :: vsl))
);rewrite map_proj_seq_safe; simpl.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
rewrite sem_rec_false.
match goal with
| |- context [sem (rec ?g ?h0 ?h1) ?vnl ?vsl] =>
    set (e0 := sem (rec g h0 h1) vnl vsl)
end.
rewrite sem_comp, map_map.
f_equal.
rewrite map_cons.
f_equal.
replace (S n) with (n+1) by omega.
rewrite map_proj_seq_normal_gen by (simpl; omega).
erewrite firstn_map_nth by (simpl; omega).
instantiate (1:=nil).
rewrite <- seq_shift, map_map; simpl.
apply map_nth_seq.
omega.
rewrite <- (
  map_map
    (proj (S n) (S s))
    (fun e => sem e (v :: vnl) (e0 :: vsl))
);rewrite map_proj_seq_safe; simpl.
f_equal.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
Qed.

(** * Recursion on the result of the function [x],
      with one function [h] taking [i] instead of two function [h]_[i] *)

Definition rec3 n s x g h : BC :=
  comp n s
    (rec1 n s g h)
    (x ::
     map (proj n 0) (seq 0 n))
    (map (proj n s) (seq n s)).

Lemma arities_rec3 n s x g h
  (Hx : arities x = ok_arities n 0)
  (Hg : arities g = ok_arities n s)
  (Hh : arities h = ok_arities (S n) (S s)) :
  arities (rec3 n s x g h) = ok_arities n s.
Proof.
simpl.
rewrite Hx, Hg, Hh.
simpl.
do 4 rewrite map_length, seq_length.
do 2 rewrite <- beq_nat_refl.
simpl.
rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H1
end.
simpl.
case_eq (n + S s).
intro H2.
contradict H2.
omega.
intros p H2.
case_eq (leb n p); intro H3.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H4
end.
do 4 rewrite <- beq_nat_refl.
simpl.
do 2 rewrite <- beq_nat_refl.
simpl.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H5
end.
match goal with
| |- context [forallb ?P ?l] => case_eq (forallb P l); intro H6
end.
simpl.
reflexivity.
rewrite forallb_forall_conv in H6.
destruct H6 as [e [H6 H7] ].
rewrite in_map_iff in H6.
destruct H6 as [q [H6 H8] ].
rewrite in_seq_iff in H8.
subst e.
simpl in H7.
case_eq (n+s).
intro H9.
contradict H8.
omega.
intros r H9.
rewrite H9 in H7.
case_eq (leb q r); intro H10.
rewrite H10 in H7.
simpl in H7.
do 2 rewrite <- beq_nat_refl in H7.
discriminate H7.
rewrite leb_iff_conv in H10.
contradict H10.
omega.
rewrite forallb_forall_conv in H5.
destruct H5 as [e [H5 H6] ].
rewrite in_map_iff in H5.
destruct H5 as [q [H5 H7] ].
rewrite in_seq_iff in H7.
subst e.
simpl in H6.
case_eq (n+0).
intro H8.
contradict H7.
omega.
intros r H8.
rewrite H8 in H6.
case_eq (leb q r); intro H9.
rewrite H9 in H6.
simpl in H6.
rewrite <- beq_nat_refl in H6.
discriminate H6.
rewrite leb_iff_conv in H9.
contradict H9.
omega.
rewrite forallb_forall_conv in H4.
destruct H4 as [e [H4 H5] ].
rewrite in_map_iff in H4.
destruct H4 as [q [H4 H6] ].
rewrite in_seq_iff in H6.
subst e.
simpl in H5.
case_eq (n+S s).
intro H7.
contradict H6.
omega.
intros r H7.
rewrite H7 in H5.
case_eq (leb q (S r)); intro H8.
rewrite H8 in H5.
simpl in H5.
do 2 rewrite <- beq_nat_refl in H5.
discriminate H5.
rewrite leb_iff_conv in H8.
contradict H8.
omega.
rewrite leb_iff_conv in H3.
contradict H3.
omega.
rewrite forallb_forall_conv in H1.
destruct H1 as [e [H1 H2] ].
rewrite in_map_iff in H1.
destruct H1 as [q [H1 H3] ].
rewrite in_seq_iff in H3.
subst e.
simpl in H2.
case_eq (leb q (n+0)); intro H4.
rewrite H4 in H2.
simpl in H2.
rewrite <- beq_nat_refl in H2.
discriminate H2.
rewrite leb_iff_conv in H4.
contradict H4.
omega.
Qed.

Lemma rec3_correct n s x g h vnl vsl :
  length vnl = n ->
  length vsl = s ->
  sem (rec3 n s x g h) vnl vsl =
  sem_rec1 g h (sem x vnl nil) vnl vsl.
Proof.
intros Hn Hs.
unfold rec3.
rewrite sem_comp, rec1_correct; simpl.
f_equal.
rewrite map_proj_seq_normal.
subst n.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vnl) at 2.
apply firstn_app.
rewrite map_proj_seq_safe.
subst s.
rewrite minus_diag.
simpl.
rewrite app_nil_r.
rewrite <- (app_nil_r vsl) at 2.
apply firstn_app.
rewrite map_length, map_length, seq_length; reflexivity.
rewrite map_length, map_length, seq_length; reflexivity.
Qed.

(** * True

  - with any arities (n, s)
*)

Definition true_e (n s:nat) : BC :=
  comp n s (comp 0 0 (succ true) nil (zero :: nil)) nil nil.

Lemma true_correct n s l1 l2:
 bs2bool (sem (true_e n s) l1 l2) = true.
Proof.
 intros; simpl; trivial.
Qed.

Lemma true_correct_nat n s l1 l2:
 bs2nat (sem (true_e n s) l1 l2) = 1.
Proof.
 intros; simpl; trivial.
Qed.

(** * False

  - with any arities (n, s)
*)

Definition false_e (n s:nat) : BC :=
  comp n s (comp 0 0 (succ false) nil (zero :: nil)) nil nil.

Lemma false_correct n s l1 l2:
 bs2bool (sem (false_e n s) l1 l2) = false.
Proof.
 intros; simpl; trivial.
Qed.

Lemma false_correct_nat n s l1 l2:
 bs2nat (sem (false_e n s) l1 l2) = 0.
Proof.
 intros; simpl; trivial.
Qed.

(** * Parity

  - arities: (0, 1)
*)

Definition parity_e : BC := (* 0 1 *)
  comp 0 1 cond nil [proj 0 1 0; false_e 0 1; true_e 0 1; false_e 0 1].

Lemma parity_correct_even v :
  bs2bool (sem parity_e nil [v]) = false ->
  even (bs2nat v).
Proof.
  destruct v; simpl; intros.
  apply even_O.
  destruct b; simpl in *.
  discriminate.
  cutrewrite (bs2nat v + (bs2nat v + 0) = 2 * (bs2nat v)).
  auto with arith.
  ring.
Qed.

Lemma parity_correct_odd v :
  bs2bool (sem parity_e nil [v]) = true ->
  odd (bs2nat v).
Proof.
  destruct v; simpl; intros.
  discriminate.
  cutrewrite (bs2nat v + (bs2nat v + 0) = (2 * (bs2nat v))).
  destruct b.
  apply odd_S.
  auto with arith.
  simpl in H; discriminate.
  omega.
Qed.

(** * Functions P, P', Y and I as defined by Bellantoni and Cook

  - arities of P: (1, 1)

  - arities of P': (2, 0)

  - arities of Y: (2, 1)

  - arities of I: (2, 1)
*)

Definition P (x:bs)(y:bs) : bs := skipn (length x) y.

Lemma P_nil : forall x, P x nil = nil.
Proof.
 intro x; case x; trivial.
Qed.

Definition P_e : BC :=
  rec (proj 0 1 0)
      (comp 1 2 pred nil [proj 1 2 1])
      (comp 1 2 pred nil [proj 1 2 1]).

Lemma P_correct x y :
  sem P_e [x] [y] = P x y.
Proof.
 unfold P; induction x; simpl in *; trivial.
 intros; case a.
 rewrite IHx; clear IHx.
 induction (length x); simpl; trivial.
 rewrite <- IHn; clear IHn.
 revert y.
 induction n; simpl; trivial; intros.
 case y; simpl; trivial.
 case y; simpl; trivial; intros.
 rewrite IHx; clear IHx.
 induction (length x); simpl; trivial.
 rewrite <- IHn; clear IHn.
 revert y.
 induction n; simpl; trivial; intros.
 case y; simpl; trivial.
 case y; simpl; trivial; intros.
Qed.

Global Opaque P_e.

Definition P'_e := from_11_to_20 P_e.

Definition Y (z w y:bs) : bs :=
  P (P z w) y.

Definition Y_e : BC :=
  comp 2 1 P_e
  [comp 2 0 P'_e [proj 2 0 0; proj 2 0 1] nil]
  [proj 2 1 2].

Lemma Y_correct z w y :
  sem Y_e [z;w] [y] = Y z w y.
Proof.
 intros; simpl.
 rewrite P_correct, P_correct.
 trivial.
Qed.

Lemma Y_skipn z w y :
  Y z w y = skipn (length w - length z) y.
Proof.
 unfold Y, P; intros.
 rewrite length_skipn.
 trivial.
Qed.

Global Opaque Y_e.

Lemma Y_nth x y z :
 hd false (Y x y z) = nth (length y - length x) z false.
Proof.
 unfold Y, P; intros.
 rewrite length_skipn.
 remember (length y - length x) as n.
 revert x y z Heqn.
 induction n; simpl; intros.
 case z; trivial.
 destruct z; simpl in *; trivial.
 apply IHn with (x:=true::x) (y:=y).
 simpl.
 omega.
Qed.

Lemma Y_nil x y : Y x y nil = nil.
Proof.
  intros; unfold Y, P.
  case (length (skipn (length x) y)); simpl; trivial.
Qed.

Lemma Y_refl x y : Y x x y = y.
Proof.
 intros; unfold Y, P.
 rewrite length_skipn, minus_diag; simpl; trivial.
Qed.

Lemma Y_nil_length x y z :
  Y x y z = nil ->
  length z <= length y - length x.
Proof.
 intros.
 unfold Y, P in H.
 rewrite length_skipn in H.
 apply skipn_nil_length; trivial.
Qed.

Lemma Y_hd_same x y z i1 i2: Y (i1 :: x) y z = Y (i2 :: x) y z.
Proof.
 intros; unfold Y, P.
 simpl; trivial.
Qed.

Lemma Y_le : forall u w y , length u <= length w ->
   length (Y u w y) <= length (Y w w y).
 intros.
 repeat rewrite Y_skipn.
 repeat rewrite skipn_length.
 omega.
Qed.

Definition I_e : BC :=
  comp 2 1 parity_e nil
  [comp 2 1 Y_e
    [comp 2 0 (succ true) nil [proj 2 0 0]; proj 2 0 1]
    [proj 2 1 2] ].

Lemma I_correct (z w y : bs) :
  sem I_e [z;w] [y] = [nth (length w - S (length z)) y false].
Proof.
 simpl; intros.
 rewrite Y_correct.
 case_eq (Y (true :: z) w y); intros.
 apply Y_nil_length in H; simpl in H.
 rewrite nth_overflow; trivial.
 replace (S (length z)) with (length (true :: z)).
 rewrite <- Y_nth.
 rewrite H; simpl; trivial.
 destruct b; trivial.
 simpl; trivial.
Qed.

Lemma I_Y_property j z w y :
  length z < length w ->
  length w - S (length z) < length y ->
  Y (j :: z) w y = [nth (length w - S (length z)) y false] ++ Y z w y.
Proof.
 intros; simpl.
 rewrite Y_skipn.
 rewrite Y_skipn.
 simpl.
 rewrite skipn_hd with (d := false).
 f_equal.
 f_equal.
 omega.
 trivial.
Qed.

Global Opaque I_e.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype ssralg.
From mathcomp Require Import ssrfun choice seq bigop prime div.
From mathcomp Require Export poly polydiv.
(* ------- *) Require Export polyorder.

Import GRing.Theory.

Open Local Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Local Notation simp := Monoid.simpm.

(* -------------------------------------------------------------------- *)
Section PolyAll.
  Variable R : idomainType.

  Implicit Types p q : {poly R}.

  (* ------------------------------------------------------------------ *)
  Definition coefE := (coefB, coefD , coefN, coefC ,
                       coefZ, coefMn, coefX, coefXn).

  (* ------------------------------------------------------------------ *)
  Lemma polyX_eq0: 'X != 0 :> {poly R}.
  Proof.
    by rewrite -size_poly_eq0 size_polyX.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma polyC_natr: forall n, n%:R%:P = n%:R :> {poly R}.
  Proof.
    by elim=> [|n IH] //=; rewrite -addn1 !natrD polyC_add IH.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma size_poly2P (p : {poly R}):
    reflect (exists2 c : R * R, c.1 != 0 & p = c.1 *: 'X - c.2%:P) (size p == 2).
  Proof.
    apply: (iffP idP); last first.
      case=> [[c1 c2]] /= nz_c1 ->; rewrite size_addl; last first.
        rewrite size_scale // size_polyX size_opp size_polyC.
        by case: (_ == _).
      by rewrite size_scale // size_polyX.
    move=> sz_p; pose c1 := p`_1; pose c0 := p`_0.
    exists (c1, -c0) => /=.
      rewrite /c1 (pred_Sn 1) -(eqP sz_p) /= -lead_coefE.
      by rewrite lead_coef_eq0 -size_poly_eq0 (eqP sz_p).
    apply/polyP=> i; rewrite !coefE; case: i => [|[|i]].
    + by rewrite mulr0 sub0r opprK.
    + by rewrite mulr1 subr0.
    + by rewrite subr0 mulr0 -[p]coefK (eqP sz_p) coef_poly.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma size_addr:
    forall p q,
      size (p + q) < size q -> size p = size q.
  Proof.
    move=> p q; case: (ltngtP (size p) (size q)) => //.
    + by move/size_addl; rewrite addrC=> ->; rewrite ltnn.
    + move=> H; move: (size_addl H)=> -> H'.
      by absurd false=> //; rewrite -(ltnn (size q)) (ltn_trans H).
  Qed.

  Lemma size_add_max p q:
    size p != size q -> size (p + q) = maxn (size p) (size q).
  Proof.
    move=> neq_sz; case sz_cmp: (size q < size p).
      by rewrite size_addl // maxnC /maxn sz_cmp.
    rewrite addrC size_addl; last first.
      by rewrite ltnNge leq_eqVlt sz_cmp orbF eq_sym.
    by rewrite maxnC /maxn sz_cmp.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma polyseq2:
    forall p, size p = 2 ->
        (exists2 r, (r.2 != 0) & (p = [:: r.1; r.2] :> seq R)).
  Proof.
    move=> [/= [//|x1 [//|x2 [//=| ? //]]]].
    by move=> Hx _; exists (x1, x2) => //=.
  Qed.

  Lemma sqpp_sub_polyseq (r : R):
    ('X - r%:P)^+2 = [:: r^+2; - (2%:R * r); 1] :> seq R.
  Proof.
    rewrite mulrDl !simp.
    rewrite sqrrB expr2 mulr2n -mulrDr -mulrBr mulrC.
    rewrite -polyC_exp -polyC_add -cons_poly_def.
    by rewrite polyseq_cons polyseqXsubC.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma dvd_factornP p c n:
    (p == (p %/ ('X - c%:P)^+n) * ('X - c%:P)^+n) = (('X - c%:P)^+n %| p).
  Proof.
    rewrite Pdiv.Idomain.dvdp_eq lead_coef_exp lead_coefXsubC.
    by rewrite !expr1n scale1r.
  Qed.

  Lemma divp_rootn n x p:
    p != 0 -> n <= \mu_x p -> p %/ ('X - x%:P)^+n != 0.
  Proof.
    move=> nz_p Hn; case: (@mu_spec _ p x nz_p)=> q Hq Ep.
    rewrite Ep -(subnK Hn) exprD mulrA Pdiv.IdomainMonic.mulpK; last first.
    + by rewrite monic_exp // monicXsubC.
    rewrite mulf_eq0 negb_or expf_eq0 polyXsubC_eq0 andbF andbT.
    apply/negP; move/eqP=> z_q.
    by rewrite z_q mul0r in Ep; rewrite Ep eqxx in nz_p.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma size_id_exp:
    forall n p,
      p != 0 -> size (p ^+ n) = ((n * (size p)) - n).+1%N.
  Proof.
    move=> n p nz_p; elim: n => [|n IH] //.
    + by rewrite !simp expr0 subnn size_polyC oner_neq0.
    rewrite exprS size_mul ?expf_neq0 //.
    rewrite IH addnS /= addnBA -?mulSn -1?subnSK //.
    + by rewrite leq_pmulr // lt0n size_poly_eq0.
    + by rewrite leq_pmulr // lt0n size_poly_eq0.
  Qed.

  Lemma odd_size_id_exp:
    forall n p , p != 0 ->
      odd (size (p ^+ n)) = if odd n then odd (size p) else true.
  Proof.
    move=> n p nz_p; rewrite size_id_exp //=.
    rewrite odd_sub ?leq_pmulr // ?lt0n ?size_poly_eq0 // odd_mul.
    by case: (odd n)=> //=; rewrite addbT negbK.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma mu_divp_mul:
    forall x p,
      p %/ ('X - x%:P)^+(\mu_x p) * ('X - x%:P)^+(\mu_x p) = p.
  Proof.
    move=> x p /=; have [-> | nz_p] := eqVneq p 0.
    + by rewrite div0p mul0r.
    by apply/eqP; rewrite eq_sym dvd_factornP root_mu.
  Qed.

  Lemma le_mu_divp_mul:
    forall x n p,
      n <= \mu_x p -> p %/ ('X - x%:P)^+n * ('X - x%:P)^+n = p.
  Proof.
    move=> x n p le_n_mu; have [-> | nz_p] := eqVneq p 0.
    + by rewrite div0p mul0r.
    by apply/eqP; rewrite eq_sym dvd_factornP root_le_mu.
  Qed.

  Lemma divp_factor_mu_neq0:
    forall x n p,
      p != 0 -> n <= \mu_x p -> p %/ ('X - x%:P)^+n != 0.
  Proof.
    move=> x n p nz_p le_n_mu; apply/negP=> /eqP.
    move/(congr1 ( *%R^~ (('X - x%:P)^+n))).
    rewrite !simp le_mu_divp_mul // => /eqP.
    by rewrite (negbTE nz_p).
  Qed.

  Lemma rootN_div_mu:
    forall x p, p != 0 ->
      ~~(root (p %/ ('X - x%:P) ^+ (\mu_x p)) x).
  Proof.
    move=> z p nz; rewrite -mu_gt0 ?divp_rootn ?(negbT nz) //.
    by rewrite -eqn0Ngt mu_div // subnn.
  Qed.

  Lemma divp_factor_root_neq0 (p : {poly R}) x:
    p != 0 -> root p x -> p %/ ('X - x%:P) != 0.
  Proof.
    move=> nz_p root_p_x; rewrite -['X - _]expr1.
    by apply: divp_factor_mu_neq0 => //; rewrite mu_gt0.
  Qed.

  Lemma mu_factor (x c : R): \mu_x ('X - c%:P) = (x == c).
  Proof.
    have [->|x_neq_c] := eqVneq x c.
    + by rewrite eqxx mu_XsubC.
    apply/eqP; rewrite (negbTE x_neq_c) eqn0Ngt mu_gt0.
    by rewrite root_XsubC. by rewrite polyXsubC_eq0.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma mu_prod (I : Type) (r : seq I) (P : pred I) (F : I -> {poly R}) x:
       \prod_(i <- r | P i) (F i) != 0
    -> \mu_x (\prod_(i <- r | P i) (F i)) = (\sum_(i <- r | P i) (\mu_x (F i)))%N.
  Proof.
    elim: r => [|i r IH]; first by rewrite !big_nil mu_polyC.
    rewrite !big_cons; case: (P i) => nz; last by rewrite IH.
    by rewrite mu_mul // IH //; move: nz; rewrite mulf_eq0; case/norP.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma mu_deriv_char (p : {poly R}) (x : R):
       (forall i, i < size p -> i \notin [char R])
    -> root p x
    -> \mu_x (p^`()) = (\mu_x p - 1)%N.
  Proof.
    move=> chrp z_px; have [->|nz_p] := eqVneq p 0.
      by rewrite derivC mu0.
    have [q nz_qx Ep] := mu_spec x nz_p.
    case Dm: (\mu_x p) => [|m].
      by move: z_px; rewrite Ep Dm mulr1 (negPf nz_qx).
    rewrite subn1 Ep Dm !derivCE mul1r -!pred_Sn.
    rewrite mulrnAr -mulrnAl exprS mulrA -mulrDl.
    rewrite cofactor_XsubC_mu // rootE !(hornerE, hornerMn).
    rewrite subrr mulr0 add0r -mulr_natl mulf_eq0.
    rewrite -rootE negb_or nz_qx andbT natf_neq0.
    rewrite /pnat /=; apply/allP => i; rewrite mem_primes.
    case/and3P=> _ _ /dvdn_leq -/(_ (ltn0Sn _)) => le_i_Sm.
    move/(dvdp_leq nz_p): (root_mu p x); rewrite size_exp_XsubC Dm.
    by move/(leq_ltn_trans le_i_Sm)/chrp.
  Qed.

  (* -------------------------------------------------------------------- *)
  Lemma lead_coef_prod (I : Type) (r : seq I) (P : pred I) (F : I -> {poly R}):
    lead_coef (\prod_(i <- r | P i) (F i)) = \prod_(i <- r | P i) (lead_coef (F i)).
  Proof.
    elim: r => [|i r IH]; first by rewrite !big_nil lead_coefC.
    by rewrite !big_cons; case: (P i); rewrite 1?lead_coefM IH.
  Qed.

  (* -------------------------------------------------------------------- *)
  Lemma coprimep_prod p (qs : seq {poly R}):
    coprimep p (\prod_(q <- qs) q) = all [pred q | coprimep p q] qs.
  Proof.
    elim: qs=> [|q qs IH]; first by rewrite big_nil coprimep1.
    by rewrite big_cons coprimep_mulr IH.
  Qed.

  (* -------------------------------------------------------------------- *)
  Lemma size_scale_leq (c : R) (p : {poly R}):
    size (c *: p) <= size p.
  Proof.
    have [->|nz_c] := eqVneq c 0.
      by rewrite scale0r size_poly0 leq0n.
    by rewrite size_scale.
  Qed.
End PolyAll.

(* -------------------------------------------------------------------- *)
Lemma size_polyf2P (K : fieldType) (p : {poly K}):
  reflect (exists c : K, p %= 'X - c%:P) (size p == 2).
Proof.
  apply: (iffP idP).
  + move/size_poly2P=> [[c1 c2] /= nz_c1 ->].
    exists (c2 / c1); apply/eqpf_eq; exists c1 => //.
    rewrite scalerBr; congr (_ - _); rewrite -mul_polyC polyC_mul.
    rewrite -polyC_inv mulrCA divrr ?mulr1 // poly_unitE.
    by rewrite size_polyC nz_c1 coefC /= unitfE.
  + by case=> c /eqpf_eq [c' nz_c' ->]; rewrite size_scale // size_XsubC.
Qed.

(* -------------------------------------------------------------------- *)
Lemma roots_dvdp (K: fieldType) (p : {poly K}) (cs : seq K):
     all [pred x | count (pred1 x) cs <= \mu_x p] cs
  -> (\prod_(c <- cs) ('X - c%:P)) %| p.
Proof.
  move=> roots; apply/dvdpP; have [->|nz_p] := eqVneq p 0.
    by exists 0; rewrite mul0r.
  elim: cs p nz_p roots => [|c cs IH] p nz_p /=.
    by move=> _; exists p; rewrite big_nil mulr1.
  rewrite eqxx add1n; case/andP=> cs_mu_pc /allP cs_mu_p.
  have/factor_theorem: root p c.
    by move: cs_mu_pc; move/(leq_ltn_trans (leq0n _));
      rewrite mu_gt0.
  case=> q Ep; have := nz_p; rewrite {1}Ep.
    rewrite mulf_eq0 polyXsubC_eq0 orbF => nz_q.
  have mu_pq: forall z, (\mu_z p = \mu_z q + (z == c))%N.
    move=> z; move/(congr1 \mu_z): Ep.
    by rewrite mu_mul ?(mulf_neq0, polyXsubC_eq0) // mu_factor.
  case: (IH q)=> //.
  + apply/allP=> z /cs_mu_p /=; rewrite mu_pq.
    by rewrite eq_sym addnC; rewrite leq_add2r.
  move=> qq Eq; rewrite Ep Eq; exists qq.
  by rewrite big_cons mulrAC mulrA.
Qed.

(* -------------------------------------------------------------------- *)
Lemma copsqr (K : fieldType) (s p q : {poly K}):
  s != 0 -> coprimep p q -> s^+2 = p * q ->
    exists r, p %= r ^+ 2.
  move=> s_neq0 cpq hpq; exists (gcdp p s); set d := gcdp _ _.
  have p_neq0 : p != 0.
    apply: contraNneq s_neq0 => p_eq0.
    by move/eqP: hpq; rewrite p_eq0 mul0r expf_eq0.
  have d_neq0 : d != 0 by rewrite gcdp_eq0 (negPf p_neq0) (negPf s_neq0).
  have dvd_ds: d %| s by rewrite dvdp_gcdr.
  have dvd_dp: d %| p by rewrite dvdp_gcdl.
  have: d ^+ 2 %| s ^+ 2; first by rewrite dvdp_exp2r.
  rewrite hpq Gauss_dvdpl => [hp|]; last first.
    by rewrite (@coprimep_dvdr _ (p ^+ 2)) ?dvdp_exp2r ?coprimep_expl.
  rewrite -(divpK hp) -[X in _ %= X]mul1r eqp_mulr //.
  rewrite (dvdp_eqp1 _ (eqpxx _)) //.
  rewrite -(@Gauss_dvdpl _ _ (s ^+ 2 %/ d ^+ 2)) ?mul1r.
    rewrite -(@dvdp_mul2r _ (d ^+ 2)) ?expf_eq0 //.
    by rewrite !divpK ?dvdp_exp2r // hpq dvdp_mulr.
  rewrite -(divpK dvd_ds) exprMn mulpK ?expf_eq0 // coprimep_expr //.
  rewrite (@coprimep_dvdr _ (p %/ d)) ?coprimep_div_gcd ?p_neq0 //.
  rewrite -(@dvdp_mul2r _ (d ^+ 2)) ?expf_eq0 //.
  by rewrite divpK // mulrA divpK // dvdp_mulr.
Qed.


(* Additional theorems about list operations. *)

From CGT Require Import A1_setup.
Require Import Wf_nat.

Local Close Scope positive.

Definition sum_list l := fold_left Nat.add l 0.
Definition max_list l := fold_left Nat.max l 0.

Section Lists.

Variable X : Type.
Hypothesis eq_dec : ∀x x' : X, {x = x'} + {x ≠ x'}.

Theorem nodup_dec (l : list X) :
  {NoDup l} + {∃l0 x l1, l = l0 ++ x :: l1 /\ In x l1}.
Proof.
induction l. left; apply NoDup_nil.
destruct IHl. destruct (in_dec eq_dec a l).
- right; exists [], a, l; easy.
- left; apply NoDup_cons; easy.
- right; destruct e as [l0 [x [l1 []]]]; subst.
  exists (a :: l0), x, l1; easy.
Qed.

Theorem app_cut (l0 l0' l1 l1' : list X) :
  l0 ++ l0' = l1 ++ l1' -> length l0 = length l1 -> l0 = l1 /\ l0' = l1'.
Proof.
revert l0' l1 l1'; induction l0; intros; destruct l1; try easy.
inv H. apply IHl0 in H3 as []; subst. easy.
simpl in H0; inv H0.
Qed.

Theorem map_singleton_eq {Y} (f : X -> Y) x y :
  map f [x] = [y] -> f x = y.
Proof.
simpl; intros H; inv H.
Qed.

Theorem fold_left_skipn {Y} (f : Y -> X -> Y) l n y :
  fold_left f l y = fold_left f (skipn n l) (fold_left f (firstn n l) y).
Proof.
revert l y; induction n; destruct l; simpl; easy.
Qed.

Theorem firstn_incl n (l : list X) :
  firstn n l ⊆ l.
Proof.
revert l; induction n; destruct l; simpl.
1-3: apply incl_nil_l. apply incl_cons.
apply in_eq. apply incl_tl, IHn.
Qed.

Theorem skipn_incl n (l : list X) :
  skipn n l ⊆ l.
Proof.
revert l; induction n; destruct l; simpl.
1,3: apply incl_nil_l. apply incl_refl.
apply incl_tl, IHn.
Qed.

Theorem in_app_comm (x : X) l l' :
  In x (l ++ l') -> In x (l' ++ l).
Proof.
intros; apply in_app_iff; apply in_app_iff in H as []; auto.
Qed.

Section Well_founded_induction.

Variable P : list X -> Prop.
Hypothesis IH : ∀l, (∀l', length l' < length l -> P l') -> P l.

Theorem lt_length_wf_ind l :
  P l.
Proof.
remember (length l) as n; revert Heqn; revert l.
apply (lt_wf_ind n); clear n; intros n IH' l H; subst.
apply IH; intros. apply IH' with (m:=length l'); easy.
Qed.

End Well_founded_induction.

End Lists.

Global Hint Resolve incl_nil_l firstn_incl skipn_incl : datatypes.
Global Hint Rewrite firstn_length skipn_length : list.