Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Definition var := nat.

Inductive prop : Set :=
| Var : var -> prop
| Neg : prop -> prop
| Conj : prop -> prop -> prop
| Disj : prop -> prop -> prop.

Fixpoint propDenote (truth : var -> bool) (p : prop) : Prop :=
  match p with
  | Var v => if truth v then True else False
  | Neg p' => ~ propDenote truth p'
  | Conj p1 p2 => propDenote truth p1 /\ propDenote truth p2
  | Disj p1 p2 => propDenote truth p1 \/ propDenote truth p2
  end.

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).

Definition bool_true_dec : forall b, {b = true} + {b = true -> False}.
  refine (fun b =>
            match b with
            | true => Yes
            | false => No
            end). reflexivity. discriminate.
Defined.

Definition decide : forall (truth : var -> bool) (p : prop),
    {propDenote truth p} + {~ propDenote truth p}.
  intros. induction p; crush. destruct (truth v); crush.
Defined.

Notation "[ e ]" := (exist _ e _).
Notation "x <- e1 ; e2" :=
  (match e1 with exist x _ => e2 end)
  (right associativity, at level 60).

Definition negate : forall p : prop,
    {p' : prop | forall truth, propDenote truth p <-> ~ propDenote truth p'}.
  refine (fix F (p : prop) : {p' : prop | forall truth, propDenote truth p <-> ~ propDenote truth p'} :=
            match p with
            | Var v => [Neg (Var v)]
            | Neg p => [p]
            | Conj p1 p2 =>
              p1' <- F p1;
              p2' <- F p2;
              [Disj p1' p2']
            | Disj p1 p2 =>
              p1' <- F p1;
              p2' <- F p2;
              [Conj p1' p2']
            end); crush;
    repeat (match goal with
            | [i : forall truth : var -> bool, _ <-> _ |- _] =>
              destruct (i truth); clear i
            | [|- context[if ?E then _ else _]] =>
              destruct E
            end); crush.
  destruct (decide truth p1'); crush.
Defined.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


(*partie 2.2*)
(* ATTENTION !!!!!
Il faut lancer coqide avec la cmd = coqide -impredicative-set*)
(*L'identité polymorphe*)

(*2.2.1*)
Definition tid : Set := forall T : Set, T -> T.
Definition id : tid := fun T:Set => fun x : T => x.

(*TESTS OF IDENTITY*)
(* 5 est nat? *)
Compute id nat 5.
(* true est boolean? *)
Compute id bool true.
(* BAD TEST | UNCOMMENT *)
(*Compute id bool 0.*)

Definition nbtrue1 :=
fun b => match b with true => 1 |
false => 0 end.

(*Verif : la fonction rend bien un nat*)
Compute id nat (nbtrue1 false).
Compute id tid id.

(*2.2.2*)
(*booleans*)
Definition pbool : Set := forall T : Set, T -> T -> T.
(*vrai*)
Definition ptr : pbool := fun T:Set => fun x:T => fun y:T => x .
(*faux*)
Definition pfa : pbool := fun T:Set => fun (x:T) (y:T) => y.
Print ptr.
Print pfa.

(*first negation*)
Definition cneg1 : pbool -> pbool := fun b => fun T:Set => fun x => fun y => b T y x.

Compute cneg1 ptr.
Compute cneg1 pfa.
(*second negation*)
Definition cneg2 : pbool -> pbool:= fun b => b pbool pfa ptr.

Compute cneg2 ptr.
Compute cneg2 pfa.
(*conj*)
Definition conjonc : pbool -> pbool -> pbool := fun a b => a pbool b a.
Compute conjonc ptr pfa.
Compute conjonc pfa ptr.

(*disonj*)
Definition disjonc : pbool -> pbool -> pbool := fun a b => a pbool a b.

Compute disjonc ptr pfa.
Compute disjonc pfa ptr.

(*3 si vrai. 5, sinon.*)
Definition foo35 : pbool -> nat := fun b => b nat 3 5.
Compute foo35 ptr.

(*BONUS : lui-meme*)
Definition bluimeme : pbool -> pbool := fun b => b pbool b b.

(*2.2.3.1*)

(*A -> B -> T) ->T*)
Definition pprod_nb : Set := forall T: Set, (nat -> bool -> T) -> T.
Definition pcpl_nb : nat -> bool -> pprod_nb := fun a b => fun T => fun k => k a b.

(* (5,true) *)
Compute pcpl_nb 5 true.
(*2.2.3.2*)
Definition pprod_bn : Set := forall T: Set, (bool -> nat -> T) -> T.
Definition pcpl_bn : bool -> nat -> pprod_bn := fun a b => fun T => fun k => k a b.
(* (true,5) *)
Compute pcpl_bn true 5.

(*2.2.3.3*)
Definition convertProd : pprod_nb -> pprod_bn := fun c => c pprod_bn (fun n b => pcpl_bn b n).
(*TEST : (5,true) => (true, 5)*)
Definition c1 := pcpl_nb 5 true.
Definition res := convertProd c1.
Compute c1.
Compute res.
(*produit universel*)
Definition pprod : Set -> Set -> Set := fun A B => forall T:Set, (A -> B -> T) -> T.
Definition pcpl : forall A B:Set, A -> B -> pprod A B := fun A B:Set => fun (a:A) (b:B) => fun T:Set => fun k:(A -> B -> T) => k a b.
(* couple = (99,true) *)
Compute pcpl nat bool 99 true.
(* couple = (1,0) *)
Compute pcpl nat nat 1 0.
(* couple = (1,(3, si vrai, 5 sinon) *)
Compute pcpl pbool nat ptr (foo35 ptr).

(*Choix (Sommes de Types) *)
(*On a juste implementé ça : A+B = ∀T, (A→T)→(B→T)→T.)*)
Definition psom (A B : Set) : Set := forall T:Set, (A -> T) -> (B -> T) -> T.
Definition inj1 (A B : Set) : A -> psom A B := fun a => fun T:Set => fun k1 : (A ->  T) => fun k2 : (B ->  T) => k1 a.
(*Inspirée par inj1*)
Definition inj2 (A B : Set) : B -> psom A B := fun b => fun T:Set => fun k1 : (A ->  T) => fun k2 : (B ->  T) => k2 b.

(*2.2.4  Entiers de Church avec typage polymorphe *)

(*Base form*)
(*On a re-utilisé les definitions de la partie1.v*)
Definition pnat := forall (T:Set), (T->T) -> (T->T).
Definition p0 : pnat := fun (T:Set) => fun (f:T->T) => fun (x:T) => x.
Definition pS : pnat -> pnat :=  fun (n: pnat) => fun (T : Set) f  x => f (n  T f x).
(*Definition de 1 2 et 3 on utilisant pS*)
Definition p1 := pS p0.
Definition p2 := pS p1.
Definition p3 := pS p2.
(*Definition cadd := \n m·\f x·n f(m f x).*)
Definition padd : pnat -> pnat -> pnat := fun n m => fun f x => n f (m f x ).
(* 2 + 3 = 5 *)
Compute padd p2 p3.
(*Definition cmult := \n m · \f· n(m f).*)
Definition pmult : pnat -> pnat -> pnat := fun m n =>  fun T:Set => (fun f => n T (m T f)).
(* 2 X 3 = 6 *)
Compute pmult p2 p3.
(*Definition ceq0 := \n·\x y· n(\z·x) y.*)
Definition peq0 : pnat -> pbool := fun n => fun T:Set => fun (x:T) (y:T) => (n T (fun z => y) x).
(* 3 X 0 == 0 ? *)
Compute peq0 (pmult p3 p0).
(* 3 == 0 ? *)
Compute peq0  p3.

(* special pplus *)
Definition pplus : pnat -> pnat -> pnat := fun n : pnat => fun m : pnat =>  n pnat pS m.
(* Test : 1 + 3 *)
Compute pplus p1 p3.

(*prédécesseur : We did not implement it... No time :-( *)

(* 2.2.5  Listes (bonus) *)
(*On a fait que la premiere question.*)
(*listen = ∀T, T→(pnat→T→T)→T.*)
Definition listen : Set := forall T: Set, T -> (pnat -> T -> T) -> T.
(*liste A = ∀T, T→(A→T→T)→T.*)
(*L'espace entre liste et A EST MANDATORY.*)
Definition liste A : Set := forall T: Set, T -> (A -> T -> T) -> T.
(*pnil A :liste A = ΛT.λxTcA→T→T.x*)
Definition pnil A : liste A := fun T:Set => fun x : T => fun c : (A -> T -> T) =>x.
(*pcons A :  A→ liste A →liste A = λaAq liste A.ΛT.λxTcA→T→T.c a(qTx c).*)
Definition pcons A : A -> liste A -> liste A :=  fun (a : A) (q : liste A) => fun T: Set => fun (x:T) (c : A -> T -> T)=> c a (q T x c).

(*2.2.6  Super bonus : arbres binaires et tri par arbre binaire de recherche*)
(*Reference*)
Definition arbin (A : Set) := forall T: Set, T -> (T -> A -> T -> T) -> T.
(*arbre Vide.*)
Definition pV (A:Set) := fun T:Set=> fun x : T => fun c : T -> A -> T -> T=> x.
(*le nœud comprenant un sous-arbre gauche, un habitant de A et un sous-arbre droit*)
Definition pN (A : Set):= fun (g : arbin A) (a : A) (d : arbin A) => fun T : Set  => fun(x : T) (c : T -> A -> T -> T) => c (g T x c) a (d T x c ).


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

Require Import Arith Omega.

Require Import utils.

Set Implicit Arguments.

Section Tortoise_and_Hare.

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

  Infix "=?" := eqdec (at level 70).

  Variable (f : X -> X) (x0 : X)
           (Hx0 : exists τ, 0 < τ /\ f↑τ x0 = f↑(2*τ) x0).

  (** The custom bar inductive predicate that serves as termination
      criteria for tortoise_hare_rec *)

  Inductive bar_th x y : Prop :=
    | in_bar_th_0 : x = y                  -> bar_th x y
    | in_bar_th_1 : bar_th (f x) (f (f y)) -> bar_th x y.

  (** We give the explicit computational part using refine
      and the proof of the logical part is delayed using _
  *)

  Fixpoint tort_hare_rec x y (H : bar_th x y) : { τ | f↑τ x = f↑(2*τ) y }.
  Proof.
    refine (match x =? y with
             | left E  => exist _ 0 _
             | right C => let (k,Hk) := tort_hare_rec (f x) (f (f y)) _
                          in  exist _ (S k) _
           end).
    * auto.
    * inversion H; tauto.
    * finish with Hk.
  Defined.

  (** Now we fix a starting point for which the iterations
      of f ends into a non-empty loop, we use Hx0 *)

  Let bar_th_fx0_ffx0 : bar_th (f x0) (f (f x0)).
  Proof.
    destruct Hx0 as (k & H1 & H2).
    apply in_bar_th_0 in H2.
    revert k H1 H2; apply nat_rev_ind.
    intros ? H; apply in_bar_th_1; finish with H.
  Qed.

  Definition tortoise_hare : { τ | 0 < τ /\ f↑τ x0 = f↑(2*τ) x0 }.
  Proof.
    refine (match tort_hare_rec bar_th_fx0_ffx0 with
      | exist _ k Hk => exist _ (S k) _
    end).
    split; try omega; finish with Hk.
  Defined.

  Let tortoise_hare_tail_rec :
    forall i x y, bar_th x y -> { k | i <= k /\ f↑(k-i) x = f↑(2*(k-i)) y }.
  Proof.
    refine (fix loop i x y H { struct H } :=
           match x =? y with
             | left E  => exist _ i _
             | right C => match loop (S i) (f x) (f (f y)) _ with
                            | exist _ k Hk => exist _ k _
                          end
           end).
    * split; f_equal; auto; omega.
    * inversion H; tauto.
    * destruct Hk; split; try omega; finish with H1.
  Qed.

  Definition tortoise_hare_tail : { τ | 0 < τ /\ f↑τ x0 = f↑(2*τ) x0 }.
  Proof.
    refine (let (k,Hk) := tortoise_hare_tail_rec 1 bar_th_fx0_ffx0 in exist _ k _).
    destruct Hk as (? & Hk); split; try omega.
    finish with Hk.
  Defined.

End Tortoise_and_Hare.

Check tortoise_hare.
Print Assumptions tortoise_hare.
Recursive Extraction tortoise_hare.

Check tortoise_hare_tail.
Print Assumptions tortoise_hare_tail.
Extraction tortoise_hare_tail.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Operators_Properties.
Require Import Coq.Lists.List.

Require Import Setoid.
Require Import Lia.
Require Import Glib.Glib.

Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Relations.Relation_Operators.

(* star - a reflexive transitive closure *)
Definition star {A} (R: relation A) : relation A := clos_refl_trans_n1 A R.
Notation "R ^*" := (star R) (at level 5, format "R ^*").

Ltac star_notation :=
  repeat change (clos_refl_trans_n1 _ ?R) with (R^*) in *.

(* seq - a transparent sequence of relation steps.
   It is equivalent to the reflexive transitive closure, but is a `Type` rather than a `Prop`.
 *)
Reserved Notation "R #*" (at level 5, format "R #*").
Inductive seq {A} (R: relation A) : A -> A -> Type :=
  | seq_refl : forall x,
      R#* x x
  | seq_step : forall x y z,
      R y z ->
      R#* x y ->
      R#* x z
  where "R #*" := (seq R).

(* nseq - a length-indexed transition sequence *)
Reserved Notation "R #" (at level 5, format "R #").
Inductive nseq {A} (R: relation A) : nat -> A -> A -> Type :=
  | nseq_refl : forall x,
      R#0 x x
  | nseq_step : forall n x y z,
      R y z ->
      R#n x y ->
      R#(S n) x z
  where "R #" := (nseq R).
Notation "R # n" := (nseq R n) (at level 5, format "R # n").

(* Length of a sequence in number of steps (not states) *)
Fixpoint seq_length {A} {R: relation A} {a a'} (seq: R#* a a') :=
  match seq with
  | seq_refl _ x => 0
  | seq_step _ x y z r seq' => S (seq_length seq')
  end.

Inductive in_seq {A} {R: relation A} {a}
  : forall {a'}, A -> R#* a a' -> Prop :=
  | in_seq_head : forall a' (seq: R#* a a'),
      in_seq a' seq
  | in_seq_tail : forall x x' y r seq,
      in_seq y seq ->
      in_seq y (seq_step R a x x' r seq).

Inductive in_seq_at {A} {R: relation A} {a}
  : forall {a'}, A -> nat -> R#* a a' -> Prop :=
  | in_seq_at_head : forall a' (seq: R#* a a'),
      in_seq_at a' (seq_length seq) seq
  | in_seq_at_tail : forall n x x' y r seq,
      in_seq_at y n seq ->
      in_seq_at y n (seq_step R a x x' r seq).

(* This is an old, more complicated definition
   TODO: rewrite in the style of in_seq
 *)
Inductive in_nseq {A} {R: relation A} {a}
  : forall {n a'}, A -> R#n a a' -> Prop :=
  | in_nseq_head_refl :
      in_nseq a (nseq_refl R a)
  | in_nseq_head_step : forall n x x' r p,
      in_nseq x' (nseq_step R n a x x' r p)
  | in_nseq_tail : forall n x x' y r p,
      in_nseq y p ->
      in_nseq y (nseq_step R n a x x' r p).

Inductive in_nseq_at {A} {R: relation A} {a}
  : forall {n a'}, A -> nat -> R#n a a' -> Prop :=
  | in_nseq_at_head_refl :
      in_nseq_at a 0 (nseq_refl R a)
  | in_nseq_at_head_step : forall n x x' r p,
      in_nseq_at x' (S n) (nseq_step R n a x x' r p)
  | in_nseq_at_tail : forall n m x x' y r p,
      in_nseq_at y m p ->
      in_nseq_at y m (nseq_step R n a x x' r p).

(* Misc. definitions *)

Definition is_serial {A} (R: relation A) := forall a, exists b, R a b.
Definition serial A := {R: relation A | is_serial R}.

Definition serial_witness {A} (R: relation A) := forall a, {b | R a b}.
Definition serialT A := {R: relation A & serial_witness R}.

Definition rel_singleton {A} (x y : A): relation A :=
  fun x' y' => x' = x /\ y' = y -> True.

Section BinaryRelationsProperties.

Context {A: Type}.
Variable R : relation A.

(* star properties *)

Theorem star_refl :
  reflexive A R^*.
Proof using.
  constructor.
Qed.

Theorem star_trans :
  transitive A R^*.
Proof using.
  unfold transitive.
  intros * Hxy Hyz.
  induction Hyz.
  - assumption.
  - follows econstructor.
Qed.

Lemma star_lift : forall x y,
  R x y ->
  R^* x y.
Proof using.
  intros * H.
  econstructor.
  - eassumption.
  - constructor.
Qed.

Theorem rt1n_star : forall x y,
  clos_refl_trans_1n A R x y -> star R x y.
Proof.
  intros * ?.
  apply clos_rt_rtn1.
  now apply clos_rt1n_rt.
Qed.

Theorem star_rt1n : forall x y,
  star R x y -> clos_refl_trans_1n A R x y.
Proof.
  intros * ?.
  apply clos_rt_rt1n.
  now apply clos_rtn1_rt.
Qed.

Theorem star_rt1n_trans : forall x y z,
  R x y ->
  R^* y z ->
  R^* x z.
Proof using.
  intros.
  apply rt1n_star.
  econstructor.
  - eassumption.
  - now apply star_rt1n.
Qed.

(* seq properties *)

Theorem seq__star : forall x y,
  R#* x y ->
  R^* x y.
Proof using.
  intros * H.
  induction H.
  - constructor.
  - follows econstructor.
Qed.

Theorem star__seq : forall x y,
  R^* x y ->
  ‖R#* x y‖.
Proof using.
  intros * H.
  induction H.
  - repeat constructor.
  - find uninhabit.
    constructor.
    follows econstructor.
Qed.

Definition seq_singleton {x y} (r: R x y)
  : R#* x y :=
  seq_step R x x y r (seq_refl R x).

Definition seq_tail {x z} (r: R#* x z) (p: seq_length r > 0) : Σ y, R#* y z.
  induction r.
  - follows exfalso.
  - destruct r0.
    + exists x.
      follows apply seq_singleton.
    + forward IHr by (cbn; lia).
      destruct exists IHr s.
      follows exists s.
Defined.

Definition seq_step_front x y z (step: R x y) (tail: R#* y z) : R#* x z.
  induction tail.
  - follows apply seq_singleton.
  - eapply seq_step.
    + exact r.
    + tedious.
Defined.

Theorem destruct_seq_front : forall x z (s: R#* x z),
  ⟨z, s⟩ = ⟨x, seq_refl R x⟩ \/
  exists y (r: R x y) (s': R#* y z), s = seq_step_front x y z r s'.
Proof using.
  intros *.
  induction s.
  - follows left.
  - right.
    destruct or IHs.
    + inject IHs.
      follows exists z r (seq_refl R z).
    + destruct IHs as (y' & r' & s' & ->).
      follows exists y' r' (seq_step R y' y z r s').
Qed.

(* Definition seq_rect_front : forall (P: forall x y, R#* x y -> Type),
  (forall x, P x x (seq_refl R x)) ->
  (forall x y z (r: R x y) (s: R#* y z), P y z s -> P x z (seq_step_front x y z r s)) ->
  forall x y (s: R#* x y), P x y s.
intros * H IH.
induction s.
- assumption!.
- todo.
Admitted. *)

Theorem in_seq_first : forall x y (r: R#* x y),
  in_seq x r.
Proof using.
  intros *.
  induction r.
  - constructor.
  - now constructor.
Qed.

Theorem in_seq_at_0 : forall x y (r: R#* x y),
  in_seq_at x 0 r.
Proof using.
  intros *.
  induction r.
  - fold (seq_length (seq_refl R x)).
    constructor.
  - now constructor.
Qed.

Theorem inv_in_seq_at_0 : forall x y (r: R#* x y) s,
  in_seq_at s 0 r ->
  s = x.
Proof using.
  intros * H.
  after induct! H as [z r|].
  follows destruct r.
Qed.

Lemma in_seq_at_length {x z}: forall (r: R#* x z) y i,
  in_seq_at y i r ->
  i <= seq_length r.
Proof using.
  tedious.
Qed.

Lemma inv_in_seq_at_length {x z}: forall (r: R#* x z) y,
  in_seq_at y (seq_length r) r ->
  y = z.
Proof using.
  intros * Hin.
  after invc! Hin.
  simpl in *.
  find (fun H => apply in_seq_at_length in H).
  exfalso; lia.
Qed.

Theorem in_seq_at_unique : forall x y (r: R#* x y) s s' i,
  in_seq_at s i r ->
  in_seq_at s' i r ->
  s = s'.
Proof using.
  intros * H H'.
  max induction H.
  - follows erewrite inv_in_seq_at_length.
  - after invc! H'.
    apply in_seq_at_length in H.
    contradict H; simpl; lia.
Qed.

Lemma in_seq_at__in_seq {x y z}: forall (r: R#* x z) i,
  in_seq_at y i r ->
  in_seq y r.
Proof using.
  tedious.
Qed.

Lemma in_seq__in_seq_at {x y z}: forall (r: R#* x z),
  in_seq y r ->
  exists i, in_seq_at y i r.
Proof using.
  intros * H.
  follows induction H.
Qed.

Lemma ex_in_seq_at_le_length {x z}: forall (r: R#* x z) i,
  i <= seq_length r ->
  exists y, in_seq_at y i r.
Proof using.
  intros * ile.
  induction r.
  - follows inv ile.
  - simpl! in ile.
    after invc ile.
    exists z.
    change (S (seq_length r0)) with (seq_length (seq_step R x y z r r0)).
    constructor.
Qed.

Lemma in_seq_at_succ_related {w z}: forall (r: R#* w z) x y i,
  in_seq_at x i r ->
  in_seq_at y (S i) r ->
  R x y.
Proof using.
  intros * Hin Hin'.
  max induction Hin.
  - apply in_seq_at_length in Hin'.
    contradict Hin'; lia.
  - after invc! Hin'.
    simpl in H2.
    inv H2.
    apply inv_in_seq_at_length in Hin as <-.
    assumption.
Qed.

Lemma ex_seq_prefix {x y z} : forall (r: R#* x z),
  in_seq y r ->
  exists prefix: R#* x y,
    forall s i, in_seq_at s i prefix -> in_seq_at s i r.
Proof using.
  tedious.
Qed.

Lemma ex_seq_at_prefix {x y z} : forall (r: R#* x z) n,
  in_seq_at y n r ->
  exists prefix: R#* x y,
    seq_length prefix = n /\
    forall s i, in_seq_at s i prefix -> in_seq_at s i r.
Proof using.
  intros * Hin.
  induction Hin.
  - follows define exists by assumption.
  - follows destruct exists IHHin prefix.
Qed.

(* Note equivalence to transitivity under Curry-Howard reflection to star *)
Definition seq_concat {x y z} (Rxy: R#* x y) (Ryz: R#* y z)
  : R#* x z.
Proof using.
  induction Ryz.
  - assumption.
  - econstructor.
    + eassumption.
    + find applyc.
      assumption.
Defined.

Theorem seq_concat_refl : forall x y (r: R#* x y),
  seq_concat (seq_refl R x) r = r.
Proof using.
  intros *.
  induction r.
  - reflexivity.
  - simpl.
    now find rewrite.
Qed.

Theorem seq_concat_assoc : forall w x y z,
  forall (a: R#* w x) (b: R#* x y) (c: R#* y z),
    seq_concat (seq_concat a b) c =
    seq_concat a (seq_concat b c).
Proof using.
  intros *.
  max induct c.
  - reflexivity.
  - simpl.
    follows find rewrite.
Qed.

Theorem in_seq__concat {x y z}: forall (a: R#* x y) (b: R#* y z) n,
  in_seq n (seq_concat a b) <-> in_seq n a \/ in_seq n b.
Proof using.
  intros *.
  split; intro H.
  - induction b.
    + simpl in H.
      now left.
    + simpl in *.
      dependent invc H.
      * right. constructor.
      * specialize (IHb a H2); clear H2.
        destruct IHb.
       -- now left.
       -- right. constructor. assumption.
  - destruct H.
    + induction b.
      * assumption.
      * simpl.
        constructor.
        now find apply.
    + induction b.
      * simpl.
        inversion H; subst.
        constructor.
      * simpl.
        dependent invc H.
       -- constructor.
       -- constructor.
          now find apply.
Qed.

Theorem in_seq_at__concat_l {x y z}: forall (a: R#* x y) (b: R#* y z) n i,
  in_seq_at n i a -> in_seq_at n i (seq_concat a b).
Proof using.
  intros * H.
  induction b.
  - assumption.
  - simpl.
    constructor.
    now find applyc.
Qed.

Theorem in_seq_at__concat_r {x y z}: forall (a: R#* x y) (b: R#* y z) n i,
  in_seq_at n i b -> in_seq_at n (seq_length a + i) (seq_concat a b).
Proof using.
  intros * H.
  induction b.
  - dependent invc H.
    simpl.
    rewrite PeanoNat.Nat.add_0_r.
    constructor.
  - simpl.
    dependent invc H.
    + clear IHb.
      simpl.
      match goal with
      | |- in_seq_at _ ?i ?seq =>
          replace i with (seq_length seq)
      end; [constructor|].
      simpl.
      rewrite PeanoNat.Nat.add_succ_r.
      f_equal.
      clear.
      induction b; simpl; try find rewrite; lia.
    + constructor.
      now find apply.
Qed.

Lemma seq_length_concat {x y z}: forall (a: R#* x y) (b: R#* y z),
  seq_length (seq_concat a b) = seq_length a + seq_length b.
Proof using.
  intros *.
  induction b; simpl; try find rewrite; lia.
Qed.

Definition seq_prepend (x y z: A):
  R x y ->
  R#* y z ->
  R#* x z.
Proof using.
  intros ? Ryz.
  induction Ryz.
  - now apply seq_singleton.
  - econstructor.
    + eassumption.
    + now find apply.
Defined.

(* Isomorphic to seq. Sometimes, this reversed structure is more convenient
   (Note the "growth" step prepends rather than appending to the end)
*)
Inductive seq_rev : A -> A -> Type :=
  | seq_rev_refl : forall x,
      seq_rev x x
  | seq_rev_step : forall x y z,
      R x y ->
      seq_rev y z ->
      seq_rev x z.

Fixpoint seq_rev_length {a a'} (seqr: seq_rev a a') :=
  match seqr with
  | seq_rev_refl x => 0
  | seq_rev_step x y z r seq' => S (seq_rev_length seq')
  end.

Definition seq_rev_concat {x y z} (Rxy: seq_rev x y) (Ryz: seq_rev y z)
  : seq_rev x z.
Proof using.
  induction Rxy.
  - assumption.
  - econstructor.
    + eassumption.
    + find applyc.
      assumption.
Defined.

Definition seq__seq_rev {x y} (seq: R#* x y): seq_rev x y.
  induction seq.
  - constructor.
  - eapply seq_rev_concat; [eassumption|].
    econstructor.
    + eassumption.
    + constructor.
Defined.

Definition seq_rev__seq {x y} (seqr: seq_rev x y): R#* x y.
  induction seqr.
  - constructor.
  - eapply seq_concat; [|eassumption].
    econstructor.
    + eassumption.
    + constructor.
Defined.

Theorem seq_rev_concat_refl : forall x y (r: seq_rev x y),
  seq_rev_concat r (seq_rev_refl y) = r.
Proof using.
  intros *.
  induction r.
  - reflexivity.
  - simpl.
    now find rewrite.
Qed.

Theorem seq_rev_concat_assoc : forall w x y z,
  forall (a: seq_rev w x) (b: seq_rev x y) (c: seq_rev y z),
    seq_rev_concat (seq_rev_concat a b) c =
    seq_rev_concat a (seq_rev_concat b c).
Proof using.
  intros *.
  max induct a.
  - reflexivity.
  - simpl.
    follows find rewrite.
Qed.

Theorem seq__seq_rev__concat {x y z}: forall (a: R#* x y) (b: R#* y z),
  seq__seq_rev (seq_concat a b) = seq_rev_concat (seq__seq_rev a) (seq__seq_rev b).
Proof using.
  intros *.
  revert x a; induct b; intros.
  - simpl.
    now rewrite seq_rev_concat_refl.
  - simpl seq_concat; simpl seq__seq_rev at 1.
    find rewrite ->.
    rewrite seq_rev_concat_assoc.
    reflexivity.
Qed.

Theorem seq_rev__seq__concat {x y z}: forall (a: seq_rev x y) (b: seq_rev y z),
  seq_rev__seq (seq_rev_concat a b) = seq_concat (seq_rev__seq a) (seq_rev__seq b).
Proof using.
  intros *.
  revert z b; induct a; intros.
  - simpl.
    now rewrite seq_concat_refl.
  - simpl seq_rev_concat; simpl seq_rev__seq at 1.
    find rewrite ->.
    rewrite <- seq_concat_assoc.
    reflexivity.
Qed.

Definition ϕ_seq__seq_rev : forall x y,
  R#* x y ≃> seq_rev x y.
Proof using.
  intros *.
  exists (@seq__seq_rev x y) (@seq_rev__seq x y).
  split.
  - intros *.
    induct b.
    + reflexivity.
    + simpl.
      rewrite seq__seq_rev__concat.
      simpl.
      now find rewrite.
  - intros *.
    induct a.
    + reflexivity.
    + simpl.
      rewrite seq_rev__seq__concat.
      simpl.
      now find rewrite.
Defined.

Theorem isomorphic_seq__seq_rev : forall x y,
  R#* x y ≃ seq_rev x y.
Proof using.
  intros.
  apply isomorphism__isomorphic.
  apply ϕ_seq__seq_rev.
Qed.

(* equivalent to in_seq under the obvious isomorphism *)
Inductive in_seq_rev {a}
  : forall {a'}, A -> seq_rev a a' -> Prop :=
  | in_seq_rev_head : forall a' (seqr: seq_rev a a'),
      in_seq_rev a seqr
  | in_seq_rev_tail : forall x x' y r seqr,
      in_seq_rev y seqr ->
      in_seq_rev y (seq_rev_step a x x' r seqr).

Inductive in_seq_rev_at {a}
  : forall {a'}, A -> nat -> seq_rev a a' -> Prop :=
  | in_seq_rev_at_head : forall a' (seqr: seq_rev a a'),
      in_seq_rev_at a 0 seqr
  | in_seq_rev_at_tail : forall n x x' y r seqr,
      in_seq_rev_at y n seqr ->
      in_seq_rev_at y (S n) (seq_rev_step a x x' r seqr).

Theorem in_seq_rev_at__concat_l {x y z}: forall (a: seq_rev x y) (b: seq_rev y z) n i,
  in_seq_rev_at n i a -> in_seq_rev_at n i (seq_rev_concat a b).
Proof using.
  intros * H.
  max induction a.
  - follows inv H.
  - simpl.
    follows invc! H.
Qed.

Theorem in_seq_rev_at__in_seq_at {x y z i} {seqr: seq_rev x z}:
  in_seq_rev_at y i seqr ->
  in_seq_at y i (seq_rev__seq seqr).
Proof using.
  intros Hin.
  max induction Hin.
  - induction seqr.
    + simpl.
      apply in_seq_at_0.
    + simpl.
      apply in_seq_at__concat_l.
      constructor.
      apply in_seq_at_0.
  - simpl.
    change (S n) with (seq_length (seq_step R a a x r (seq_refl R a)) + n).
    follows apply in_seq_at__concat_r.
Qed.

Theorem in_seq_at__in_seq_rev_at__iso {x y z i} {seqr: seq_rev x z}:
  in_seq_at y i ((ϕ_seq__seq_rev x z)⁻¹ seqr) ->
  in_seq_rev_at y i seqr.
Proof using.
  intros Hin.
  max induct Hin.
  - after induction seqr.
    simpl.
    follows rewrite seq_length_concat.
  - change (seq_rev__seq ?x) with ((ϕ_seq__seq_rev _ _)⁻¹ x) in H0.
    apply eq_cancel_right in H0.
    especialize IHHin; forward IHHin by apply inv_cancel_iso.
    simpl in H0;
    change (seq__seq_rev ?x) with (ϕ_seq__seq_rev _ _ x) in H0.
    subst.
    follows apply in_seq_rev_at__concat_l.
Qed.

Theorem in_seq_at__in_seq_rev_at {x y z i} {seqr: seq_rev x z}:
  in_seq_at y i (seq_rev__seq seqr) ->
  in_seq_rev_at y i seqr.
Proof using.
  apply in_seq_at__in_seq_rev_at__iso.
Qed.

Theorem in_seq_at__in_seq_rev_at__iso' {x y z i} {seq: R#* x z}:
  in_seq_at y i seq ->
  in_seq_rev_at y i (ϕ_seq__seq_rev x z seq).
Proof using.
  iso ϕ_seq__seq_rev seq seqr.
  rewrite iso_cancel_inv.
  apply in_seq_at__in_seq_rev_at__iso.
Qed.

Theorem in_seq_iso_in_seq_rev_flip : forall x y z,
  forall b: seq_rev x y, in_seq_rev z b = in_seq z ((ϕ_seq__seq_rev x y)⁻¹ b).
Proof using.
  intros *.
  induct b; extensionality.
  - simpl.
    split; intro; find inversion; subst; constructor.
  - split; intro H; simpl in *.
    + apply in_seq__concat.
      rewrite <- IHb.
      dependent inv H.
      * left.
        repeat constructor.
      * auto.
    + apply in_seq__concat in H.
      rewrite <- IHb in H.
      destruct H.
      * dependent inv H.
       -- destruct b; repeat constructor.
       -- inversion H3; subst.
          repeat constructor.
      * now constructor.
Qed.

Theorem in_seq_iso_in_seq_rev : forall x y z,
  iso_equiv (ϕ_seq__seq_rev x y) (@in_seq A R x y z) (@in_seq_rev x y z).
Proof using.
  intros *.
  rewrite iso_equiv_flip.
  apply in_seq_iso_in_seq_rev_flip.
Qed.

Theorem seq_length_iso_seq_rev_length : forall x y,
  iso_equiv (ϕ_seq__seq_rev x y) seq_length seq_rev_length.
Proof using.
  intros *.
  rewrite iso_equiv_flip.
  intros seqr.
  after max induction seqr.
  simpl.
  rewrite seq_length_concat.
  simpl.
  follows f_equal.
Qed.

Lemma in_seq_rev_at_last : forall x y (seqr: seq_rev x y),
  in_seq_rev_at y (seq_rev_length seqr) seqr.
Proof using.
  tedious.
Qed.

(* nseq properties *)

Definition nseq__seq {n} {x y}:
  R#n x y ->
  R#* x y.
Proof using.
  intros * H.
  induction H.
  - constructor.
  - econstructor; eassumption.
Defined.

Definition seq__nseq {x y}:
  R#* x y ->
  {n & R#n x y}.
Proof using.
  intros * H.
  induction H.
  - eexists. constructor.
  - destruct exists IHseq n.
    exists (S n).
    econstructor; eassumption.
Defined.

Theorem in_nseq_at__in_nseq : forall x a b n m (r: R#n a b),
  in_nseq_at x m r ->
  in_nseq x r.
Proof using.
  intros * H.
  induction H; constructor.
  assumption.
Qed.

Theorem in_nseq__in_nseq_at : forall x a b n (r: R#n a b),
  in_nseq x r ->
  exists m, m <= n /\ in_nseq_at x m r.
Proof using.
  intros * H.
  induction H.
  - eexists.
    split; [|constructor].
    reflexivity.
  - eexists.
    split; [|constructor].
    lia.
  - destruct exists IHin_nseq m.
    exists m.
    destruct IHin_nseq.
    split.
    + lia.
    + constructor.
      assumption.
Qed.

Definition nseq_singleton {x y} (r: R x y) : R#1 x y.
  tedious.
Defined.

Definition nseq_prepend (x y z: A) n:
  R x y ->
  R#n y z ->
  R#(S n) x z.
Proof using.
  intros ? Ryz.
  follows induction Ryz.
Defined.

End BinaryRelationsProperties.

(* These must be declared outside the section to be visisble *)

Add Parametric Relation {A: Type} (R: relation A): A (star R)
  reflexivity  proved by (star_refl R)
  transitivity proved by (star_trans R)
  as star_rel.

Arguments ϕ_seq__seq_rev {A R x y}.


Require Import Ashley.Axioms.
Require Import Ashley.Category.

Class Preorder (A:Type) :=
{
  within: A -> A -> Prop;
  within_reflex: forall p, within p p;
  within_trans: forall p q r, within q r -> within p q -> within p r
}.
Notation "a >= b" := (within b a).
Notation "a <= b" := (within a b).
Notation "a > b" := (~ within a b).
Notation "a < b" := (~ within b a).

Instance indexed_Preorder (I:Type) (A:Type) `{Preorder A} : Preorder (I -> A) :=
{
  within p q := forall i, within (p i) (q i)
}.
intros.
apply within_reflex.
intros.
apply (within_trans (p i) (q i) (r i)).
apply H0.
apply H1.
Defined.

Instance within_Category (A:Type) `{Preorder A}: Category A :=
{
  hom := within;
  id := within_reflex;
  compose := within_trans
}.
intros.
apply proof_irrelevance.
intros.
apply proof_irrelevance.
intros.
apply proof_irrelevance.
Defined.

Definition Preorder_Category {A} (po: Preorder A): Category A := @within_Category A po.

Class PartialOrder (A:Type) `{Preorder A} :=
{
  within_antisym: forall p q, within p q -> within q p -> p = q
}.

Instance indexed_PartialOrder (I:Type) (A:Type) `{PartialOrder A} : PartialOrder (I -> A) :=
{
}.
intros.
apply fun_ext.
intros.
apply within_antisym.
apply H1.
apply H2.
Defined.

Class BoundedPartialOrder (A:Type) `{PartialOrder A} :=
{
  bottom: A;
  bottom_within: forall (p:A), bottom <= p;
  top: A;
  top_without: forall (p:A), p <= top
}.

Instance indexed_BoundedPartialOrder (I:Type) (A:Type) `{BoundedPartialOrder A} : BoundedPartialOrder (I -> A) :=
{
  bottom i := bottom;
  top i := top
}.
intros.
unfold within.
unfold indexed_Preorder.
intros.
apply bottom_within.
intros.
unfold within.
unfold indexed_Preorder.
intros.
apply top_without.
Defined.

Require Import Ashley.Proposition.

Instance prop_Preorder: Preorder Prop :=
{
  within p q := p -> q
}.
intros.
exact H.
intros.
firstorder.
Defined.

Instance prop_PartialOrder: PartialOrder Prop :=
{
}.
intros.
apply prop_ext.
firstorder.
Defined.

Instance prop_BoundedPartialOrder: BoundedPartialOrder Prop :=
{
  bottom := False;
  top := True
}.
unfold within.
unfold prop_PartialOrder.
firstorder.
unfold within.
unfold prop_PartialOrder.
firstorder.
Defined.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Require Import language.
Require Import state.
Require Import util.
Import ListNotations.

Fixpoint aeval (stoV: storeV) (stoF: storeF) (a:aexp) : nat :=
match a with
| ANum n => n
| AId name => (stoV name)
| APlus a1 a2 => (aeval stoV stoF a1) + (aeval stoV stoF a2)
| AMult a1 a2 => (aeval stoV stoF a1) * (aeval stoV stoF a2)
| AMinus a1 a2 => (aeval stoV stoF a1) - (aeval stoV stoF a2)
| AFsize fname => length (stoF fname)
end.

Fixpoint findbk (li:list nat) (loc:nat): option nat :=
match li with
| [] => None
| x::xli => if (beq_nat loc 1) then Some x else (findbk xli (loc-1))
end.

Fixpoint bkeval (stoV:storeV) (stoB:storeB)
                (stoF:storeF) (bk:bkexp) : option nat :=
match bk with
| BKNum n => Some n
| BKId name => Some (stoB name)
| BKAddr fname a => findbk (stoF fname) (aeval stoV stoF a)
end.

Fixpoint beval stoV stoB stoF (b:bexp) : option bool :=
match b with
| BTrue   => Some true
| BFalse  => Some false
| BEq a1 a2 => Some (beq_nat (aeval stoV stoF a1) (aeval stoV stoF a2))
| BLe a1 a2 => Some (leb (aeval stoV stoF a1) (aeval stoV stoF a2))
| BNot b1   =>(match (beval stoV stoB stoF b1) with
               | None => None
               | Some x => Some (negb x)
               end)
| BAnd b1 b2  =>(match (beval stoV stoB stoF b1), (beval stoV stoB stoF b2) with
                 | None,_ => None
                 | _,None => None
                 | Some x1,Some x2 => Some (andb x1 x2)
                 end)
| BOr  b1 b2  =>(match (beval stoV stoB stoF b1), (beval stoV stoB stoF b2) with
                 | None,_ => None
                 | _,None => None
                 | Some x1, Some x2 => Some (orb x1 x2)
                 end)
| BKeq bk1 bk2  =>(match (bkeval stoV stoB stoF bk1),
                         (bkeval stoV stoB stoF bk2)
                   with
                   | None,_ => None
                   | _,None => None
                   | Some a1, Some a2 => (Some (beq_nat a1 a2))
                   end)
| BKle bk1 bk2  => (match (bkeval stoV stoB stoF bk1),
                          (bkeval stoV stoB stoF bk2)
                   with
                   | None,_ => None
                   | _,None => None
                   | Some a1, Some a2 => (Some (leb a1 a2))
                   end)
end.

(* auxiliary function *)
Definition beq_op_nat x y : bool :=
match x,y with
| None,None => true
| Some n1,Some n2 => beq_nat n1 n2
| _,_ => false
end.

Fixpoint in_list (li:list (option nat)) (x:option nat) : bool :=
match li with
| [] => false
| t::xli => if beq_op_nat t x then true else in_list xli x
end.

Definition get_content (nli:list (option nat)) : list nat :=
let f := fun t => match t with
                 | Some n => n
                 | None => 0
                 end
in (map f nli).

Fixpoint all_none (opli:list (option nat)) : bool :=
match opli with
| [] => true
| x::li => if beq_op_nat x None then all_none li
           else false
end.

Fixpoint h_unionB_many hB locli nli : heapB :=
match locli,nli with
| loc::locs,n::ns => h_unionB_many (h_updateB hB loc n) locs ns
| [],[] => hB
| _,_ => hB
end.

Inductive big_step: command -> state -> ext_state -> Prop :=
| E_Skip  : forall stat,
              big_step CSkip stat (St stat)
| E_Ass   : forall stoV stoB stoF hV hB x a n, (aeval stoV stoF a) = n ->
              big_step (CAss x a) (stoV,stoB,stoF,hV,hB)
                       (St ((st_updateV stoV x n),stoB,stoF,hV,hB))
| E_Seq   : forall c1 c2 st0 st1 opst,
              big_step c1 st0 (St st1) ->
              big_step c2 st1 opst ->
              big_step (CSeq c1 c2) st0 opst
| E_Seq_Ab: forall c1 c2 st0,
              big_step c1 st0 Abt ->
              big_step (CSeq c1 c2) st0 Abt
| E_IfTure: forall stoV stoB stoF hV hB opst b c1 c2,
              beval stoV stoB stoF b = Some true ->
              big_step c1 (stoV,stoB,stoF,hV,hB) opst ->
              big_step (CIf b c1 c2) (stoV,stoB,stoF,hV,hB) opst
| E_IfFalse: forall stoV stoB stoF hV hB opst b c1 c2,
              beval stoV stoB stoF b = Some false ->
              big_step c2 (stoV,stoB,stoF,hV,hB) opst ->
              big_step (CIf b c1 c2) (stoV,stoB,stoF,hV,hB) opst
| E_If_Ab : forall stoV stoB stoF hV hB b c1 c2,
              beval stoV stoB stoF b = None ->
              big_step (CIf b c1 c2) (stoV,stoB,stoF,hV,hB) Abt

| E_WhileEnd : forall b stoV stoB stoF hV hB c,
                 beval stoV stoB stoF b = Some false ->
                 big_step (CWhile b c) (stoV,stoB,stoF,hV,hB) (St (stoV,stoB,stoF,hV,hB))

| E_WhileLoop : forall stoV stoB stoF hV hB opst b c st,
                  beval stoV stoB stoF b = Some true ->
                  big_step c (stoV,stoB,stoF,hV,hB) (St st) ->
                  big_step (CWhile b c) st opst ->
                  big_step (CWhile b c) (stoV,stoB,stoF,hV,hB) opst
| E_WhileLoop_Ab : forall stoV stoB stoF hV hB b c,
                  beval stoV stoB stoF b = Some true ->
                  big_step c (stoV,stoB,stoF,hV,hB) Abt ->
                  big_step (CWhile b c) (stoV,stoB,stoF,hV,hB) Abt
| E_While_Ab :  forall stoV stoB stoF hV hB b c,
                  beval stoV stoB stoF b = None ->
                  big_step (CWhile b c) (stoV,stoB,stoF,hV,hB) Abt

| E_Cons : forall stoV stoB stoF hV hB a n x l,
              aeval stoV stoF a = n ->
              hV l = None ->
              big_step (CCons x a) (stoV,stoB,stoF,hV,hB)
                       (St ((st_updateV stoV x l),stoB,stoF,
                            (h_updateV hV l n), hB))

| E_Lookup : forall stoV stoB stoF hV hB x a1 l n,
                aeval stoV stoF a1 = l ->
                hV l = Some n ->
                big_step (CLookup x a1) (stoV,stoB,stoF,hV,hB)
                         (St ((st_updateV stoV x n),stoB,stoF,hV,hB))

| E_Lookup_Ab : forall stoV stoB stoF hV hB x a1 l,
                   aeval stoV stoF a1 = l ->
                   hV l = None ->
                   big_step (CLookup x a1) (stoV,stoB,stoF,hV,hB) Abt

| E_Mutat : forall stoV stoB stoF hV hB a1 a2 n1 n2,
                  aeval stoV stoF a1 = n1 ->
                  aeval stoV stoF a2 = n2 ->
                  in_domV n1 hV ->
                  big_step (CMutat a1 a2) (stoV,stoB,stoF,hV,hB)
                           (St (stoV,stoB,stoF,(h_updateV hV n1 n2),hB))

| E_Mutat_Ab : forall stoV stoB stoF hV hB a1 a2 n1,
                     aeval stoV stoF a1 = n1 ->
                     hV n1 = None ->
                     big_step (CMutat a1 a2) (stoV,stoB,stoF,hV,hB) Abt

| E_Dispose : forall stoV stoB stoF hV hB a1 n1,
                 aeval stoV stoF a1 = n1 ->
                 in_domV n1 hV ->
                 big_step
                   (CDispose a1) (stoV,stoB,stoF,hV,hB)
                   (St (stoV,stoB,stoF,(h_removeV hV n1),hB))

| E_Dispose_Ab : forall stoV stoB stoF hV hB a1 n1,
                    aeval stoV stoF a1 = n1 ->
                    hV n1 = None ->
                    big_step (CDispose a1) (stoV,stoB,stoF,hV,hB) Abt

| E_Fcreate : forall stoV stoB stoF hV hB f bkli nli nlist locli xli,
                 nli = map (bkeval stoV stoB stoF) bkli ->
                 in_list nli None = false ->
                 get_content nli = nlist ->
                 length locli = length nli ->
                 map hB locli = xli ->
                 all_none xli = true ->
                 big_step (CFcreate f bkli) (stoV,stoB,stoF,hV,hB)
                          (St (stoV,stoB,(st_updateF stoF f locli),hV,
                              (h_unionB_many hB locli nlist)))
| E_Fcreate_Abt : forall stoV stoB stoF hV hB f bkli nli,
                    nli = map (bkeval stoV stoB stoF) bkli ->
                    in_list nli None = true ->
                    big_step (CFcreate f bkli) (stoV,stoB,stoF,hV,hB) Abt

| E_FcontentAppend : forall stoV stoB stoF hV hB f bkli nli nlist ff xli locli,
                        nli = map (bkeval stoV stoB stoF) bkli ->
                        in_list nli None = false ->
                        get_content nli = nlist ->
                        length locli = length nli ->
                        map hB locli = xli ->
                        all_none xli = true ->
                        ff = stoF f ->
                        big_step (CFcontentAppend f bkli) (stoV,stoB,stoF,hV,hB)
                                 (St (stoV,stoB,
                                     (st_updateF stoF f (ff ++ locli)),hV,
                                     (h_unionB_many hB locli nlist)))

| E_FcontentAppend_Abt : forall stoV stoB stoF hV hB f bkli nli,
                          nli = map (bkeval stoV stoB stoF) bkli ->
                          in_list nli None = true ->
                          big_step (CFcontentAppend f bkli)
                                   (stoV,stoB,stoF,hV,hB) Abt

| E_FaddressAppend : forall stoV stoB stoF hV hB f1 f2 bkli nli nlist ff2,
                        nli = map (bkeval stoV stoB stoF) bkli ->
                        in_list nli None = false ->
                        get_content nli = nlist ->
                        ff2 = stoF f2 ->
                        big_step (CFaddressAppend f1 f2 bkli) (stoV,stoB,stoF,hV,hB)
                                 (St (stoV,stoB,
                                     (st_updateF stoF f1 (ff2 ++ nlist)),hV,hB))

| E_FaddressAppend_Abt : forall stoV stoB stoF hV hB f1 f2 bkli nli,
                          nli = map (bkeval stoV stoB stoF) bkli ->
                          in_list nli None = true ->
                          big_step (CFaddressAppend f1 f2 bkli)
                                   (stoV,stoB,stoF,hV,hB) Abt

| E_Fdelete : forall stoV stoB stoF hV hB f,
                big_step (CFdelete f) (stoV,stoB,stoF,hV,hB)
                         (St (stoV,stoB,stoF,hV,hB))

| E_Blookup : forall stoV stoB stoF hV hB b bk n v,
                (bkeval stoV stoB stoF bk) = Some n->
                hB n = Some v ->
                big_step (CBlookup b bk) (stoV,stoB,stoF,hV,hB)
                         (St (stoV,(st_updateB stoB b v),stoF,hV,hB))

| E_Blookup_AbtBK : forall stoV stoB stoF hV hB b bk,
                      (bkeval stoV stoB stoF bk) = None ->
                      big_step (CBlookup b bk) (stoV,stoB,stoF,hV,hB) Abt

| E_Blookup_AbtHp : forall stoV stoB stoF hV hB b bk n,
                      (bkeval stoV stoB stoF bk) = Some n ->
                      hB n = None ->
                      big_step (CBlookup b bk) (stoV,stoB,stoF,hV,hB) Abt

| E_Bass : forall stoV stoB stoF hV hB b bk n,
              (bkeval stoV stoB stoF bk) = Some n ->
              big_step (CBlookup b bk) (stoV,stoB,stoF,hV,hB)
                       (St (stoV,(st_updateB stoB b n),stoF,hV,hB))

| E_Bass_Abt : forall stoV stoB stoF hV hB b bk,
                (bkeval stoV stoB stoF bk) = None ->
                big_step (CBlookup b bk) (stoV,stoB,stoF,hV,hB) Abt

| E_Bmutat : forall stoV stoB stoF hV hB bk1 bk2 n1 n2,
                (bkeval stoV stoB stoF bk1) = Some n1 ->
                (bkeval stoV stoB stoF bk2) = Some n2 ->
                big_step (CBmutat bk1 bk2) (stoV,stoB,stoF,hV,hB)
                         (St (stoV,stoB,stoF,hV,(h_updateB hB n1 n2)))

| E_Bmutat_AbtBk1 : forall stoV stoB stoF hV hB bk1 bk2,
                      (bkeval stoV stoB stoF bk1) = None ->
                      big_step (CBmutat bk1 bk2) (stoV,stoB,stoF,hV,hB) Abt

| E_Bmutat_AbtBk2 : forall stoV stoB stoF hV hB bk1 bk2 n1,
                      (bkeval stoV stoB stoF bk1) = Some n1 ->
                      (bkeval stoV stoB stoF bk2) = None ->
                      big_step (CBmutat bk1 bk2) (stoV,stoB,stoF,hV,hB) Abt

| E_Bdelete : forall stoV stoB stoF hV hB bk,
                big_step (CBdelete bk) (stoV,stoB,stoF,hV,hB)
                         (St (stoV,stoB,stoF,hV,hB)).

Notation "c1 '/' st '\\' opst" := (big_step c1 st opst)
                                  (at level 40, st at level 39).


Require Import Arith.

Definition Nat : Type :=
  forall A : Type, (A -> A) -> (A -> A).

Definition NatPlus(n m : Nat) : Nat :=
  fun A f x => n A f (m A f x).

Definition nat2Nat : nat -> Nat := nat_iter.

Definition Nat2nat(n : Nat) : nat := n _ S O.

Lemma NatPlus_plus :
  forall n m, Nat2nat (NatPlus (nat2Nat n) (nat2Nat m)) = n + m.
Proof.
  assert (forall n m : nat, nat_iter n S m = n + m).
    intros.
    induction n.
    - reflexivity.
    - simpl; apply eq_S; assumption.
  - intros.
  unfold nat2Nat; unfold Nat2nat; unfold NatPlus.
  repeat rewrite H.
  rewrite plus_0_r.
  reflexivity.
Qed.


Require Import Bool ZArith micromega.Lia.

From BY Require Import Matrix Divstep Zpower_nat Impl.
From BY.Hierarchy Require Import Definitions BigOp.

Local Open Scope Z_scope.
Local Open Scope mat_scope.
Local Open Scope vec_scope.

Local Open Scope ring_scope.
Local Open Scope lmod_scope.

Import Z.

(* Notation big_mmult_rev := (fun n m f => @big_op_rev _ mmult I f n m). *)

Theorem _9_1_1 d f g (n m : nat) : (m <= n)%nat -> Z.odd f = true ->
    2 ^+ (n - m) ⋅ [ fn d f g n , gn d f g n ] ≡
    big_mul_rev (fun i => Tn d f g i) m n ⋅ [ fn d f g m , gn d f g m ].
Proof.
  revert m. induction n; intros.
  - replace m with 0%nat by lia; auto_mat.
  - destruct (Nat.eq_dec m (S n)).
    + subst. rewrite big_op_rev_nil.

      rewrite Nat.sub_diag.
      auto_mat; lia. lia.
    + rewrite <- minus_Sn_m. rewrite <- Zpower_nat_mul_r.
      rewrite (left_act_assoc (⋅) Z.mul). rewrite Tn_transition.
      rewrite scvec_vmult, scmat_vmult_swap.
      rewrite IHn.
      rewrite <- (left_act_assoc (⋅) [*]).
      rewrite <- (big_op_rev_S_l [*] 1). reflexivity. all: try lia; assumption. Qed.

Theorem _9_1_2 d f g (n m : nat) : (m <= n)%nat -> odd f = true ->
    [ 1 , dn d f g n  ] ≡
    big_mul_rev (fun i => Sn d f g i) m n ⋅ [ 1 , dn d f g m ].
Proof.
  revert m. induction n; intros.
  - replace m with 0%nat by lia. auto_mat.
  - destruct (Nat.eq_dec m (S n)).
    + subst. rewrite big_op_rev_nil. auto_mat. lia.
    + rewrite Sn_transition. rewrite IHn with (m:=m).
      rewrite <- (left_act_assoc (⋅) [*]). rewrite <- (big_op_rev_S_l [*] 1). reflexivity. all: try lia; assumption. Qed.


(* Alumno: Agustín Mista *)
(* Fecha:        2/11/17 *)

(* ------------------------------ *)
(*          Ejercicio 1           *)
(* ------------------------------ *)
Section Ejercicio1.

  Variable LEAL : Prop.        (* El general es leal *)
  Variable OBEDECE : Prop.     (* El general obedece las órdenes *)
  Variable INTELIGENTE : Prop. (* El general es inteligente *)
  Variable COMPRENDE : Prop.   (* El general comprende las órdenes *)

  (* Si el general era leal, habría obedecido las órdenes. *)
  Hypothesis H1 : LEAL -> OBEDECE.

  (* Si el general era inteligente, las habría comprendido (las órdenes). *)
  Hypothesis H2 : INTELIGENTE -> COMPRENDE.

  (* O el general desobedeció las órdenes o no las comprendió. *)
  Hypothesis H3 : ~OBEDECE \/ ~COMPRENDE.

  (* Luego, el general era desleal o no era inteligente. *)
  Lemma lemma1 : ~LEAL \/ ~INTELIGENTE.
  Proof.
    unfold not in *.
    elim H3; [left | right]; intros; apply H; [apply H1 | apply H2]; assumption.
  Qed.

End Ejercicio1.

(* ------------------------------ *)
(*          Ejercicio 2           *)
(* ------------------------------ *)
Section Ejercicio2.

  Require Import Classical.

  Variable C : Set.
  Variable P : C -> C -> Prop.

  Lemma lemma2 : (exists x y : C, P x y) \/ ~(exists x : C, P x x).
  Proof.
    unfold not in *.
    elim classic with (P := exists x y : C, P x y).
    - left. assumption.
    - right. intros. elim H. elim H0. intros. exists x. exists x. assumption.
  Qed.

End Ejercicio2.

(* ------------------------------ *)
(*          Ejercicio 3           *)
(* ------------------------------ *)
Section Ejercicio3.

  Variable U : Set.
  Variable a : U.
  Variables P Q R T : U -> Prop.

  (* 3.1 *)
  Lemma Ej3_1 : (forall x : U, P x -> Q x) -> P a -> Q a.
  Proof.
    intros. exact (H a H0).
  Qed.

  (* 3.2 *)
  Lemma Ej3_2 : (forall x : U, P x -> Q x) -> (forall x : U, Q x -> R x)
                -> (forall x : U, P x -> R x).
  Proof.
    intros. exact (H0 x (H x H1)).
  Qed.

  (* 3.3 *)
  Lemma Ej3_3 : (forall x : U, Q x) \/ (forall y : U, T y)
                -> forall z : U, Q z \/ T z.
  Proof.
    intros. elim H; intros; [left | right]; exact (H0 z).
  Qed.

End Ejercicio3.

(* ------------------------------ *)
(*          Ejercicio 4           *)
(* ------------------------------ *)
Section Ejercicio4.

  Parameter ABnat : forall n : nat, Set.

  (* 4.1 *)
  Parameter null : ABnat O.

  (* 4.2 *)
  Parameter add : forall n m: nat, ABnat n -> nat -> ABnat m -> ABnat (n+m+1).

  (* 4.3 *)
  Definition leftTree : ABnat 1 := add 0 0 null 7 null.
  Definition rightTree : ABnat 1 := add 0 0 null 9 null.
  Definition myTree : ABnat 3 := add 1 1 leftTree 8 rightTree.

End Ejercicio4.


Require Export A003induction.

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.
Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Notation "( x , y )" := (pair x y).

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity.
Qed.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intro p.
  destruct p.
  reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intro.
  destruct p.
  reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intro.
  destruct p.
  reflexivity.
Qed.

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | 0 => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => 0
  | h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
    | nil => nil
    | h :: t => match h with
                 | 0 => nonzeros t
                 | _ => h :: nonzeros t
               end
  end.

Example test_nonzeros: nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
    | nil => nil
    | h :: t => match oddb h with
                 | false => oddmembers t
                 | true => h :: oddmembers t
               end
  end.

Example test_oddmembers: oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity. Qed.

Definition countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers2: countoddmembers [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers3: countoddmembers nil = 0.
Proof. reflexivity. Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1 with
    | [] => l2
    | h1 :: t1 => match l2 with
                    | [] => l1
                    | h2 :: t2 => h1 :: h2 :: alternate t1 t2
                  end
  end.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity. Qed.
Example test_alternate2: alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.
Example test_alternate3: alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity. Qed.
Example test_alternate4: alternate [] [20;30] = [20;30].
Proof. reflexivity. Qed.

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
    | [] => 0
    | h :: t => match (beq_nat h v) with
                  | true => S (count v t)
                  | false => count v t
                end
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag := v :: s.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.
Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition bge_nat (n m:nat) : bool :=
  negb (blt_nat n m).

Definition member (v:nat) (s:bag) : bool :=
  (bge_nat (count v s) 1).

Example test_member1: member 1 [1;4;1] = true.
Proof. reflexivity. Qed.
Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
    | [] => []
    | h :: t => match (beq_nat v h) with
                  | true => t
                  | false => h :: remove_one v t
                end
  end.

Example test_remove_one1: count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one2: count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one3: count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_one4: count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
    | [] => []
    | h :: t => match (beq_nat v h) with
                  | true => remove_all v t
                  | false => h :: remove_all v t
                end
  end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint subset (s__1:bag) (s__2:bag) : bool :=
  match s__1 with
    | [] => true
    | h :: t => match count h s__2 with
                 | 0 => false
                 | _ => subset t (remove_one h s__2)
               end
  end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.
Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

Theorem bag_add_count: forall (b : bag) (i : nat),
  count i (add i b) = S (count i b).
Proof.
  intros.
  destruct b.
  Case "b = []".
    replace (add i []) with [i].
    replace (count i []) with 0.
    simpl.
    replace (beq_nat i i) with true.
    reflexivity.
    SCase "beq_nat i i = true".
      rewrite <- beq_nat_refl.
      reflexivity.
    SCase "0 = count i []".
      reflexivity.
    SCase "[i] = add i []".
      reflexivity.

  Case "b = add i b".
    replace (add i (n :: b)) with (i :: n :: b).
    replace (count i (i :: n :: b)) with
      (S (count i (n :: b))).
    reflexivity.
    SCase "S (count i (n :: b)) = count i (i :: n :: b)".
      simpl.
      rewrite <- beq_nat_refl.
      reflexivity.
    SCase "i :: n :: b = add i (n :: b)".
      reflexivity.
Qed.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intro.
  destruct l.
  reflexivity.
  simpl. reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = cons n l1'".
    simpl. rewrite -> IHl1'. reflexivity. Qed.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2.
  induction l1 as [| n l1'].
  reflexivity.
  simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint snoc (l:natlist) (v:nat) : natlist :=
  match l with
    | [] => [v]
    | h :: t => h :: snoc t v
  end.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => snoc (rev t) h
  end.
Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = []".
    reflexivity.
  Case "l = n :: l'".
    (* This is the tricky case.  Let's begin as usual
       by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality
       involving snoc, but we don't have any equations
       in either the immediate context or the global
       environment that have anything to do with snoc!

       We can make a little progress by using the IH to
       rewrite the goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Abort.

Theorem length_snoc : forall n : nat, forall l : natlist,
  length (snoc l n) = S (length l).
Proof.
  intros n l.
  induction l.
  reflexivity.
  simpl. rewrite <- IHl. reflexivity.
Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intro l.
  induction l.
  reflexivity.
  simpl. rewrite length_snoc. rewrite IHl. reflexivity.
Qed.

Theorem app_nil_end : forall l : natlist,
  l ++ [] = l.
Proof.
  intro l.
  induction l.
  reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Lemma rev_snoc_rev : forall t : natlist, forall h : nat,
                       rev (snoc (rev t) h) = h :: rev (rev t).
Proof.
  intros.
  induction t.
  reflexivity.
  simpl.

  replace (rev (snoc (rev t) n)) with (n :: (rev (rev t))).
Abort.

Theorem snoc_append : forall (l:natlist) (n:nat),
  snoc l n = l ++ [n].
Proof.
  intros.
  induction l.
  reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Lemma cons_rev : forall n : nat, forall l : natlist,
                   n :: rev l = rev (l ++ [n]).
Proof.
  intros.
  induction l.
  reflexivity.
  simpl.
  rewrite <- IHl.
  simpl.
  reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intro l.
  induction l as [| h t].
  Case "l = []".
    reflexivity.
  Case "l = h :: t".
    simpl.
    replace (rev (snoc (rev t) h)) with (h :: rev (rev t)).
    rewrite IHt.
    reflexivity.
    SCase "h :: rev (rev t) = rev (snoc (rev t) h)".
      rewrite IHt.
      rewrite snoc_append.
      rewrite <- cons_rev.
      rewrite IHt.
      reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  reflexivity.
Qed.

Lemma app_nil_r : forall l : natlist,
                    l ++ [] = l.
Proof.
  induction l. reflexivity. simpl. rewrite IHl. reflexivity.
Qed.

Theorem distr_rev : forall l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros.
  induction l1 as [| h1 t1].
  Case "l1 = []".
    simpl.
    rewrite app_nil_r.
    reflexivity.
  Case "l1 = h1 :: t1".
    simpl.
    rewrite snoc_append.
    rewrite IHt1.
    rewrite app_assoc.
    rewrite snoc_append.
    reflexivity.
Qed.

Lemma cons_app_assoc : forall h : nat, forall l1 l2 : natlist,
                         (h :: l1) ++ l2 = h :: l1 ++ l2.
Proof. intros. reflexivity. Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  induction l1 as [| h1 t1].
  Case "l1 = []".
    reflexivity.
  Case "l1 = h1 :: t1".
    rewrite cons_app_assoc.
    induction h1 as [| h1'].
    SCase "h1 = 0".
      simpl.
      rewrite IHt1.
      reflexivity.
    SCase "h1 = S h1'".
      simpl.
      rewrite IHt1.
      reflexivity.
Qed.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l2 with
    | [], [] => true
    | h1 :: t1, [] => false
    | [], h2 :: t2 => false
    | h1 :: t1, h2 :: t2 =>
      (andb (beq_nat h1 h2) (beq_natlist t1 t2))
  end.

Example test_beq_natlist1 : (beq_natlist nil nil = true).
Proof. reflexivity. Qed.
Example test_beq_natlist2 : beq_natlist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.
Example test_beq_natlist3 : beq_natlist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intro.
  induction l.
  reflexivity.
  simpl.
  rewrite <- beq_nat_refl.
  rewrite <- IHl.
  reflexivity.
Qed.

Theorem count_member_nonzero : forall (s : bag),
  ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  reflexivity.
Qed.  (* WHAT THE ****!! YOU'RE SO AMAZING COQ!! *)

Theorem ble_n_Sn : forall n,
  ble_nat n (S n) = true.
Proof.
  intros n. induction n as [| n'].
  Case "0".
    simpl. reflexivity.
  Case "S n'".
    simpl. rewrite IHn'. reflexivity. Qed.

Theorem remove_decreases_count: forall (s : bag),
  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intro.
  induction s.
  Case "s = []". reflexivity.
  Case "s = n :: s".
    induction n.
    SCase "n = 0".
      simpl.
      rewrite ble_n_Sn.
      reflexivity.
    SCase "n = S n".
      simpl.
      rewrite IHs.
      reflexivity.
Qed.

Theorem bag_count_sum: forall s1 s2 : bag,
  count 0 (sum s1 s2) = count 0 s1 + count 0 s2.
Proof.
  intros.
  induction s1, s2.
  Case "s1 = [], s2 = []". reflexivity.
  Case "s1 = [], s2 = n :: s2". reflexivity.
  Case "s1 = n :: s1, s2 = []".
    induction n.
    SCase "n = 0".
      rewrite plus_0_r.
      rewrite app_nil_r.
      reflexivity.
    SCase "n = S n".
      rewrite plus_0_r.
      rewrite app_nil_r.
      reflexivity.
  Case "s1 = n0 :: s1, s2 = n :: s2".
    induction n0, n; (simpl; rewrite IHs1; reflexivity).
(*
    induction n0, n.
    SCase "n0 = n = 0".
      simpl. rewrite IHs1.
      reflexivity.
    SCase "n0 = 0, n = S n".
      simpl. rewrite IHs1.
      reflexivity.
    SCase "n0 = S n0, n = 0".
      simpl. rewrite IHs1.
      reflexivity.
    SCase "n0 = S n0, n = S n".
      simpl. rewrite IHs1.
      reflexivity.
*)
Qed.

(* this question is a four-star exercise.

  my idea is to apply induction on l1 and l2, then deny all false assumptions:
   - l1 = [], l2 <> []
   - l1 <> [], l1 = []
  and prove the true assumptions:
   - l1 = l2 = []
   - l1 = l2 <> []

  currently i have no idea about how to cope with such false hypotheses.
 *)
Theorem rev_injective: forall (l1 l2 : natlist),
                         rev l1 = rev l2 -> l1 = l2.
Proof.
  intros.
  assert (rev (rev l1) = rev (rev l2)).
  rewrite H. reflexivity.

  rewrite rev_involutive in H0.
  rewrite rev_involutive in H0.
  assumption.
Qed.

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Fixpoint index (n:nat) (l:natlist) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n 0 with
               | true => Some a
               | false => index (pred n) l'
               end
  end.

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

Example test_index1 : index 0 [4;5;6;7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 3 [4;5;6;7] = Some 7.
Proof. reflexivity. Qed.
Example test_index3 : index 10 [4;5;6;7] = None.
Proof. reflexivity. Qed.

Fixpoint index' (n:nat) (l:natlist) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n 0 then Some a else index' (pred n) l'
  end.

Definition hd_opt (l : natlist) : natoption :=
  match l with
    | nil => None
    | a :: _ => Some a
  end.

Example test_hd_opt1 : hd_opt [] = None.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt3 : hd_opt [5;6] = Some 5.
Proof. reflexivity. Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_opt l).
Proof.
  intros.
  induction l.
  reflexivity.
  reflexivity.
Qed.

Module Dictionary.

Inductive dictionary : Type :=
  | empty : dictionary
  | record : nat -> nat -> dictionary -> dictionary.

Definition insert (key value : nat) (d : dictionary) : dictionary :=
  (record key value d).

Fixpoint find (key : nat) (d : dictionary) : natoption :=
  match d with
  | empty => None
  | record k v d' => if (beq_nat key k)
                       then (Some v)
                       else (find key d')
  end.

Theorem dictionary_invariant1' : forall (d : dictionary) (k v: nat),
  (find k (insert k v d)) = Some v.
Proof.
  intros.
  induction d.
  Case "d = {}".
    simpl.
    rewrite <- beq_nat_refl.
    reflexivity.
  Case "d = (k:v)::d".
    simpl.
    rewrite <- beq_nat_refl.
    reflexivity.
Qed.

Theorem dictionary_invariant2' : forall (d : dictionary) (m n o: nat),
  beq_nat m n = false -> find m d = find m (insert n o d).
Proof.
  intros.
  simpl.
  rewrite H.
  reflexivity.
Qed.

End Dictionary.


(*
  10152160137 陈弈君 homeowork 9
*)

Set Warnings "-notation-overridden,-parsing".
Require Export IndProp.

(* 1 *)
Print le.
Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H.
  - apply le_n.
  - Print le. apply le_S. apply IHle.
Qed.

(* 2 *)
Theorem n_le_Sn : forall n, n <= S n.
Proof. intros. apply le_S. apply le_n. Qed.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros. inversion H.
  - apply le_n.
  - apply le_trans with (n := S n). apply n_le_Sn. apply H1.
Qed.

(* 3 *)
Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  intros. induction a.
  - simpl. apply O_le_n.
  - simpl. apply n_le_m__Sn_le_Sm. apply IHa.
Qed.

(* 4 *)
Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
  unfold lt. intros. split.
  - induction H. apply n_le_m__Sn_le_Sm.
    + apply le_plus_l.
    + apply le_S. apply IHle.
  - induction H.
    + apply n_le_m__Sn_le_Sm. rewrite -> plus_comm. apply le_plus_l.
    + apply le_S. apply IHle.
Qed.

(* 5 *)
Theorem lt_S : forall n m,
  n < m ->
  n < S m.
Proof.
  unfold lt. intros. apply le_S. apply H.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rtrigo_def.
Require Reals.Rpower.
Require BuiltIn.
Require real.Real.

Import Rtrigo_def.
Import Rpower.

(* Why3 comment *)
(* exp is replaced with (Reals.Rtrigo_def.exp x) by the coq driver *)

(* Why3 goal *)
Lemma Exp_zero : ((Reals.Rtrigo_def.exp 0%R) = 1%R).
exact exp_0.
Qed.

Require Import Exp_prop.

(* Why3 goal *)
Lemma Exp_sum : forall (x:R) (y:R),
  ((Reals.Rtrigo_def.exp (x + y)%R) = ((Reals.Rtrigo_def.exp x) * (Reals.Rtrigo_def.exp y))%R).
exact exp_plus.
Qed.

(* Why3 comment *)
(* log is replaced with (Reals.Rpower.ln x) by the coq driver *)

(* Why3 goal *)
Lemma Log_one : ((Reals.Rpower.ln 1%R) = 0%R).
exact ln_1.
Qed.

(* Why3 goal *)
Lemma Log_mul : forall (x:R) (y:R), ((0%R < x)%R /\ (0%R < y)%R) ->
  ((Reals.Rpower.ln (x * y)%R) = ((Reals.Rpower.ln x) + (Reals.Rpower.ln y))%R).
intros x y (Hx,Hy).
now apply ln_mult.
Qed.

(* Why3 goal *)
Lemma Log_exp : forall (x:R),
  ((Reals.Rpower.ln (Reals.Rtrigo_def.exp x)) = x).
exact ln_exp.
Qed.

(* Why3 goal *)
Lemma Exp_log : forall (x:R), (0%R < x)%R ->
  ((Reals.Rtrigo_def.exp (Reals.Rpower.ln x)) = x).
exact exp_ln.
Qed.

(* Why3 assumption *)
Definition log2 (x:R): R := ((Reals.Rpower.ln x) / (Reals.Rpower.ln 2%R))%R.

(* Why3 assumption *)
Definition log10 (x:R): R :=
  ((Reals.Rpower.ln x) / (Reals.Rpower.ln 10%R))%R.


From Coq Require Export NArith List.
From Coq Require Import Arith Sorting Orders OrdersEx Lia.
Import ListNotations.

Add Search Blacklist "N_as".

#[global] Open Scope N_scope.

Notation "'input' x ',' .. ',' y" := (cons x .. (cons y nil) ..)
  (at level 200, x constr at level 0).

Definition example := input
16,1,2,0,4,2,7,1,2,14
.

Module NTotalOrder := OTF_to_TTLB N_as_OT.
Module SortN := Sort NTotalOrder.

Definition median (xs : list N) : N :=
  match skipn (length xs / 2)%nat xs with
  | [] => 0
  | x :: _ => x
  end.

Definition sum_N : list N -> N := fold_right N.add 0%N.

(* |x-y| *)
Definition dist (x y : N) : N := if x <=? y then y - x else x - y.

Definition solve (xs : list N) : N :=
  let xs := SortN.sort xs in
  sum_N (map (dist (median xs)) xs).

(* Compute solve example. *)

Definition dist2 (x y : N) : N :=
  let d := dist x y in
  d * (d + 1) / 2.

(* Cost to move everyone starting at positions [xs] to the same position [y]. *)
Definition fuel2 (xs : list N) (y : N) : N :=
  sum_N (map (dist2 y) xs).

Fixpoint searchMin (n : nat) (f : N -> N) (low width : N) : N * N :=
  match n with O => (0, 0) | S n =>
  let il := width / 2 in
  let xl := low + il in
  let xr := low + il + 1 in
  let fl := f xl in
  let fr := f xr in
  match 1 <? width with
  | true =>
    if fl <=? fr then searchMin n f low il
    else searchMin n f xr (width - il - 1)
  | false =>
    if (0 =? width)%N || (fl <=? fr)%N then (xl, fl) else (xr, fr)
  end
  end.

Fixpoint maximum (xs : list N) : N :=
  match xs with
  | [] => 0
  | [x] => x
  | x :: xs => N.max x (maximum xs)
  end.

Definition solve2 (xs : list N) : N :=
  let f n := fuel2 xs n in
  let m := maximum xs in
  snd (searchMin (S (N.to_nat m)) f 0 m).

(* Compute solve2 example. *)

Definition solve12 (xs : list N) : N * N := (solve xs, solve2 xs).

Definition Convex (f : N -> N) : Prop :=
  forall i j k, (j+k) * f (i+j) <= k * f i + j * f (i+j+k).

Definition LocallyConvex (f : N -> N) : Prop :=
  forall i, 2 * f (i+1) <= f i + f (i+2).

Definition Predecreasing (f : N -> N) : Prop :=
  forall i j, i < j -> f j <= f i -> forall k, k <= i -> f i <= f k.

Definition Postincreasing (f : N -> N) : Prop :=
  forall i j, i < j -> f i <= f j -> forall k, j <= k -> f j <= f k.

Definition VShaped (f : N -> N) : Prop := Predecreasing f /\ Postincreasing f.

Lemma cancel_add_sub : forall a b c, c <= b -> (a + c) + (b - c) = a + b.
Proof.
  intros; rewrite N.add_sub_assoc; lia.
Qed.

Ltac forward H :=
  match type of H with
  | (?Y -> _) => let Z := fresh in assert (Z : Y); [ | specialize (H Z) ]
  end.

Lemma searchMin_sound n f
  : forall low width, width < N.of_nat n ->
    let x := searchMin n f low width in
    low <= fst x <= low + width
      /\ snd x = f (fst x).
Proof.
  induction n; cbn [searchMin]; intros; [ lia | ].
  rewrite Nat2N.inj_succ in H.
  destruct (N.ltb_spec 1 width).
  - assert (HH : width / 2 < width).
    { apply N.div_lt_upper_bound; lia. }
    destruct (_ <=? _).
    { eapply Morphisms_Prop.and_impl_morphism; [ | exact (fun X => X) | apply IHn; lia ].
      intros ?; lia. }
    { eapply Morphisms_Prop.and_impl_morphism; [ | exact (fun X => X) | apply IHn ].
      { eapply Morphisms_Prop.and_impl_morphism.
        { red; apply N.le_trans. remember (width / 2). lia. }
        { refine (fun X => N.le_trans _ _ _ X _). lia. } }
      eapply N.le_lt_trans.
      { apply N.sub_le_mono_r. apply N.le_sub_l. }
      lia. }
  - destruct (N.eqb_spec 0 width).
    { subst width; cbn. rewrite N.add_0_r. split; [ split | ]; reflexivity. }
    destruct (_ <=? _) eqn:E; cbn; split; try reflexivity.
    all: apply N.le_1_r in H0; destruct H0 as [-> | ->]; cbn; lia.
Qed.

Lemma searchMin_correct n f (Hf : VShaped f)
  : forall low width,
    width < N.of_nat n ->
    forall i, i <= width -> snd (searchMin n f low width) <= f (low+i).
Proof.
  induction n; [ (* contradiction *) lia | ]. intros; cbn [searchMin].
  rewrite Nat2N.inj_succ in H.
  destruct (N.ltb_spec 1 width).
  - assert (HH : width / 2 < width).
    { apply N.div_lt_upper_bound; lia. }
    assert (coIH : width / 2 < N.of_nat n) by lia.
    destruct (N.leb_spec (f (low + width / 2)) (f (low + width / 2 + 1))).
    + specialize (IHn low (width / 2) coIH).
      destruct (N.leb_spec i (width / 2)).
      { apply IHn; assumption. }
      { etransitivity; [ apply IHn; reflexivity | ].
        rewrite H2.
        eapply (proj2 Hf); [ | apply H2 | ]; lia. }
    + specialize (IHn (low + width / 2 + 1) (width - width / 2 - 1)).
      forward IHn.
      { eapply N.le_lt_trans.
        { apply N.sub_le_mono_r. apply N.le_sub_l. }
        lia. }
      destruct (N.ltb_spec i (width / 2 + 1)).
      { etransitivity; [ apply (IHn 0); lia | ].
        rewrite N.add_0_r.
        apply N.lt_le_incl in H2. rewrite H2.
        eapply (proj1 Hf); [ | apply H2 | ]; lia. }
      { replace i with (width / 2 + 1 + (i - (width / 2 + 1))) by lia.
        rewrite 2 N.add_assoc. apply IHn. lia. }
  - destruct (N.eqb_spec 0 width); cbn.
    { subst width; cbn. apply N.le_0_r in H0. subst. reflexivity. }
    destruct (N.leb_spec (f (low + width / 2)) (f (low + width / 2 + 1))) as [e | e]; cbn.
    all: apply N.le_1_r in H1; destruct H1 as [-> | ->]; cbn; try contradiction.
    all: apply N.le_1_r in H0; destruct H0 as [-> | ->]; cbn.
    all: cbn in e; try rewrite N.add_0_r in *; try reflexivity; lia.
Qed.

Lemma Convex_additive f g : Convex f -> Convex g -> Convex (fun i => f i + g i).
Proof.
  unfold Convex; intros Hf Hg i j k. specialize (Hf i j k). specialize (Hg i j k). lia.
Qed.

Lemma Convex_constant i : Convex (fun _ => i).
Proof.
  unfold Convex; lia.
Qed.

Lemma Convex_summative {A} (f : A -> N -> N)
  : (forall z, Convex (f z)) -> forall xs, Convex (fun i => sum_N (map (fun x => f x i) xs)).
Proof.
  intros Hf; induction xs; cbn.
  - apply Convex_constant.
  - apply Convex_additive; auto.
Qed.

Lemma div_mul : forall n m, n mod m = 0 -> n / m * m = n.
Proof.
  intros. rewrite (N.div_mod' n m) at 2. rewrite H, N.add_0_r. lia.
Qed.

Lemma conseq_even : forall n, (n * (n+1)) mod 2 = 0.
Proof.
  intros n. assert (H := N.mod_bound_pos n 2). destruct H as [_ H]; [lia ..| ].
  apply N.lt_le_pred in H.
  apply N.le_1_r in H.
  rewrite <- N.mul_mod_idemp_l by lia.
  destruct H as [ H | H ]; rewrite H.
  - reflexivity.
  - rewrite N.mul_1_l. rewrite <- N.add_mod_idemp_l by lia. rewrite H. reflexivity.
Qed.

Lemma minus_minus m n p : n <= m -> p <= n -> m - n + p = m - (n - p).
Proof.
  lia.
Qed.

Lemma LocallyConvex_dist2_2 : forall z, LocallyConvex (fun i => dist2 i z).
Proof.
  unfold Convex, dist2, dist. intros z i.
  repeat lazymatch goal with
    | [ |- context [ ?x <=? ?y ] ] => destruct (N.leb_spec x y); cbn - [N.add N.sub N.mul]
    end.
  all: try lia.
  all: apply (N.mul_le_mono_pos_r _ _ 2); [ lia | ].
  all: rewrite (N.mul_add_distr_r _ _ 2).
  all: rewrite <- !(N.mul_assoc _ _ 2).
  all: rewrite !div_mul by apply conseq_even.
  all: try lia.
  - rewrite minus_minus, N.add_sub by lia.
    replace (z - (i+1)) with ((z-i)-1) by lia.
    replace (z - (i+2) + 1) with ((z-i)-1) by lia.
    replace (z - (i+2)) with ((z-i)-2) by lia.
    rewrite ?(N.mul_add_distr_l (z-i)), ?(N.mul_add_distr_r (z-i)), ?(N.mul_sub_distr_l (z-i)), ?(N.mul_sub_distr_r (z-i)).
    remember ((z-i) * (z-i)) as ZZ.
    lia.
  - replace z with (i+1) by lia. lia.
  - replace z with i by lia. lia.
Qed.

Instance Proper_mul_le : Proper (N.le ==> N.le ==> N.le) N.mul.
Proof.
  unfold Proper, respectful. auto using N.mul_le_mono.
Qed.

Instance Proper_add_le : Proper (N.le ==> N.le ==> N.le) N.add.
Proof.
  unfold Proper, respectful. auto using N.add_le_mono.
Qed.

Lemma add_twice n : n + n = 2 * n.
Proof.
  lia.
Qed.

Lemma Convex_LocallyConvex f : LocallyConvex f -> Convex f.
Proof.
  unfold LocallyConvex, Convex. intros Hf.
  intros i j k; revert i j; induction k as [ | k IH ] using N.peano_ind; intros i j.
  - rewrite N.mul_0_l, !N.add_0_r. lia.
  - rewrite !N.add_succ_r, N.mul_succ_l.
    etransitivity; [ rewrite <- N.add_le_mono_r; apply IH | ].
    enough (j * f (i + j + k) + f (i + j) <= f i + j * f (N.succ (i + j + k))) by lia.
    clear IH.
    revert i j; induction k as [ | k IH ] using N.peano_ind; intros i j.
    + rewrite N.add_0_r, <- N.mul_succ_l.
      induction j as [ | j IH] using N.peano_ind.
      * rewrite N.add_0_r, !N.mul_0_l. lia.
      * rewrite (N.add_le_mono_r _ _ (N.succ j * f (i + N.succ j))).
        rewrite N.mul_succ_l. rewrite N.add_shuffle0, add_twice, N.mul_shuffle3, N.add_succ_r, <- (N.add_1_r (i + j)).
        rewrite (Hf (i+j)).
        rewrite N.mul_add_distr_l, IH. rewrite <- N.add_1_r.
        replace (N.succ (i + j + 1)) with (i + j + 2) by lia. lia.
    + rewrite (N.add_le_mono_r _ _ (j * f (i + j + N.succ k))).
      rewrite N.add_shuffle0, add_twice, N.mul_shuffle3.
      replace (i + j + N.succ k) with (i + j + k + 1) by lia.
      rewrite Hf.
      replace (N.succ (i + j + k + 1)) with (i + j + k + 2) by lia.
      rewrite !N.mul_add_distr_l.
      rewrite N.add_shuffle0.
      rewrite IH.
      replace (N.succ (i + j + k)) with (i + j + k + 1) by lia.
      lia.
Qed.

Lemma Postincreasing_Convex f : Convex f -> Postincreasing f.
Proof.
  unfold Convex, Postincreasing; intros Hf i j Eij Fij k Ejk. revert Fij.
  replace k with (j + (k - j)) in * by lia; generalize (k-j).
  replace j with (i + (N.pred (j - i) + 1)) in * by lia; generalize (N.pred (j-i)).
  clear j k Eij Ejk. intros j k. intros Fj.
  specialize (Hf i (j + 1) k).
  rewrite N.mul_add_distr_r in Hf.
  rewrite Fj in Hf.
  rewrite (N.add_comm (_ * _)) in Hf.
  rewrite <- N.add_le_mono_l in Hf.
  rewrite <- N.mul_le_mono_pos_l in Hf by lia.
  lia.
Qed.

Lemma Predecreasing_Convex f : Convex f -> Predecreasing f.
Proof.
  unfold Convex, Predecreasing; intros Hf i j Eij Fij k Ejk. revert Fij.
  replace j with (i + (N.pred (j - i) + 1)) in * by lia; generalize (N.pred (j-i)).
  replace i with (k + (i - k)) in * by lia; generalize (i-k).
  clear i j Eij Ejk. intros i j. intros Fj.
  specialize (Hf k i (j+1)).
  rewrite N.mul_add_distr_r in Hf.
  rewrite Fj in Hf.
  rewrite (N.add_comm (_ * _)) in Hf.
  rewrite <- N.add_le_mono_r in Hf.
  rewrite <- N.mul_le_mono_pos_l in Hf by lia.
  lia.
Qed.

Lemma VShaped_Convex f : Convex f -> VShaped f.
Proof.
  constructor.
  - apply Predecreasing_Convex; auto.
  - apply Postincreasing_Convex; auto.
Qed.

Lemma Convex_fuel2 : forall z, Convex (fuel2 z).
Proof.
  intros z; apply Convex_summative.
  intros z'; apply Convex_LocallyConvex, LocallyConvex_dist2_2.
Qed.

Theorem solve2_correct xs
  : exists i, solve2 xs = fuel2 xs i /\ forall j, j <= maximum xs -> fuel2 xs i <= fuel2 xs j.
Proof.
  unfold solve2.
  exists (fst (searchMin (S (N.to_nat (maximum xs))) (fuel2 xs) 0 (maximum xs))).
  assert (Hmax : forall i, i < N.of_nat (S (N.to_nat i))) by lia.
  refine ((fun I J => conj I (J I)) _ _).
  - apply (searchMin_sound _ _ _ _ (Hmax _)).
  - intros E j Hj. rewrite <- E. apply searchMin_correct with (low := 0).
    + apply VShaped_Convex, Convex_fuel2.
    + apply Hmax.
    + apply Hj.
Qed.


(** An Ssreflect Tutorial *)

(** http://hal.archives-ouvertes.fr/docs/00/40/77/78/PDF/RT-367.pdf  *)

Require Import ssreflect ssrbool eqtype ssrnat ssrfun.

(** 3 Arithmetic for Euclidean division *)
(** ユーグリッド互除法 *)

(* 3.2 Deﬁnitions *)

Fixpoint edivn_rec (d m q : nat) : nat*nat :=
  if m - d is m'.+1 then edivn_rec d m' q.+1 else (q, m).
Eval compute in edivn_rec 3 7 1.            (* (2,3) *)

Definition edivn_rec'' d :=
  fix loop (m q : nat) {struct m} :=
  if m - d is m'.+1 then loop m' q.+1 else (q, m).
Eval compute in edivn_rec'' 3 7 1.            (* (2,3) *)

Definition edivn m d :=                     (* 商と余 *)
  if d > 0 then edivn_rec d.-1 m 0 else (0, m).
Eval compute in edivn 7 3.

Definition edivn_rec2 d := fix loop (m q : nat) {struct m} := (* 不使用 *)
  if m - (d - 1) is m'.+1 then loop m' q.+1 else (q, m).
Eval compute in edivn_rec2 4 7 1.            (* (2,3) *)

Definition edivn2 m d :=                    (* 不使用 *)
  if d > 0 then edivn_rec2 d m 0 else (0, m).

CoInductive edivn_spec (m d : nat) : nat * nat -> Type :=
  EdivnSpec q r of (m = q * d + r) & ((d > 0) ==> (r < d)) :
    edivn_spec m d (q, r).
Eval compute in (EdivnSpec 7 3 2 1).       (* 7 / 3 = 2 ... 1 *)
(* :  7 = 2 * 3 + 1 -> (0 < 3) ==> (1 < 3) -> edivn_spec 7 3 (2, 1) *)

(* 3.3 Results *)

Lemma edivnP : forall m d, edivn_spec m d (edivn m d).
Proof.
  rewrite /edivn => m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
  elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
  rewrite subn_if_gt; case: ltnP => [// | le_dm].
  rewrite -{1}(subnK le_dm) -addnS addnA.
  rewrite addnAC -mulSnr.                   (* addnAC を追加した。  *)
  apply (IHn (m - d) q.+1).                 (* apply: IHn でもよい。 *)
  apply: leq_trans le_mn; exact: leq_subr.
Qed.

Lemma edivn_eq : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
  move=> d q r lt_rd; have d_pos: 0 < d by exact: leq_trans lt_rd.
  case: edivnP lt_rd => q' r'; rewrite d_pos /=.
    wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
  rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
    rewrite -(leq_pmul2r d_pos); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
    by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.
Eval compute in edivn 7 3.                  (* (2,1) *)
Eval compute in edivn (2 * 3 + 1) 3.        (* (2,1) *)

(* 3.4 Parametric type families and alternative speciﬁcations *)
(* edivn_spec とだいたい同じ *)
CoInductive edivn_spec_right : nat -> nat -> nat * nat -> Type :=
  EdivnSpec_right m d q r of m = q * d + r & (d > 0) ==> (r < d) :
    edivn_spec_right m d (q, r).
Eval compute in (EdivnSpec_right 7 3 2 1).  (* 7 / 3 = 2 ... 1 *)
(* :  7 = 2 * 3 + 1 -> (0 < 3) ==> (1 < 3) -> edivn_right 7 3 (2, 1) *)

CoInductive edivn_spec_left (m d : nat)(qr : nat * nat) : Type :=
  EdivnSpec_left of m = qr.1 * d + qr.2 & (d > 0) ==> (snd qr < d) :
    edivn_spec_left m d qr.
Eval compute in (EdivnSpec_left 7 3 (2,1)).  (* 7 / 3 = 2 ... 1 *)
(* : 7 = (2, 1).1 * 3 + (2, 1).2 ->
       (0 < 3) ==> ((2, 1).2 < 3) -> edivn_spec_left 7 3 (2, 1) *)

Lemma edivnP_right' : forall m d, edivn_spec_right m d (edivn m d).
Proof.
  (* 証明は、edivnP と同じ。 *)
  rewrite /edivn => m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
  elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
  rewrite subn_if_gt; case: ltnP => [// | le_dm].
  rewrite -{1}(subnK le_dm) -addnS addnA.
  rewrite addnAC -mulSnr.                   (* addnAC を追加した。  *)
  apply (IHn (m - d) q.+1).                 (* apply: IHn でもよい。 *)
  apply: leq_trans le_mn; exact: leq_subr.
Qed.

(* ProofCafe yoshihiro503 による。 *)
Lemma edivnP_right : forall m d, edivn_spec_right m d (edivn m d).
Proof.
Check edivnP.
 move=> m d.
 case: (edivnP m d) => q r eq_m_dqr impl_0d_rd.
 by apply: EdivnSpec_right.
Qed.

Lemma edivnP_left' : forall m d, edivn_spec_left m d (edivn m d).
Proof.
  (* 証明は、edivnP と同じ。 *)
  rewrite /edivn => m [|d] //=; rewrite -{1}[m]/(0 * d.+1 + m).
  elim: m {-2}m 0 (leqnn m) => [|n IHn] [|m] q //=; rewrite ltnS => le_mn.
  rewrite subn_if_gt; case: ltnP => [// | le_dm].
  rewrite -{1}(subnK le_dm) -addnS addnA.
  rewrite addnAC -mulSnr.                   (* addnAC を追加した。  *)
  apply (IHn (m - d) q.+1).                 (* apply: IHn でもよい。 *)
  apply: leq_trans le_mn; exact: leq_subr.
Qed.

(* ProofCafe yoshihiro503 による。 *)
Lemma edivnP_left : forall m d, edivn_spec_left m d (edivn m d).
Proof.
 move=> m d.
 case: (edivnP m d) => q r eq impl.
 by apply EdivnSpec_left.
Qed.

Lemma edivn_eq_right : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
  move=> d q r lt_rd; have d_pos: 0 < d by exact: leq_trans lt_rd.
  set m := q * d + r; have: m = q * d + r by [].
  set d' := d; have: d' = d by [].
  case: (edivnP_right m d') => {m d'} m d' q' r' -> lt_r'd' d'd q'd'r'.
  move: q'd'r' lt_r'd' lt_rd; rewrite d'd d_pos {d'd m} /=.
    wlog: q q' r r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
  rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
    rewrite -(leq_pmul2r d_pos); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
  by rewrite addnS ltnNge mulSn -addnA -Eqr addnCA addnA leq_addr.
Qed.

Lemma edivn_eq_left : forall d q r, r < d -> edivn (q * d + r) d = (q, r).
Proof.
  move=> d q r lt_rd; have d_pos: 0 < d by exact: leq_trans lt_rd.
  case: (edivnP_left (q * d + r) d) lt_rd; rewrite d_pos /=.
    set q' := (edivn (q * d + r) d).1; set r' := (edivn (q * d + r) d).2.
  rewrite (surjective_pairing (edivn (q * d + r) d)) -/q' -/r'.
    wlog: q r q' r' / q <= q' by case (ltnP q q'); last symmetry; eauto.
  rewrite leq_eqVlt; case: eqP => [-> _|_] /=; first by move/addnI->.
    rewrite -(leq_pmul2r d_pos); move/leq_add=> Hqr Eqr _; move/Hqr {Hqr}.
  by rewrite addnS ltnNge mulSn -addnA Eqr addnCA addnA leq_addr.
Qed.
(* .1と.2は直積のfstとsndである。これを使うには、ssrfunが必要である。 *)

(* END *)

(* 証明に直接使われていないもの。 *)

(** 3.1 Basics *)
Variable n : nat.

Lemma three : S (S (S O)) = 3 /\ 2 = 0.+1.+1.
Proof. by [].
Qed.

Lemma concrete_plus : plus 16 64 = 80.
Proof.
    by [].
Qed.

Lemma concrete_le : le 1 3.
Proof.
    by apply: (Le.le_trans _ 2); apply: Le.le_n_Sn.
Qed.

Fixpoint subn_rec (m n : nat) {struct m} :=
  match m, n with
    | m'.+1, n'.+1 => (m' - n')
    | _, _ => m
end.

Lemma concrete_big_leq : 0 <= 51.
Proof.
    by [].
Qed.

Lemma semi_concrete_leq : forall n m, n <= m -> 51 + n <= 51 + m.
Proof.
    by [].
Qed.

Lemma concrete_arith : (50 < 100) && (3 + 4 < 3 * 4 <= 17 - 2).
Proof.
    by [].
Qed.

Lemma plus_commute : forall n1 m1, n1 + m1 = m1 + n1.
Proof.
    by elim=> [| n IHn m]; [elim | change (n.+1 + m) with ((n + m).+1); rewrite IHn; elim: m].
(*  by elim=> [| n IHn m]; [elim | rewrite -[n.+1 + m]/(n + m).+1 IHn; elim: m]. *)
Qed.

CoInductive ltn_xor_geq (m : nat) (n : nat) : bool -> bool -> Set := (* 不使用 *)
| LtnNotGeq : m < n -> ltn_xor_geq m n false true
| GeqNotLtn : n <= m -> ltn_xor_geq m n true false.
Check LtnNotGeq 1 2.                        (* : 1 < 2 -> ltn_xor_geq 1 2 false true *)
Check GeqNotLtn 1 1.                        (* : 0 < 1 -> ltn_xor_geq 1 1 true false *)

(* END *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Graphs                                                                  *
**************************************************************************)

(* under construction *)

Set Implicit Arguments.
Require Import LibCore LibArray LibSet.

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

Definition value_nonneg A (f:A->int) (P:A->Prop) :=
  forall x, P x -> f x >= 0.

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

Parameter graph : Type -> Type.
Parameter nodes : forall A, graph A -> set int.
Parameter edges : forall A, graph A -> set (int*int*A).

Definition has_edge A (g:graph A) x y w :=
  (x,y,w) \in edges g.

Parameter has_edge_nodes : forall A (g : graph A) x y w,
  has_edge g x y w -> x \in nodes g /\ y \in nodes g.

Lemma has_edge_in_nodes_l : forall A (g : graph A) x y w,
  has_edge g x y w -> x \in nodes g.
Proof. intros. forwards*: has_edge_nodes. Qed.

Lemma has_edge_in_nodes_r : forall A (g : graph A) x y w,
  has_edge g x y w -> y \in nodes g.
Proof. intros. forwards*: has_edge_nodes. Qed.

Definition nonneg_edges (g:graph int) :=
  forall x y w, has_edge g x y w -> w >= 0.
  (* forall x y, value_nonneg id (has_edge g x y) *)

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

Definition path A := list (int*int*A).

Inductive is_path A (g:graph A) : int -> int -> path A -> Prop :=
  | is_path_nil : forall x,
      x \in nodes g ->
      is_path g x x nil
  | is_path_cons : forall x y z w p,
      is_path g x y p ->
      has_edge g y z w ->
      is_path g x z ((y,z,w)::p).

Lemma is_path_in_nodes_l : forall A (g:graph A) x y p,
  is_path g x y p -> x \in nodes g.
Proof. introv H. induction~ H. Qed.

Lemma is_path_in_nodes_r : forall A (g:graph A) x y p,
  is_path g x y p -> y \in nodes g.
Proof. introv H. inverts~ H. apply* has_edge_in_nodes_r. Qed.

Lemma is_path_cons_has_edge : forall A (g:graph A) x y z w p,
  is_path g x z ((y,z,w)::p) -> has_edge g y z w.
Proof. introv H. inverts~ H. Qed.

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

Definition weight (p:path int) :=
  nosimpl (fold_right (fun e acc => let '(_,_,w) := e in w+acc) 0 p).

Lemma weight_nil :
  weight (nil : path int) = 0.
Proof. auto. Qed.

Lemma weight_cons : forall (p:path int) x y w,
  weight ((x,y,w)::p) = w + weight p.
Proof. intros. unfold weight. rew_list~. Qed.

(** A graph with nonnegative edges has only paths
    of nonnegative weight *)

Lemma nonneg_edges_to_path : forall g,
  nonneg_edges g -> forall x y,
  value_nonneg weight (is_path g x y).
Proof.
  introv NG H. induction H.
  rewrite weight_nil. math.
  rewrite weight_cons. forwards: NG H0. math.
Qed.


(* Playing with (co-)fixpoints with local definitions *)

Inductive listn : nat -> Set :=
  niln : listn 0
| consn : forall n:nat, nat -> listn n -> listn (S n).

Fixpoint f (n:nat) (m:=pred n) (l:listn m) (p:=S n) {struct l} : nat :=
   match n with O => p | _ =>
     match l with niln => p | consn q _ l => f (S q) l end
   end.

Eval compute in (f 2 (consn 0 0 niln)).

CoInductive Stream : nat -> Set :=
  Consn : forall n, nat -> Stream n -> Stream (S n).

CoFixpoint g (n:nat) (m:=pred n) (l:Stream m) (p:=S n) : Stream p :=
    match n return (let m:=pred n in forall l:Stream m, let p:=S n in Stream p)
    with
    | O => fun l:Stream 0 => Consn O 0 l
    | S n' =>
      fun l:Stream n' =>
      let l' :=
        match l in Stream q return Stream (pred q) with Consn _ _ l => l end
      in
      let a := match l with Consn _ a l => a end in
      Consn (S n') (S a) (g n' l')
   end l.

Eval compute in (fun l => match g 2 (Consn 0 6 l) with Consn _ a _ => a end).

(* Check inference of simple types in presence of non ambiguous
   dependencies (needs revision 10125) *)

Section folding.

Inductive vector (A:Type) : nat -> Type :=
  | Vnil : vector A 0
  | Vcons : forall (a:A) (n:nat), vector A n -> vector A (S n).

Variables (B C : Set) (g : B -> C -> C) (c : C).

Fixpoint foldrn n bs :=
  match bs with
  | Vnil _ => c
  | Vcons _ b _ tl => g b (foldrn _ tl)
  end.

End folding.

(* Check definition by tactics *)

Set Automatic Introduction.

Inductive even : nat -> Type :=
  | even_O : even 0
  | even_S : forall n, odd n -> even (S n)
with odd : nat -> Type :=
    odd_S : forall n, even n -> odd (S n).

Fixpoint even_div2 n (H:even n) : nat :=
  match H with
  | even_O => 0
  | even_S n H => S (odd_div2 n H)
  end
with odd_div2 n H : nat.
destruct H.
apply even_div2 with n.
assumption.
Qed.

Fixpoint even_div2' n (H:even n) : nat with odd_div2' n (H:odd n) : nat.
destruct H.
exact 0.
apply odd_div2' with n.
assumption.
destruct H.
apply even_div2' with n.
assumption.
Qed.

CoInductive Stream1 (A B:Type) := Cons1 : A -> Stream2 A B -> Stream1 A B
with Stream2 (A B:Type) := Cons2 : B -> Stream1 A B -> Stream2 A B.

CoFixpoint ex1 (n:nat) (b:bool) : Stream1 nat bool
with ex2 (n:nat) (b:bool) : Stream2 nat bool.
apply Cons1.
exact n.
apply (ex2 n b).
apply Cons2.
exact b.
apply (ex1 (S n) (negb b)).
Defined.

Section visibility.

  Let Fixpoint imm (n:nat) : True := I.

  Let Fixpoint by_proof (n:nat) : True.
  Proof. exact I. Defined.
End visibility.

Fail Check imm.
Fail Check by_proof.

Module Import mod_local.
  Fixpoint imm_importable (n:nat) : True := I.

  Local Fixpoint imm_local (n:nat) : True := I.

  Fixpoint by_proof_importable (n:nat) : True.
  Proof. exact I. Defined.

  Local Fixpoint by_proof_local (n:nat) : True.
  Proof. exact I. Defined.
End mod_local.

Check imm_importable.
Fail Check imm_local.
Check mod_local.imm_local.
Check by_proof_importable.
Fail Check by_proof_local.
Check mod_local.by_proof_local.


(**
Here we define the basic notions of setoids.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

(**
Projections and builder functions of equivalence relations.
*)
Definition make_eq_rel
           {X : hSet}
           (rel : hrel X)
           (isrefl_rel : isrefl rel)
           (issymm_rel : issymm rel)
           (istrans_rel : istrans rel)
  : eqrel X
  := rel ,, ((istrans_rel ,, isrefl_rel) ,, issymm_rel).

Notation "'id' g" := (eqrelrefl _ g) (at level 30) : setoid_scope.
Notation "! p" := (eqrelsymm _ _ _ p) : setoid_scope.
Notation "p @ q" := (eqreltrans _ _ _ _ p q) : setoid_scope.
Delimit Scope setoid_scope with setoid.

(**
A setoid is just a pair of a set and an equivalence relation.
 *)
Definition setoid :=
  ∑ (X : hSet), eqrel X.

(**
Projections and builder functions of setoids.
 *)
Definition make_setoid
           {X : hSet}
           (R : eqrel X)
  : setoid
  := X ,, R.

Coercion carrier (X : setoid) : hSet := pr1 X.

Definition carrier_eq
           (X : setoid)
  : eqrel X
  := pr2 X.

Notation "x ≡ y" := (carrier_eq _ x y) (at level 70).

Definition isaprop_setoid_eq
           {X : setoid}
           (x y : X)
  : isaprop (x ≡ y).
Proof.
  apply (pr1 (carrier_eq X)).
Defined.

Definition setoid_path
           {X : setoid}
           {x y : X}
           (p : x = y)
  : x ≡ y.
Proof.
  induction p.
  apply (id _)%setoid.
Defined.

(**
Lastly, we define setoid morphisms.
 *)
Definition setoid_morphism (X₁ X₂ : setoid)
  := ∑ (f : X₁ → X₂), ∏ (x y : X₁), x ≡ y → f x ≡ f y.

(**
Projections and builder functions for setoid morphisms.
 *)
Definition make_setoid_morphism
           {X₁ X₂ : setoid}
           (f : X₁ → X₂)
           (Rf : ∏ (x y : X₁), x ≡ y → f x ≡ f y)
  : setoid_morphism X₁ X₂
  := f ,, Rf.

Definition map_carrier
           {X₁ X₂ : setoid}
           (f : setoid_morphism X₁ X₂)
  : X₁ → X₂
  := pr1 f.

Coercion map_carrier : setoid_morphism >-> Funclass.

Definition map_eq
           {X₁ X₂ : setoid}
           (f : setoid_morphism X₁ X₂)
           {x y : X₁}
  : x ≡ y → f x ≡ f y
  := pr2 f x y.

(**
Equality principle for setoid morphisms.
 *)
Definition setoid_morphism_eq
           {X₁ X₂ : setoid}
           (f g : setoid_morphism X₁ X₂)
           (e : ∏ (x : X₁), f x = g x)
  : f = g.
Proof.
  use subtypePath.
  - intro.
    do 3 (apply impred ; intro).
    apply isaprop_setoid_eq.
  - apply funextsec.
    exact e.
Defined.

Definition isaset_setoid_morphism (X₁ X₂ : setoid)
  : isaset(setoid_morphism X₁ X₂).
Proof.
  use isaset_total2.
  - apply isaset_set_fun_space.
  - intros f ; cbn.
    apply isasetaprop.
    repeat (apply impred ; intro).
    apply isaprop_setoid_eq.
Defined.


Require Import ZArith.
Require Import Ensembles.

Module NaiveLang.
  Definition expr := (nat -> Z) -> Prop.
  Definition context := expr -> Prop.
  Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
  Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
  Definition orp  (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
  Definition falsep : expr := fun st => False.

  Definition derivable (Phi: context) (e : expr) : Prop := forall st, (forall e0, Phi e0 -> e0 st) -> e st.
End NaiveLang.

Require Import interface_3.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Axiom deduction_andp_intros : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi y -> derivable Phi (andp x y)) .
  Axiom deduction_andp_elim1 : (forall (Phi : context) (x y : expr), derivable Phi (andp x y) -> derivable Phi x) .
  Axiom deduction_andp_elim2 : (forall (Phi : context) (x y : expr), derivable Phi (andp x y) -> derivable Phi y) .
  Axiom deduction_orp_intros1 : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi (orp x y)) .
  Axiom deduction_orp_intros2 : (forall (Phi : context) (x y : expr), derivable Phi y -> derivable Phi (orp x y)) .
  Axiom deduction_orp_elim : (forall (Phi : Ensemble expr) (x y z : expr), derivable (Union expr Phi (Singleton expr x)) z -> derivable (Union expr Phi (Singleton expr y)) z -> derivable (Union expr Phi (Singleton expr (orp x y))) z) .
  Axiom deduction_falsep_elim : (forall (Phi : context) (x : expr), derivable Phi falsep -> derivable Phi x) .
  Axiom deduction_modus_ponens : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi (impp x y) -> derivable Phi y) .
  Axiom deduction_impp_intros : (forall (Phi : Ensemble expr) (x y : expr), derivable (Union expr Phi (Singleton expr x)) y -> derivable Phi (impp x y)) .
  Axiom deduction_weaken : (forall (Phi Psi : Ensemble expr) (x : expr), Included expr Phi Psi -> derivable Phi x -> derivable Psi x) .
  Axiom derivable_assum : (forall (Phi : Ensemble expr) (x : expr), In expr Phi x -> derivable Phi x) .
  Axiom deduction_subst : (forall (Phi Psi : context) (y : expr), (forall x : expr, Psi x -> derivable Phi x) -> derivable (Union expr Phi Psi) y -> derivable Phi y) .
End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Module Solver := IPSolver NaiveLang.
Import T.
Import Solver.