From Coq Require Import Lists.List.
From Coq Require Import BinNums.
From Coq Require Import ZArith.BinInt.
From Coq Require Import ZArith.BinIntDef.
From Coq Require Import ZArith.Zdigits.
From Coq Require Import ZArith.Znat.
From Coq Require Import NArith.Nnat.
From Coq Require Import ZArith Psatz.
From Coq Require Import PeanoNat.
Import ListNotations.

Inductive monkey :=
  | Monkey (idx : nat) (items : list N) (op : N -> N) (test : N -> bool) (throwt : nat) (throwf : nat)
.

Inductive red_monkey :=
  | RMonkey (idx : nat) (items : list N)
.

Definition reduce (m : monkey) :=
  match m with
  | Monkey idx items _ _ _ _ => RMonkey idx items
  end.

Open Scope N_scope.
Definition test_in :=  [
  Monkey 0%nat [79;98] (fun n => n * 19) (fun n => N.modulo n 23 =? 0) 2 3;
  Monkey 1%nat [54;65;75;74] (fun n => n + 6) (fun n => N.modulo n 19 =? 0) 2 0;
  Monkey 2%nat [79;60;97] (fun n => n * n) (fun n => N.modulo n 13 =? 0) 1 3;
  Monkey 3%nat [74] (fun n => n + 3) (fun n => N.modulo n 17 =? 0) 0 1
].

Definition input :=  [
  Monkey 0%nat [85;77;77] (fun n => n * 7) (fun n => N.modulo n 19 =? 0) 6 7;
  Monkey 1%nat [80;99] (fun n => n * 11) (fun n => N.modulo n 3 =? 0) 3 5;
  Monkey 2%nat [74;60;74;63;86;92;80] (fun n => n + 8) (fun n => N.modulo n 13 =? 0) 0 6;
  Monkey 3%nat [71;58;93;65;80;68;54;71] (fun n => n + 7) (fun n => N.modulo n 7 =? 0) 2 4;
  Monkey 4%nat [97;56;79;65;58] (fun n => n + 5) (fun n => N.modulo n 5 =? 0) 2 0;
  Monkey 5%nat [77] (fun n => n + 4) (fun n => N.modulo n 11 =? 0) 4 3;
  Monkey 6%nat [99;90;84;50] (fun n => n * n) (fun n => N.modulo n 17 =? 0) 7 1;
  Monkey 7%nat [50;66;61;92;64;78] (fun n => n + 3) (fun n => N.modulo n 2 =? 0) 5 1
].

Definition fail_monkey := Monkey 99%nat [] id (fun _ => false) 99%nat 99%nat.

Fixpoint update_nth {A} (n : nat) (f : A -> A) (l : list A) :=
  match n, l with
  | _, nil => nil
  | O, (a :: r) => f a :: r
  | S n, (a :: r) => a :: update_nth n f r
  end.

Section Part1.
Let monkey_item_step (monkeys : list monkey) (idx : nat) :=
  match nth idx monkeys fail_monkey with
  | (Monkey _ [] _ _ _ _) => monkeys
  | (Monkey _ (i::r) op test throwt throwf) =>
    let i' := N.div (op i) 3 in
    let target := if test i' then throwt else throwf in
    (update_nth target (fun m => match m with | (Monkey idxt lt opt testt throwtt throwft) => Monkey idxt (lt++[i']) opt testt throwtt throwft end)
    (update_nth idx (fun _ => Monkey idx r op test throwt throwf) monkeys))
  end.

Let Fixpoint monkey_step' (cnt : nat) (monkeys : list monkey) (idx : nat) :=
  match cnt with
  | O => monkeys
  | S n => monkey_step' n (monkey_item_step monkeys idx) idx
  end.

Let monkey_step (monkeys : list monkey) (idx : nat) (mb : list N) :=
  match nth idx monkeys fail_monkey with
  | (Monkey _ [] _ _ _ _) => (monkeys,mb)
  | (Monkey _ l _ _ _ _) => (monkey_step' (length l) monkeys idx,update_nth idx (fun n => n + N.of_nat (length l)) mb)
  end.

Let Fixpoint round' (monkeys : list monkey) (cur : nat) (mb : list N):=
  match cur with
  | O => (monkeys,mb)
  | S n => let (m',mb') := monkey_step monkeys (length monkeys - S n) mb in round' m' n mb'
  end.

Let round (monkeystate : list monkey * list N) := round' (fst monkeystate) (length (fst monkeystate)) (snd monkeystate).

Let Fixpoint ntimes {A} (n : nat) (f : A -> A) (a : A) :=
  match n with
  | O => a
  | S n => ntimes n f (f a)
  end.

Let Fixpoint insert (l : list N) (new : N) :=
  match l with
  | nil => [new]
  | (h :: t) => if h <=? new then new :: h :: t else h :: insert t new
  end.

Let Fixpoint sort (l : list N) :=
  match l with
  | nil => nil
  | (h :: t) => insert (sort t) h
  end.

Definition impl_1 (l : list monkey) :=
  let mb := snd (ntimes 20 round (l,repeat 0 (length l))) in
  match sort mb with
  | nil => 0
  | [_] => 0
  | a :: b :: _ => a * b
  end.

End Part1.

Section Part2.
Definition monkey_item_step (monkeys : list monkey) (idx : nat) :=
  match nth idx monkeys fail_monkey with
  | (Monkey _ [] _ _ _ _) => monkeys
  | (Monkey _ (i::r) op test throwt throwf) =>
    let i' := N.modulo (op i) (2*3*5*7*11*13*17*19*23) in
    let target := if test i' then throwt else throwf in
    (update_nth target (fun m => match m with | (Monkey idxt lt opt testt throwtt throwft) => Monkey idxt (lt++[i']) opt testt throwtt throwft end)
    (update_nth idx (fun _ => Monkey idx r op test throwt throwf) monkeys))
  end.

Fixpoint monkey_step' (cnt : nat) (monkeys : list monkey) (idx : nat) :=
  match cnt with
  | O => monkeys
  | S n => monkey_step' n (monkey_item_step monkeys idx) idx
  end.

Definition monkey_step (monkeys : list monkey) (idx : nat) (mb : list N) :=
  match nth idx monkeys fail_monkey with
  | (Monkey _ [] _ _ _ _) => (monkeys,mb)
  | (Monkey _ l _ _ _ _) => (monkey_step' (length l) monkeys idx,update_nth idx (fun n => n + N.of_nat (length l)) mb)
  end.

Fixpoint round' (monkeys : list monkey) (cur : nat) (mb : list N):=
  match cur with
  | O => (monkeys,mb)
  | S n => let (m',mb') := monkey_step monkeys (length monkeys - S n) mb in round' m' n mb'
  end.

Definition round (monkeystate : list monkey * list N) := round' (fst monkeystate) (length (fst monkeystate)) (snd monkeystate).

Fixpoint ntimes' {A} (n : positive) (f : A -> A) (a : A) :=
  match n with
  | xH => f a
  | xO n => ntimes' n (fun x => f (f x)) a
  | xI n => ntimes' n (fun x => f (f x)) (f a)
  end.

Definition ntimes {A} (n : N) (f : A -> A) (a : A) :=
  match n with
  | N0 => a
  | Npos p => ntimes' p f a
  end.

Compute ntimes 10000 (fun x => x + 1) 0.

Fixpoint insert (l : list N) (new : N) :=
  match l with
  | nil => [new]
  | (h :: t) => if h <=? new then new :: h :: t else h :: insert t new
  end.

Fixpoint sort (l : list N) :=
  match l with
  | nil => nil
  | (h :: t) => insert (sort t) h
  end.

Definition impl_2 (l : list monkey) :=
  let mb := snd (ntimes 10000 round (l,repeat 0 (length l))) in
  match sort mb with
  | nil => 0
  | [_] => 0
  | a :: b :: _ => a * b
  end.

End Part2.
Example test1 : impl_1 test_in = 10605. Proof. vm_compute. reflexivity. Qed.

Compute impl_1 input.

Example test2 : impl_2 test_in = 2713310158. Proof. vm_compute. reflexivity. Qed.

Compute impl_2 input.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Cons : natural -> lst -> lst | Nil : lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite append_assoc.
      rewrite IHx. rewrite append_assoc. simpl. reflexivity.
   - intros. simpl. lfind. Admitted.


Require Import List.
Require Import Peano_dec.

Import ListNotations.

(* Abstract syntax for 'calculus of inductive constructions'.                   *)
Inductive Exp : Type :=
| EProp : Exp                               (* sort 'Prop'                      *)
| ESet  : Exp                               (* sort 'Set'                       *)
| EType : nat -> Exp                        (* sort 'Type(n)'                   *)
| EVar  : nat -> Exp                        (* variables                        *)
| ECon  : nat -> Exp                        (* constants                        *)
| EProd : nat -> Exp -> Exp -> Exp          (* forall (x:T), U                  *)
| ELam  : nat -> Exp -> Exp -> Exp          (* fun (x:T) => U                   *)
| EApp  : Exp -> Exp -> Exp                 (* application                      *)
| ELet  : nat -> Exp -> Exp -> Exp -> Exp   (* let x:=(t:T) in U                *)
.

(* xs represents the list of variables which are deemed 'bound'                 *)
Definition h_ (f:nat -> Exp) (xs:list nat) (x:nat) : Exp :=
    match in_dec eq_nat_dec x xs with
    | left  _   => EVar x                   (* x is deemed bound                *)
    | right _   => f x                      (* x is deemed free                 *)
    end.

(* Unsure whether xs or (n :: xs) for 'T' in say 'forall (n:T), U'              *)
Fixpoint subst_ (f:nat -> Exp) (t:Exp) (xs:list nat) : Exp :=
    match t with
    | EProp         => EProp
    | ESet          => ESet
    | EType n       => EType n
    | EVar  n       => h_ f xs n
    | ECon  n       => ECon n
    | EProd n T U   => EProd n (subst_ f T xs) (subst_ f U (n :: xs))
    | ELam  n T U   => ELam  n (subst_ f T xs) (subst_ f U (n :: xs))
    | EApp t1 t2    => EApp (subst_ f t1 xs) (subst_ f t2 xs)
    | ELet n t T U  => ELet n (subst_ f t xs)(subst_ f T xs)(subst_ f U (n::xs))
    end.

(* Does not avoid variable capture so inappropriate in current form.            *)
Definition subst (f:nat -> Exp) (t:Exp) : Exp := subst_ f t [].

Definition replace (x:nat) (t:Exp) (u:nat) : Exp :=
    match eq_nat_dec u x with
    | left  _   => t        (* if u = x  return t   *)
    | right _   => EVar u   (* otherwise return u   *)
    end.

(* substituting term t in place of variable x in term s                         *)
Definition Sub (s t:Exp) (n:nat) : Exp := subst (replace n t) s.

(* Whether a term is a 'sort' or not. Needed to defined typing rules.           *)
Inductive isSort : Exp -> Prop :=
| SortProp : isSort EProp
| SortSet  : isSort ESet
| SortType : forall (n:nat), isSort (EType n)
.

(* Type for 'local declarations' of 'variables'                                 *)
Inductive LocalDecl : Type :=
| LAssume : nat -> Exp -> LocalDecl         (* n:T , T is a type                *)
| LDefine : nat -> Exp -> Exp -> LocalDecl  (* n := (t:T)                       *)
.

(* Variable involved must be distinct                                           *)
Definition LocalContext : Type := list LocalDecl.

(* Whether a variable n is declared in the local context C.                     *)
Fixpoint inCtxVar (n:nat) (C:LocalContext) : Prop :=
    match C with
    | []        => False
    | d :: C'   =>
        match d with
        | LAssume m _   => (n = m) \/ inCtxVar n C'
        | LDefine m _ _ => (n = m) \/ inCtxVar n C'
        end
    end.

(* Whether a declaration is present in the local context C.                     *)
Fixpoint inCtxDecl (n:nat) (T:Exp) (C:LocalContext) : Prop :=
    match C with
    | []        => False
    | d :: C'   =>
        match d with
        | LAssume n' T'     => ((n = n') /\ (T = T')) \/ inCtxDecl n T C'
        | LDefine n' _ T'   => ((n = n') /\ (T = T')) \/ inCtxDecl n T C'
        end
    end.

(* Type for 'global declarations' of 'constants'                                *)
Inductive GlobalDecl : Type :=
| GAssume : nat -> Exp -> GlobalDecl        (* c:T, T is a type                 *)
| GDefine : nat -> Exp -> Exp -> GlobalDecl (* c := t : T                       *)
| GInduct : nat -> GlobalDecl               (* TBT, define inductive objects    *)
.

Definition GlobalEnv : Type := list GlobalDecl.

(* Whether a constant n is declared in the global environment E.                *)
Fixpoint inEnvConst (n:nat) (E:GlobalEnv) : Prop :=
    match E with
    | []        => False
    | d :: E'   =>
        match d with
        | GAssume m _   => (n = m) \/ inEnvConst n E'
        | GDefine m _ _ => (n = m) \/ inEnvConst n E'
        | GInduct m     => (n = m) \/ inEnvConst n E'
        end
    end.

(* Whether a declaration is present in the global environment E.                *)
Fixpoint inEnvDecl (n:nat) (T:Exp) (E:GlobalEnv) : Prop :=
    match E with
    | []        => False
    | d :: E'   =>
        match d with
        | GAssume n' T'     => ((n = n') /\ (T = T')) \/ inEnvDecl n T E'
        | GDefine n' _ T'   => ((n = n') /\ (T = T')) \/ inEnvDecl n T E'
        | GInduct _         => inEnvDecl n T E'
        end
    end.

(* Judgement: E[C] |- t:T                                                       *)
(* t is well-typed and has type T in the global env E and local context C       *)

(* Judgement: WF(E)[C]                                                          *)
(* The global env E is well-formed and the local context C is valid in E        *)

(* Definition: t is well-typed in E, iff there exists a local context C         *)
(* and a term T such that E[C] |- t:T can be derived from typing rules          *)

Inductive Entails : GlobalEnv -> LocalContext -> Exp -> Exp -> Prop :=
| AxProp: forall E C,
    WF E C                                  ->  (* WF(E)[C]                     *)
    Entails E C EProp (EType 1)                 (* E[C] |- Prop:Type(1)         *)
| AxSet: forall E C,
    WF E C                                  ->  (* WF(E)[C]                     *)
    Entails E C ESet (EType 1)                  (* E[C] |- Set:Type(1)          *)
| AxType: forall E C n,
    WF E C                                  ->  (* WF(E)[C]                     *)
    Entails E C (EType n) (EType (S n))         (* E[C] |- Type(n):Type(n+1)    *)
| Var: forall E C T n,
    WF E C                                  ->  (* WF(E)[C]                     *)
    inCtxDecl n T C                         ->  (* n:T or n := t:T (some t) in C*)
    Entails E C (EVar n) T                      (* E[C] |- n:T                  *)
| Con: forall E C T n,
    WF E C                                  ->  (* WF(E)[C]                     *)
    inEnvDecl n T E                         ->  (* n:T or n := t:T (some t) in E*)
    Entails E C (ECon n) T                      (* E[C] |- n:T                  *)
| ProdProp: forall E C T s n U,
    Entails E C T s                         ->  (* E[C] |- T:s                  *)
    isSort s                                ->  (* s is Prop, Set or Type(n)    *)
    Entails E ((LAssume n T) :: C) U EProp  ->  (* E[(n:T) :: C] |- U:Prop      *)
    Entails E C (EProd n T U) EProp             (* E[C] |- A(n:T),U  :Prop      *)
| ProdSet: forall E C T s n U,
    Entails E C T s                         ->  (* E[C] |- T:s                  *)
    (s = EProp \/ s = ESet)                 ->  (* s is Prop or Set             *)
    Entails E ((LAssume n T) :: C) U ESet   ->  (* E[(n:T) :: C] |- U:Set       *)
    Entails E C (EProd n T U) ESet              (* E[C] |- A(n:T),U  :Set       *)
| ProdType: forall E C T i n U,
    Entails E C T (EType i)                 ->  (* E[C] |- T:Type(i)            *)
    Entails E ((LAssume n T)::C) U (EType i)->  (* E[(n:T) :: C] |- U:Type(i)   *)
    Entails E C (EProd n T U) (EType i)         (* E[C] |- A(n:T),U  :Set       *)
| Lam: forall E C n T U s t,
    Entails E C (EProd n T U) s             ->
    Entails E ((LAssume n T)::C) t U        ->
    Entails E C (ELam n T t) (EProd n T U)
| App: forall E C t n U T u,
    Entails E C t (EProd n U T)             ->  (* E[C] |- t:A(n:U),T           *)
    Entails E C u U                         ->  (* E[C] |- u:U                  *)
    Entails E C (EApp t u) (Sub T u n)          (* E[C] |- (t u):T[u/n]         *)
| Let : forall E C t T n u U,
    Entails E C t T                         ->  (* E[C] |- t:T                  *)
    Entails E ((LDefine n t T)::C) u U      ->  (* E[(n := t:T)::C] |- u:U      *)
    Entails E C (ELet n t T u) (Sub U t n)      (* E[C] |- (let (n:=t:T) in u)  *)
                                                (*         : U[t/n]             *)
with WF : GlobalEnv -> LocalContext -> Prop :=
| WEmpty: WF [] []
| WLocalAssume: forall E C T s n,
    Entails E C T s                         ->  (* E[C] |- T:s                  *)
    isSort s                                ->  (* s is Prop, Set or Type(n)    *)
    ~ inCtxVar n C                          ->  (* Var n not already in C       *)
    WF E ((LAssume n T) :: C)                   (* WF(E)[ (n:T) :: C]           *)
| WLocalDef: forall E C t T n,
    Entails E C t T                         ->  (* E[C] |- t:T                  *)
    ~ inCtxVar n C                          ->  (* Var n not already in C       *)
    WF E ((LDefine n t T) :: C)                 (* WF(E)[ (n := t:T) :: C ]     *)
| WGlobalAssume: forall E T s n,
    Entails E [] T s                        ->  (* E[[]] |- T:s                 *)
    isSort s                                ->  (* s is Prop, Set or Type(n)    *)
    ~ inEnvConst n E                        ->  (* Const n not already in E     *)
    WF ((GAssume n T) :: E) []                  (* WF((n:T) :: E)[]             *)
| WGlobalDef: forall E t T n,
    Entails E [] t T                        ->  (* E[[]] |- t:T                 *)
    ~ inEnvConst n E                        ->  (* Const n not already in E     *)
    WF ((GDefine n t T) :: E) []                (* WF((n := t:T) :: E)[]        *)
.


(** * Gen: Generalizing Induction Hypotheses *)

(* $Date: 2011-06-07 16:49:17 -0400 (Tue, 07 Jun 2011) $ *)

Require Export Poly.

(** In the previous chapter, we saw a proof that the [double] function
    is injective.  The way we _start_ this proof is a little bit
    delicate: if we begin it with
[[
      intros n. induction n.
]]
    all is well.  But if we begin it with
[[
      intros n m. induction n.
]]
    we get stuck in the middle of the inductive case... *)

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = O". simpl. intros eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros eq. destruct m as [| m'].
    SCase "m = O". inversion eq.
    SCase "m = S m'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
      (* Here we are stuck.  We need the assertion in order to
         rewrite the final goal (subgoal 2 at this point) to an
         identity.  But the induction hypothesis, [IHn'], does
         not give us [n' = m'] -- there is an extra [S] in the
         way -- so the assertion is not provable. *)
      Admitted.

(** What went wrong here?

    The problem is that, at the point we invoke the induction
    hypothesis, we have already introduced [m] into the context
    -- intuitively, we have told Coq, "Let's consider some particular
    [n] and [m]..." and we now have to prove that, if [double n =
    double m] for _this particular_ [n] and [m], then [n = m].

    The next tactic, [induction n] says to Coq: We are going to show
    the goal by induction on [n].  That is, we are going to prove that
    the proposition

      - [P n]  =  "if [double n = double m], then [n = m]"

    holds for all [n] by showing

      - [P O]

         (i.e., "if [double O = double m] then [O = m]")

      - [P n -> P (S n)]

        (i.e., "if [double n = double m] then [n = m]" implies "if
        [double (S n) = double m] then [S n = m]").

    If we look closely at the second statement, it is saying something
    rather strange: it says that, for a _particular_ [m], if we know

      - "if [double n = double m] then [n = m]"

    then we can prove

       - "if [double (S n) = double m] then [S n = m]".

    To see why this is strange, let's think of a particular [m] --
    say, [5].  The statement is then saying that, if we can prove

      - [Q] = "if [double n = 10] then [n = 5]"

    then we can prove

      - [R] = "if [double (S n) = 10] then [S n = 5]".

    But knowing [Q] doesn't give us any help with proving [R]!  (If we
    tried to prove [R] from [Q], we would say something like "Suppose
    [double (S n) = 10]..." but then we'd be stuck: knowing that
    [double (S n)] is [10] tells us nothing about whether [double n]
    is [10], so [Q] is useless at this point.)

    To summarize: Trying to carry out this proof by induction on [n]
    when [m] is already in the context doesn't work because we are
    trying to prove a relation involving _every_ [n] but just a
    _single_ [m]. *)

(** The good proof of [double_injective] leaves [m] in the goal
    statement at the point where the [induction] tactic is invoked on
    [n]: *)

Theorem double_injective' : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = O". simpl. intros m eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'".
    (* Notice that both the goal and the induction
       hypothesis have changed: the goal asks us to prove
       something more general (i.e., to prove the
       statement for *every* [m]), but the IH is
       correspondingly more flexible, allowing us to
       choose any [m] we like when we apply the IH.  *)
    intros m eq.
    (* Now we choose a particular [m] and introduce the
       assumption that [double n = double m].  Since we
       are doing a case analysis on [n], we need a case
       analysis on [m] to keep the two "in sync." *)
    destruct m as [| m'].
    SCase "m = O". inversion eq.  (* The 0 case is trivial *)
    SCase "m = S m'".
      (* At this point, since we are in the second
         branch of the [destruct m], the [m'] mentioned
         in the context at this point is actually the
         predecessor of the one we started out talking
         about.  Since we are also in the [S] branch of
         the induction, this is perfect: if we
         instantiate the generic [m] in the IH with the
         [m'] that we are talking about right now (this
         instantiation is performed automatically by
         [apply]), then [IHn'] gives us exactly what we
         need to finish the proof. *)
      assert (n' = m') as H.
      SSCase "Proof of assertion". apply IHn'.
        inversion eq. reflexivity.
      rewrite -> H. reflexivity.  Qed.

(** So what we've learned is that we need to be careful about
    using induction to try to prove something too specific: If
    we're proving a property of [n] and [m] by induction on [n],
    we may need to leave [m] generic.

    However, this strategy doesn't always apply directly;
    sometimes a little rearrangement is needed.  Suppose, for
    example, that we had decided we wanted to prove
    [double_injective] by induction on [m] instead of [n]. *)

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  Case "m = O". simpl. intros eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        (* Here we are stuck again, just like before. *)
Admitted.

(** The problem is that, to do induction on [m], we must first
    introduce [n].  (If we simply say [induction m] without
    introducing anything first, Coq will automatically introduce
    [n] for us!)  What can we do about this?

    One possibility is to rewrite the statement of the lemma so
    that [m] is quantified before [n].  This will work, but it's
    not nice: We don't want to have to mangle the statements of
    lemmas to fit the needs of a particular strategy for proving
    them -- we want to state them in the most clear and natural
    way.

    What we can do instead is to first introduce all the
    quantified variables and then _re-generalize_ one or more of
    them, taking them out of the context and putting them back at
    the beginning of the goal.  The [generalize dependent] tactic
    does this. *)

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* [n] and [m] are both in the context *)
  generalize dependent n.
  (* Now [n] is back in the goal and we can do induction on
     [m] and get a sufficiently general IH. *)
  induction m as [| m'].
  Case "m = O". simpl. intros n eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros n eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        apply IHm'. inversion eq. reflexivity.
      rewrite -> H. reflexivity.  Qed.

(** Let's look at an informal proof of this theorem.  Note that the
    proposition we prove by induction leaves [n] quantified,
    corresponding to the use of generalize dependent in our formal
    proof.

_Theorem_: For any nats [n] and [m], if [double n = double m], then
  [n = m].

_Proof_: Let [m] be a [nat]. We prove by induction on [m] that, for
  any [n], if [double n = double m] then [n = m].

  - First, suppose [m = 0], and suppose [n] is a number such
    that [double n = double m].  We must show that [n = 0].

    Since [m = 0], by the definition of [double] we have [double n =
    0].  There are two cases to consider for [n].  If [n = 0] we are
    done, since this is what we wanted to show.  Otherwise, if [n = S
    n'] for some [n'], we derive a contradiction: by the definition of
    [double] we would have [n = S (S (double n'))], but this
    contradicts the assumption that [double n = 0].

  - Otherwise, suppose [m = S m'] and that [n] is again a number such
    that [double n = double m].  We must show that [n = S m'], with
    the induction hypothesis that for every number [s], if [double s =
    double m'] then [s = m'].

    By the fact that [m = S m'] and the definition of [double], we
    have [double n = S (S (double m'))].  There are two cases to
    consider for [n].

    If [n = 0], then by definition [double n = 0], a contradiction.
    Thus, we may assume that [n = S n'] for some [n'], and again by
    the definition of [double] we have [S (S (double n')) = S (S
    (double m'))], which implies by inversion that [double n' = double
    m'].

    Instantiating the induction hypothesis with [n'] thus allows us to
    conclude that [n' = m'], and it follows immediately that [S n' = S
    m'].  Since [S n' = n] and [S m' = m], this is just what we wanted
    to show. [] *)

(** **** Exercise: 3 stars (gen_dep_practice) *)
(** Carry out this proof by induction on [m]. *)

Theorem plus_n_n_injective_take2 : forall n m,
     n + n = m + m ->
     n = m.
Proof.
intros n m.
generalize dependent n.
induction m.
destruct n.
simpl.
reflexivity.
intros.
inversion H.
intros.
destruct n.
inversion H.
simpl in *.
repeat rewrite <- plus_n_Sm in *.
inversion H.
apply (IHm n) in H1.
rewrite -> H1.
reflexivity.
Qed.

(** Now prove this by induction on [l]. *)

Theorem index_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     index (S n) l = None.
Proof.
intros.
generalize dependent n.
induction l.
reflexivity.
intros.
destruct n.
inversion H.
simpl.
apply IHl.
inversion H.
reflexivity.
Qed.

(** [] *)

(** **** Exercise: 3 stars, optional (index_after_last_informal) *)
(** Write an informal proof corresponding to your Coq proof
    of [index_after_last]:

     _Theorem_: For all sets [X], lists [l : list X], and numbers
      [n], if [length l = n] then [index (S n) l = None].

     _Proof_:
     (* FILL IN HERE *)
[]
*)

(** **** Exercise: 3 stars, optional (gen_dep_practice_opt) *)
(** Prove this by induction on [l]. *)

Theorem length_snoc''' : forall (n : nat) (X : Type)
                              (v : X) (l : list X),
     length l = n ->
     length (snoc l v) = S n.
Proof.
intros.
generalize dependent n.
induction l.
intros.
destruct n.
reflexivity.
simpl in *.
inversion H.
intros.
simpl in *.
destruct n.
inversion H.
inversion H.
apply (IHl n) in H1.
rewrite H.
rewrite H1.
reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (app_length_cons) *)
(** Prove this by induction on [l1], without using [app_length]. *)

Theorem app_length_cons : forall (X : Type) (l1 l2 : list X)
                                  (x : X) (n : nat),
     length (l1 ++ (x :: l2)) = n ->
     S (length (l1 ++ l2)) = n.
Proof.
intros.
generalize dependent n.
induction l1.
intros.
Case "l=[]".
simpl in *.
assumption.
simpl in *.
Case "l= x::y".
intros.
destruct n.
inversion H.
apply eq_remove_S.
apply IHl1.
inversion H.
reflexivity.
Qed.

(** [] *)

(** **** Exercise: 4 stars, optional (app_length_twice) *)
(** Prove this by induction on [l], without using app_length. *)

Theorem app_length_twice2 : forall (X:Type) (n:nat) (l:list X),
     length l = n ->
     length (l ++ l) = n + n.
Proof.
intros.
generalize dependent n.
induction l.
intros.
simpl in *.
rewrite <- H.
reflexivity.
intros.
destruct n.
simpl in  *.
inversion H.
simpl in *.
repeat rewrite <- plus_n_Sm in *.
assert (length (l ++ l) = n + n).
apply IHl.
inversion H.
reflexivity.
rewrite <- H0.
inversion H.
apply eq_remove_S.
inversion H.
Admitted.

Theorem app_length_twice : forall (X:Type) (n:nat) (l:list X),
     length l = n ->
     length (l ++ l) = n + n.
Proof.
 intros X n l.
 generalize dependent n.
 induction l as [|x l'].
 Case "l = []".
   simpl.
   intros n H.
   rewrite <- H.
   reflexivity.
 Case "l = x :: l'".
   rewrite -> length_app_S.
   simpl in *.
   intros n H.
   rewrite <- H.
   rewrite <- plus_n_Sm.
   rewrite <- plus_comm.
   rewrite <- plus_n_Sm.
   f_equal. f_equal.
   erewrite IHl' with (n := pred n).
   destruct n ; inversion H. simpl.
   reflexivity. destruct n.
   inversion H. simpl. inversion H.
   reflexivity.
Qed.

(** [] *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O P U V : Universe, ((wd_ U O /\ (wd_ V O /\ (wd_ P U /\ (wd_ P O /\ (col_ O P V /\ col_ O U V))))) -> col_ P U O)).
Proof.
  time tac.
Qed.

End FOFProblem.


From stdpp Require Export countable vector.
From stdpp Require Import options.

Class Finite A `{EqDecision A} := {
  enum : list A;
  (* [NoDup] makes it easy to define the cardinality of the type. *)
  NoDup_enum : NoDup enum;
  elem_of_enum x : x ∈ enum
}.
Global Hint Mode Finite ! - : typeclass_instances.
Global Arguments enum : clear implicits.
Global Arguments enum _ {_ _} : assert.
Global Arguments NoDup_enum : clear implicits.
Global Arguments NoDup_enum _ {_ _} : assert.
Definition card A `{Finite A} := length (enum A).

Program Definition finite_countable `{Finite A} : Countable A := {|
  encode := λ x,
    Pos.of_nat $ S $ default 0 $ fst <$> list_find (x =.) (enum A);
  decode := λ p, enum A !! pred (Pos.to_nat p)
|}.
Next Obligation.
  intros ?? [xs Hxs HA] x; unfold encode, decode; simpl.
  destruct (list_find_elem_of (x =.) xs x) as [[i y] Hi]; auto.
  rewrite Nat2Pos.id by done; simpl; rewrite Hi; simpl.
  destruct (list_find_Some (x =.) xs i y); naive_solver.
Qed.
Global Hint Immediate finite_countable : typeclass_instances.

Definition find `{Finite A} (P : A → Prop) `{∀ x, Decision (P x)} : option A :=
  list_find P (enum A) ≫= decode_nat ∘ fst.

Lemma encode_lt_card `{finA: Finite A} (x : A) : encode_nat x < card A.
Proof.
  destruct finA as [xs Hxs HA]; unfold encode_nat, encode, card; simpl.
  rewrite Nat2Pos.id by done; simpl.
  destruct (list_find _ xs) as [[i y]|] eqn:HE; simpl.
  - apply list_find_Some in HE as (?&?&?); eauto using lookup_lt_Some.
  - destruct xs; simpl; [|lia].
    exfalso; eapply not_elem_of_nil, (HA x).
Qed.
Lemma encode_decode A `{finA: Finite A} i :
  i < card A → ∃ x : A, decode_nat i = Some x ∧ encode_nat x = i.
Proof.
  destruct finA as [xs Hxs HA].
  unfold encode_nat, decode_nat, encode, decode, card; simpl.
  intros Hi. apply lookup_lt_is_Some in Hi. destruct Hi as [x Hx].
  exists x. rewrite !Nat2Pos.id by done; simpl.
  destruct (list_find_elem_of (x =.) xs x) as [[j y] Hj]; auto.
  split; [done|]; rewrite Hj; simpl.
  apply list_find_Some in Hj as (?&->&?). eauto using NoDup_lookup.
Qed.
Lemma find_Some `{finA: Finite A} (P : A → Prop) `{∀ x, Decision (P x)} (x : A) :
  find P = Some x → P x.
Proof.
  destruct finA as [xs Hxs HA]; unfold find, decode_nat, decode; simpl.
  intros Hx. destruct (list_find _ _) as [[i y]|] eqn:Hi; simplify_eq/=.
  rewrite !Nat2Pos.id in Hx by done.
  destruct (list_find_Some P xs i y); naive_solver.
Qed.
Lemma find_is_Some `{finA: Finite A} (P : A → Prop) `{∀ x, Decision (P x)} (x : A) :
  P x → ∃ y, find P = Some y ∧ P y.
Proof.
  destruct finA as [xs Hxs HA]; unfold find, decode; simpl.
  intros Hx. destruct (list_find_elem_of P xs x) as [[i y] Hi]; auto.
  rewrite Hi; unfold decode_nat, decode; simpl. rewrite !Nat2Pos.id by done.
  simpl. apply list_find_Some in Hi; naive_solver.
Qed.

Definition encode_fin `{Finite A} (x : A) : fin (card A) :=
  Fin.of_nat_lt (encode_lt_card x).
Program Definition decode_fin `{Finite A} (i : fin (card A)) : A :=
  match Some_dec (decode_nat i) return _ with
  | inleft (x ↾ _) => x | inright _ => _
  end.
Next Obligation.
  intros A ?? i ?; exfalso.
  destruct (encode_decode A i); naive_solver auto using fin_to_nat_lt.
Qed.
Lemma decode_encode_fin `{Finite A} (x : A) : decode_fin (encode_fin x) = x.
Proof.
  unfold decode_fin, encode_fin. destruct (Some_dec _) as [[x' Hx]|Hx].
  { by rewrite fin_to_nat_to_fin, decode_encode_nat in Hx; simplify_eq. }
  exfalso; by rewrite ->fin_to_nat_to_fin, decode_encode_nat in Hx.
Qed.

Lemma fin_choice {n} {B : fin n → Type} (P : ∀ i, B i → Prop) :
  (∀ i, ∃ y, P i y) → ∃ f, ∀ i, P i (f i).
Proof.
  induction n as [|n IH]; intros Hex.
  { exists (fin_0_inv _); intros i; inv_fin i. }
  destruct (IH _ _ (λ i, Hex (FS i))) as [f Hf], (Hex 0%fin) as [y Hy].
  exists (fin_S_inv _ y f); intros i; by inv_fin i.
Qed.
Lemma finite_choice `{Finite A} {B : A → Type} (P : ∀ x, B x → Prop) :
  (∀ x, ∃ y, P x y) → ∃ f, ∀ x, P x (f x).
Proof.
  intros Hex. destruct (fin_choice _ (λ i, Hex (decode_fin i))) as [f ?].
  exists (λ x, eq_rect _ _ (f(encode_fin x)) _ (decode_encode_fin x)); intros x.
  destruct (decode_encode_fin x); simpl; auto.
Qed.

Lemma card_0_inv P `{finA: Finite A} : card A = 0 → A → P.
Proof.
  intros ? x. destruct finA as [[|??] ??]; simplify_eq.
  by destruct (not_elem_of_nil x).
Qed.
Lemma finite_inhabited A `{finA: Finite A} : 0 < card A → Inhabited A.
Proof.
  unfold card; intros. destruct finA as [[|x ?] ??]; simpl in *; [exfalso;lia|].
  constructor; exact x.
Qed.
Lemma finite_inj_submseteq `{finA: Finite A} `{finB: Finite B} (f: A → B)
  `{!Inj (=) (=) f} : f <$> enum A ⊆+ enum B.
Proof.
  intros. destruct finA, finB. apply NoDup_submseteq; auto using NoDup_fmap_2.
Qed.
Lemma finite_inj_Permutation `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A = card B → f <$> enum A ≡ₚ enum B.
Proof.
  intros. apply submseteq_Permutation_length_eq.
  - by rewrite fmap_length.
  - by apply finite_inj_submseteq.
Qed.
Lemma finite_inj_surj `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A = card B → Surj (=) f.
Proof.
  intros HAB y. destruct (elem_of_list_fmap_2 f (enum A) y) as (x&?&?); eauto.
  rewrite finite_inj_Permutation; auto using elem_of_enum.
Qed.

Lemma finite_surj A `{Finite A} B `{Finite B} :
  0 < card A ≤ card B → ∃ g : B → A, Surj (=) g.
Proof.
  intros [??]. destruct (finite_inhabited A) as [x']; auto with lia.
  exists (λ y : B, default x' (decode_nat (encode_nat y))).
  intros x. destruct (encode_decode B (encode_nat x)) as (y&Hy1&Hy2).
  { pose proof (encode_lt_card x); lia. }
  exists y. by rewrite Hy2, decode_encode_nat.
Qed.
Lemma finite_inj A `{Finite A} B `{Finite B} :
  card A ≤ card B ↔ ∃ f : A → B, Inj (=) (=) f.
Proof.
  split.
  - intros. destruct (decide (card A = 0)) as [HA|?].
    { exists (card_0_inv B HA). intros y. apply (card_0_inv _ HA y). }
    destruct (finite_surj A B) as (g&?); auto with lia.
    destruct (surj_cancel g) as (f&?). exists f. apply cancel_inj.
  - intros [f ?]. unfold card. rewrite <-(fmap_length f).
    by apply submseteq_length, (finite_inj_submseteq f).
Qed.
Lemma finite_bijective A `{Finite A} B `{Finite B} :
  card A = card B ↔ ∃ f : A → B, Inj (=) (=) f ∧ Surj (=) f.
Proof.
  split.
  - intros; destruct (proj1 (finite_inj A B)) as [f ?]; auto with lia.
    exists f; split; [done|]. by apply finite_inj_surj.
  - intros (f&?&?). apply (anti_symm (≤)); apply finite_inj.
    + by exists f.
    + destruct (surj_cancel f) as (g&?). exists g. apply cancel_inj.
Qed.
Lemma inj_card `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A ≤ card B.
Proof. apply finite_inj. eauto. Qed.
Lemma surj_card `{Finite A} `{Finite B} (f : A → B)
  `{!Surj (=) f} : card B ≤ card A.
Proof.
  destruct (surj_cancel f) as (g&?).
  apply inj_card with g, cancel_inj.
Qed.
Lemma bijective_card `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} `{!Surj (=) f} : card A = card B.
Proof. apply finite_bijective. eauto. Qed.

(** Decidability of quantification over finite types *)
Section forall_exists.
  Context `{Finite A} (P : A → Prop).

  Lemma Forall_finite : Forall P (enum A) ↔ (∀ x, P x).
  Proof. rewrite Forall_forall. intuition auto using elem_of_enum. Qed.
  Lemma Exists_finite : Exists P (enum A) ↔ (∃ x, P x).
  Proof. rewrite Exists_exists. naive_solver eauto using elem_of_enum. Qed.

  Context `{∀ x, Decision (P x)}.

  Global Instance forall_dec: Decision (∀ x, P x).
  Proof using Type*.
   refine (cast_if (decide (Forall P (enum A))));
    abstract by rewrite <-Forall_finite.
  Defined.
  Global Instance exists_dec: Decision (∃ x, P x).
  Proof using Type*.
   refine (cast_if (decide (Exists P (enum A))));
    abstract by rewrite <-Exists_finite.
  Defined.
End forall_exists.

(** Instances *)
Section enc_finite.
  Context `{EqDecision A}.
  Context (to_nat : A → nat) (of_nat : nat → A) (c : nat).
  Context (of_to_nat : ∀ x, of_nat (to_nat x) = x).
  Context (to_nat_c : ∀ x, to_nat x < c).
  Context (to_of_nat : ∀ i, i < c → to_nat (of_nat i) = i).

  Local Program Instance enc_finite : Finite A := {| enum := of_nat <$> seq 0 c |}.
  Next Obligation.
    apply NoDup_alt. intros i j x. rewrite !list_lookup_fmap. intros Hi Hj.
    destruct (seq _ _ !! i) as [i'|] eqn:Hi',
      (seq _ _ !! j) as [j'|] eqn:Hj'; simplify_eq/=.
    apply lookup_seq in Hi' as  [-> ?]. apply lookup_seq in Hj' as [-> ?].
    rewrite <-(to_of_nat i), <-(to_of_nat j) by done. by f_equal.
  Qed.
  Next Obligation.
    intros x. rewrite elem_of_list_fmap. exists (to_nat x).
    split; auto. by apply elem_of_list_lookup_2 with (to_nat x), lookup_seq.
  Qed.
  Lemma enc_finite_card : card A = c.
  Proof. unfold card. simpl. by rewrite fmap_length, seq_length. Qed.
End enc_finite.

Section surjective_finite.
  Context `{Finite A, EqDecision B} (f : A → B).
  Context `{!Surj (=) f}.

  Program Definition surjective_finite: Finite B :=
    {| enum := remove_dups (f <$> enum A) |}.
  Next Obligation. apply NoDup_remove_dups. Qed.
  Next Obligation.
    intros y. rewrite elem_of_remove_dups, elem_of_list_fmap.
    destruct (surj f y). eauto using elem_of_enum.
  Qed.
End surjective_finite.

Section bijective_finite.
  Context `{Finite A, EqDecision B} (f : A → B) (g : B → A).
  Context `{!Inj (=) (=) f, !Cancel (=) f g}.

  Definition bijective_finite : Finite B :=
    let _ := cancel_surj (f:=f) (g:=g) in
    surjective_finite f.
End bijective_finite.

Global Program Instance option_finite `{Finite A} : Finite (option A) :=
  {| enum := None :: (Some <$> enum A) |}.
Next Obligation.
  constructor.
  - rewrite elem_of_list_fmap. by intros (?&?&?).
  - apply (NoDup_fmap_2 _); auto using NoDup_enum.
Qed.
Next Obligation.
  intros ??? [x|]; [right|left]; auto.
  apply elem_of_list_fmap. eauto using elem_of_enum.
Qed.
Lemma option_cardinality `{Finite A} : card (option A) = S (card A).
Proof. unfold card. simpl. by rewrite fmap_length. Qed.

Global Program Instance Empty_set_finite : Finite Empty_set := {| enum := [] |}.
Next Obligation. by apply NoDup_nil. Qed.
Next Obligation. intros []. Qed.
Lemma Empty_set_card : card Empty_set = 0.
Proof. done. Qed.

Global Program Instance unit_finite : Finite () := {| enum := [tt] |}.
Next Obligation. apply NoDup_singleton. Qed.
Next Obligation. intros []. by apply elem_of_list_singleton. Qed.
Lemma unit_card : card unit = 1.
Proof. done. Qed.

Global Program Instance bool_finite : Finite bool := {| enum := [true; false] |}.
Next Obligation.
  constructor; [ by rewrite elem_of_list_singleton | apply NoDup_singleton ].
Qed.
Next Obligation. intros [|]; [ left | right; left ]. Qed.
Lemma bool_card : card bool = 2.
Proof. done. Qed.

Global Program Instance sum_finite `{Finite A, Finite B} : Finite (A + B)%type :=
  {| enum := (inl <$> enum A) ++ (inr <$> enum B) |}.
Next Obligation.
  intros. apply NoDup_app; split_and?.
  - apply (NoDup_fmap_2 _). by apply NoDup_enum.
  - intro. rewrite !elem_of_list_fmap. intros (?&?&?) (?&?&?); congruence.
  - apply (NoDup_fmap_2 _). by apply NoDup_enum.
Qed.
Next Obligation.
  intros ?????? [x|y]; rewrite elem_of_app, !elem_of_list_fmap;
    [left|right]; (eexists; split; [done|apply elem_of_enum]).
Qed.
Lemma sum_card `{Finite A, Finite B} : card (A + B) = card A + card B.
Proof. unfold card. simpl. by rewrite app_length, !fmap_length. Qed.

Global Program Instance prod_finite `{Finite A, Finite B} : Finite (A * B)%type :=
  {| enum := foldr (λ x, (pair x <$> enum B ++.)) [] (enum A) |}.
Next Obligation.
  intros A ?????. induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl.
  { constructor. }
  apply NoDup_app; split_and?.
  - by apply (NoDup_fmap_2 _), NoDup_enum.
  - intros [? y]. rewrite elem_of_list_fmap. intros (?&?&?); simplify_eq.
    clear IH. induction Hxs as [|x' xs ?? IH]; simpl.
    { rewrite elem_of_nil. tauto. }
    rewrite elem_of_app, elem_of_list_fmap.
    intros [(?&?&?)|?]; simplify_eq.
    + destruct Hx. by left.
    + destruct IH; [ | by auto ]. by intro; destruct Hx; right.
  - done.
Qed.
Next Obligation.
  intros ?????? [x y]. induction (elem_of_enum x); simpl.
  - rewrite elem_of_app, !elem_of_list_fmap. eauto using elem_of_enum.
  - rewrite elem_of_app; eauto.
Qed.
Lemma prod_card `{Finite A} `{Finite B} : card (A * B) = card A * card B.
Proof.
  unfold card; simpl. induction (enum A); simpl; auto.
  rewrite app_length, fmap_length. auto.
Qed.

Definition list_enum {A} (l : list A) : ∀ n, list { l : list A | length l = n } :=
  fix go n :=
  match n with
  | 0 => [[]↾eq_refl]
  | S n => foldr (λ x, (sig_map (x ::.) (λ _ H, f_equal S H) <$> (go n) ++.)) [] l
  end.

Global Program Instance list_finite `{Finite A} n : Finite { l : list A | length l = n } :=
  {| enum := list_enum (enum A) n |}.
Next Obligation.
  intros A ?? n. induction n as [|n IH]; simpl; [apply NoDup_singleton |].
  revert IH. generalize (list_enum (enum A) n). intros l Hl.
  induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl; auto; [constructor |].
  apply NoDup_app; split_and?.
  - by apply (NoDup_fmap_2 _).
  - intros [k1 Hk1]. clear Hxs IH. rewrite elem_of_list_fmap.
    intros ([k2 Hk2]&?&?) Hxk2; simplify_eq/=. destruct Hx. revert Hxk2.
    induction xs as [|x' xs IH]; simpl in *; [by rewrite elem_of_nil |].
    rewrite elem_of_app, elem_of_list_fmap, elem_of_cons.
    intros [([??]&?&?)|?]; simplify_eq/=; auto.
  - apply IH.
Qed.
Next Obligation.
  intros A ?? n [l Hl]. revert l Hl.
  induction n as [|n IH]; intros [|x l] Hl; simpl; simplify_eq.
  { apply elem_of_list_singleton. by apply (sig_eq_pi _). }
  revert IH. generalize (list_enum (enum A) n). intros k Hk.
  induction (elem_of_enum x) as [x xs|x xs]; simpl in *.
  - rewrite elem_of_app, elem_of_list_fmap. left. injection Hl. intros Hl'.
    eexists (l↾Hl'). split; [|done]. by apply (sig_eq_pi _).
  - rewrite elem_of_app. eauto.
Qed.

Lemma list_card `{Finite A} n : card { l : list A | length l = n } = card A ^ n.
Proof.
  unfold card; simpl. induction n as [|n IH]; simpl; auto.
  rewrite <-IH. clear IH. generalize (list_enum (enum A) n).
  induction (enum A) as [|x xs IH]; intros l; simpl; auto.
  by rewrite app_length, fmap_length, IH.
Qed.

Fixpoint fin_enum (n : nat) : list (fin n) :=
  match n with 0 => [] | S n => 0%fin :: (FS <$> fin_enum n) end.
Global Program Instance fin_finite n : Finite (fin n) := {| enum := fin_enum n |}.
Next Obligation.
  intros n. induction n; simpl; constructor.
  - rewrite elem_of_list_fmap. by intros (?&?&?).
  - by apply (NoDup_fmap _).
Qed.
Next Obligation.
  intros n i. induction i as [|n i IH]; simpl;
    rewrite elem_of_cons, ?elem_of_list_fmap; eauto.
Qed.
Lemma fin_card n : card (fin n) = n.
Proof. unfold card; simpl. induction n; simpl; rewrite ?fmap_length; auto. Qed.

(* shouldn’t be an instance (cycle with [sig_finite]): *)
Lemma finite_sig_dec `{!EqDecision A} (P : A → Prop) `{Finite (sig P)} x :
  Decision (P x).
Proof.
  assert {xs : list A | ∀ x, P x ↔ x ∈ xs} as [xs ?].
  { clear x. exists (proj1_sig <$> enum _). intros x. split; intros Hx.
    - apply elem_of_list_fmap_1_alt with (x ↾ Hx); [apply elem_of_enum|]; done.
    - apply elem_of_list_fmap in Hx as [[x' Hx'] [-> _]]; done. }
  destruct (decide (x ∈ xs)); [left | right]; naive_solver.
Qed. (* <- could be Defined but this lemma will probably not be used for computing *)

Section sig_finite.
  Context {A} (P : A → Prop) `{∀ x, Decision (P x)}.

  Fixpoint list_filter_sig (l : list A) : list (sig P) :=
    match l with
    | [] => []
    | x :: l => match decide (P x) with
              | left H => x ↾ H :: list_filter_sig l
              | _ => list_filter_sig l
              end
    end.
  Lemma list_filter_sig_filter (l : list A) :
    proj1_sig <$> list_filter_sig l = filter P l.
  Proof.
    induction l as [| a l IH]; [done |].
    simpl; rewrite filter_cons.
    destruct (decide _); csimpl; by rewrite IH.
  Qed.

  Context `{Finite A} `{∀ x, ProofIrrel (P x)}.

  Global Program Instance sig_finite : Finite (sig P) :=
    {| enum := list_filter_sig (enum A) |}.
  Next Obligation.
    eapply NoDup_fmap_1. rewrite list_filter_sig_filter.
    apply NoDup_filter, NoDup_enum.
  Qed.
  Next Obligation.
    intros p. apply (elem_of_list_fmap_2_inj proj1_sig).
    rewrite list_filter_sig_filter, elem_of_list_filter.
    split; [by destruct p | apply elem_of_enum].
  Qed.
  Lemma sig_card : card (sig P) = length (filter P (enum A)).
  Proof. by rewrite <-list_filter_sig_filter, fmap_length. Qed.
End sig_finite.

Lemma finite_pigeonhole `{Finite A} `{Finite B} (f : A → B) :
  card B < card A → ∃ x1 x2, x1 ≠ x2 ∧ f x1 = f x2.
Proof.
  intros. apply dec_stable; intros Heq.
  cut (Inj eq eq f); [intros ?%inj_card; lia|].
  intros x1 x2 ?. apply dec_stable. naive_solver.
Qed.

Lemma nat_pigeonhole (f : nat → nat) (n1 n2 : nat) :
  n2 < n1 →
  (∀ i, i < n1 → f i < n2) →
  ∃ i1 i2, i1 < i2 < n1 ∧ f i1 = f i2.
Proof.
  intros Hn Hf. pose (f' (i : fin n1) := nat_to_fin (Hf _ (fin_to_nat_lt i))).
  destruct (finite_pigeonhole f') as (i1&i2&Hi&Hf'); [by rewrite !fin_card|].
  apply (not_inj (f:=fin_to_nat)) in Hi. apply (f_equal fin_to_nat) in Hf'.
  unfold f' in Hf'. rewrite !fin_to_nat_to_fin in Hf'.
  pose proof (fin_to_nat_lt i1); pose proof (fin_to_nat_lt i2).
  destruct (decide (i1 < i2)); [exists i1, i2|exists i2, i1]; lia.
Qed.

Lemma list_pigeonhole {A} (l1 l2 : list A) :
  l1 ⊆ l2 →
  length l2 < length l1 →
  ∃ i1 i2 x, i1 < i2 ∧ l1 !! i1 = Some x ∧ l1 !! i2 = Some x.
Proof.
  intros Hl Hlen.
  assert (∀ i : fin (length l1), ∃ (j : fin (length l2)) x,
    l1 !! (fin_to_nat i) = Some x ∧
    l2 !! (fin_to_nat j) = Some x) as [f Hf]%fin_choice.
  { intros i. destruct (lookup_lt_is_Some_2 l1 i)
      as [x Hix]; [apply fin_to_nat_lt|].
    assert (x ∈ l2) as [j Hjx]%elem_of_list_lookup_1
      by (by eapply Hl, elem_of_list_lookup_2).
    exists (nat_to_fin (lookup_lt_Some _ _ _ Hjx)), x.
    by rewrite fin_to_nat_to_fin. }
  destruct (finite_pigeonhole f) as (i1&i2&Hi&Hf'); [by rewrite !fin_card|].
  destruct (Hf i1) as (x1&?&?), (Hf i2) as (x2&?&?).
  assert (x1 = x2) as -> by congruence.
  apply (not_inj (f:=fin_to_nat)) in Hi. apply (f_equal fin_to_nat) in Hf'.
  destruct (decide (i1 < i2)); [exists i1, i2|exists i2, i1]; eauto with lia.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* ---                        matrix.v                                  --- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*          2-2 matrices with natural coefficients                          *)

(* original version using nat instead of Z                                  *)

Require Import monoid.
Require Import Arith.
Require Import Compare_dec.
Require Import fmpc.

Record Mat2 : Set := mat2 {M11 : nat; M12 : nat; M21 : nat; M22 : nat}.

Definition Id2 := mat2 1 0 0 1.

Definition Mat_mult (M M' : Mat2) :=
  mat2 (M11 M * M11 M' + M12 M * M21 M') (M11 M * M12 M' + M12 M * M22 M')
    (M21 M * M11 M' + M22 M * M21 M') (M21 M * M12 M' + M22 M * M22 M').

Axiom
  Mat_assoc :
    forall M M' M'' : Mat2,
    Mat_mult M (Mat_mult M' M'') = Mat_mult (Mat_mult M M') M''.

Lemma matrix : monoid Mat2.
 refine (mkmonoid Mat2 Id2 Mat_mult _ _ _).
 exact Mat_assoc.
 simple induction a.
  intros M13 M14 M23 M24.
  unfold Id2, Mat_mult in |- *; simpl in |- *.
  repeat rewrite plus_0_r.
  case M13; case M14; case M23; case M24; auto.
  simple induction a.
  intros.
  unfold Id2, Mat_mult in |- *; simpl in |- *.
  repeat rewrite mult_0_r.
  repeat rewrite mult_1_r.
  simpl in |- *; repeat rewrite plus_0_r.
  auto.
Defined.

(* Fibonacci numbers *)

(* definition *)

Fixpoint Fib (n : nat) : nat :=
  match n return nat with
  | O => (* O *)  1
      (* (S p ) *)
  | S p =>
      match p return nat with
      | O => (* O *)  1
          (* S q *)
      | S q => Fib q + Fib p
      end
  end.

Lemma Unfold_FibO : Fib 0 = 1.
Proof.
 unfold Fib in |- *; simpl in |- *; auto with arith.
Qed.

Lemma Unfold_Fib1 : Fib 1 = 1.
Proof.
 unfold Fib in |- *; simpl in |- *; auto with arith.
Qed.

Lemma Unfold_FibSSn : forall n : nat, Fib (S (S n)) = Fib (S n) + Fib n.
Proof.
 intro n; unfold Fib at 1 in |- *.
 simpl in |- *; auto with arith.
Qed.

(* A "Decaled" Fibonnacci function *)

Definition shift_Fib (n : nat) :=
  match n return nat with
  | O => 0
  | S p => Fib p
  end.

Lemma Unfold_shift_Fib : forall n : nat, shift_Fib (S n) = Fib n.
Proof.
 intro n; unfold shift_Fib in |- *; auto with arith.
Qed.

Lemma Simpl_shift_Fib :
 forall n : nat, shift_Fib (S (S n)) = shift_Fib (S n) + shift_Fib n.
Proof.
 simple induction n.
 unfold shift_Fib, Fib in |- *; simpl in |- *; auto with arith.
 intros.
 unfold shift_Fib in |- *.
 rewrite Unfold_FibSSn; auto with arith.
Qed.

Definition fib_mat := mat2 1 1 1 0.

Lemma fib_mat_n :
 forall (n : nat) (a b d : nat),
 power Mat2 matrix fib_mat n = mat2 a b b d ->
 power Mat2 matrix fib_mat (S n) = mat2 (a + b) (b + d) a b.
Proof.
 intros; simpl in |- *.
 rewrite H.
 unfold Mat_mult in |- *.
 simpl in |- *.
 repeat rewrite plus_0_r.
 case a; case b; case d; auto.
Qed.

Lemma fib_n :
 forall n : nat,
 power Mat2 matrix fib_mat (S n) =
 mat2 (shift_Fib (S (S n))) (shift_Fib (S n))
   (shift_Fib (S n)) (shift_Fib n).
Proof.
 simple induction n.
 unfold power, shift_Fib, o, u in |- *; simpl in |- *.
 unfold fib_mat in |- *; simpl in |- *.
 unfold Mat_mult, Id2 in |- *; simpl in |- *; auto with arith.
 intros.
 rewrite (fib_mat_n (S n0) _ _ _ H).
 rewrite (Simpl_shift_Fib (S n0)).
 pattern (shift_Fib (S (S n0))) at 4 in |- *.
 rewrite (Simpl_shift_Fib n0).
 auto with arith.
Qed.

Lemma fib_computation :
 forall n : nat,
 0 < n -> Fib n = M11 (power Mat2 matrix fib_mat n).
Proof.
 simple induction n.
 intro; absurd (0 < 0); auto with arith.
 intros.
 rewrite fib_n; unfold M11 in |- *; auto with arith.
Qed.


(** definition of the small step semantics *)

Require Import Utils Syntax Ty.

(** definition of substitution **)

Fixpoint subst (x : id) (t : term) (t' : term) {struct t'} : term :=
  match t' with
    | tm_var i => if beq_id x i then t else t'
    | tm_app l r => tm_app (subst x t l) (subst x t r)
    | tm_abs i T t1 => tm_abs i T (if beq_id x i then t1 else (subst x t t1))
    | tm_trust t1 => tm_trust (subst x t t1)
    | tm_distrust t1 => tm_distrust (subst x t t1)
    | tm_check t1 => tm_check (subst x t t1)
    | tm_true        => tm_true
    | tm_false       => tm_false
  end.

(** definition of values *)

Inductive value : term -> Prop :=
  | v_true : value tm_true
  | v_false : value tm_false
  | v_abs : forall x T t, value (tm_abs x T t).

Inductive untrust_value : term -> Prop :=
  | u_value : forall v, value v -> untrust_value (tm_distrust v).

Hint Constructors value untrust_value.

Reserved Notation "e '==>' e'" (at level 40).

(* the small step semantics relation *)

Inductive step : term -> term -> Prop :=
  | e_appabs : forall x T t12 v2, value v2 -> (tm_app (tm_abs x T t12) v2) ==> subst x v2 t12
  | e_app1   : forall t1 t1' t2, t1 ==> t1' -> tm_app t1 t2 ==> tm_app t1' t2
  | e_app2   : forall v1 t2 t2', value v1 -> t2 ==> t2' -> tm_app v1 t2 ==> tm_app v1 t2'
  | e_appabsu : forall v x T t12, untrust_value v -> tm_app (tm_abs x T t12) v ==> (subst x v t12)
  | e_app2u : forall v1 t2 t2', untrust_value v1 -> t2 ==> t2' -> tm_app v1 t2 ==> tm_app v1 t2'
  (** other rules **)
  | e_trust1 : forall t1 t1', t1 ==> t1' -> tm_trust t1 ==> tm_trust t1'
  | e_distrust1 : forall t1 t1', t1 ==> t1' -> tm_distrust t1 ==> tm_distrust t1'
  | e_check1 : forall t1 t1', t1 ==> t1' -> tm_check t1 ==> tm_check t1'
  | e_distrustc1 : forall v, value v -> tm_trust (tm_distrust v) ==> tm_trust v
  | e_distrustd1 : forall v, value v -> tm_distrust (tm_distrust v) ==> tm_distrust v
  | e_distrusta1 : forall v x T t, value v -> tm_app (tm_distrust (tm_abs x T t)) v ==> tm_distrust (subst x v t)
  | e_distrusta2 : forall v x T t, untrust_value v -> tm_app (tm_distrust (tm_abs x T t)) v ==> tm_distrust (subst x v t)
  | e_trustv : forall t, value t -> tm_trust t ==> t
  | e_checkv : forall t, value t -> tm_check t ==> t
    where "t '==>' t'" := (step t t').

Hint Constructors step.

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

Definition step_normal_form := normal_form step.

Hint Unfold normal_form step_normal_form.

Remark value_dont_step : forall t, value t -> ~ exists t', t ==> t'.
Proof.
  intros t H Hc. inv H ; try solve by inversion 2.
Qed.

Remark untrust_value_dont_step : forall t, untrust_value t -> ~ exists t', t ==> t'.
Proof.
  intros t Hu Hc. inv Hu.
  inv Hc. inv H0. apply value_dont_step in H. elim H ; eexists ; eauto.
  inv H.
Qed.

Ltac s := f_equal ; eauto ;
  try (match goal with
         | [H : value ?X, H1 : ?X ==> _ |- _] =>
           apply value_dont_step in H
         | [H : untrust_value ?X, H1 : ?X ==> _ |- _] =>
           apply untrust_value_dont_step in H
         | [H : False |- _] => elim H
         | [H : ~ _ |- _] => elim H
         | [H : tm_distrust _ ==> _ |- _] => inv H
         | [ |- ex _] => eexists ; eauto ; fail
       end) ; try solve by inversion ; unfold step_normal_form, normal_form in *.

(* this lemma proves that the previous semantics is deterministic *)

Lemma step_deterministic : forall t t', t ==> t' -> forall t'', t ==> t'' -> t' = t''.
Proof with eauto.
   intros t t' H ; induction H ; intros t'' H2 ; inv H2 ; repeat s ...
Qed.

(** multi step semantics **)

Definition multi_step := refl_step_closure step.

Notation "t '==>*' v" := (multi_step t v) (at level 40).