Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.uni.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module ResponseTime.

  Import UniprocessorSchedule SporadicTaskset TaskArrival.

  (* In this section, we define the notion of a response-time bound. *)
  Section ResponseTimeBound.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* Let tsk be any task that is to be analyzed. *)
    Variable tsk: sporadic_task.

    (* For simplicity, let's define some local names. *)
    Let job_has_completed_by := completed_by job_cost sched.

    (* Then, we say that R is a response-time bound of tsk in this schedule ... *)
    Variable R: time.

    (* ... iff any job j of tsk in this arrival sequence has
       completed by (job_arrival j + R). *)
    Definition is_response_time_bound_of_task :=
      forall j,
        arrives_in arr_seq j ->
        job_task j = tsk ->
        job_has_completed_by j (job_arrival j + R).

  End ResponseTimeBound.

  (* In this section, we prove some basic lemmas about response-time bounds. *)
  Section BasicLemmas.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* Assume that jobs don't execute after completion. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* For simplicity, let's define some local names. *)
    Let job_has_completed_by := completed_by job_cost sched.

    (* We begin by proving lemmas about job response-time bounds. *)
    Section SpecificJob.

      (* Let j be any job... *)
      Variable j: Job.

      (* ...with response-time bound R. *)
      Variable R: time.
      Hypothesis response_time_bound:
        job_has_completed_by j (job_arrival j + R).

      (* Then, the service received by j at any time t' after its response time is 0. *)
      Lemma service_after_job_rt_zero :
        forall t',
          t' >= job_arrival j + R ->
          service_at sched j t' = 0.
      Proof.
        rename response_time_bound into RT,
               H_completed_jobs_dont_execute into EXEC; ins.
        unfold is_response_time_bound_of_task, completed_by,
               completed_jobs_dont_execute in *.
        apply/eqP; rewrite -leqn0.
        rewrite <- leq_add2l with (p := job_cost j).
        move: RT => /eqP RT; rewrite -{1}RT addn0.
        apply leq_trans with (n := service sched j t'.+1);
          last by apply EXEC.
        unfold service, service_during.
        rewrite -> big_cat_nat with (p := t'.+1) (n := job_arrival j + R);
          [rewrite leq_add2l /= | by ins | by apply ltnW].
        by rewrite big_nat_recr // /=; apply leq_addl.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_job_rt_zero :
        forall t' t'',
          t' >= job_arrival j + R ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        ins; apply/eqP; rewrite -leqn0.
        rewrite big_nat_cond; rewrite -> eq_bigr with (F2 := fun i => 0);
          first by rewrite big_const_seq iter_addn mul0n addn0 leqnn.
        intro i; rewrite andbT; move => /andP [LE _].
        by rewrite service_after_job_rt_zero;
          [by ins | by apply leq_trans with (n := t')].
      Qed.

    End SpecificJob.

    (* Next, we prove properties about task response-time bounds. *)
    Section AllJobs.

      (* Consider any task tsk ...*)
      Variable tsk: sporadic_task.

      (* ... for which a response-time bound R is known. *)
      Variable R: time.
      Hypothesis response_time_bound:
        is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched tsk R.

      (* Then, for any job j of this task, ...*)
      Variable j: Job.
      Hypothesis H_from_arrival_sequence: arrives_in arr_seq j.
      Hypothesis H_job_of_task: job_task j = tsk.

      (* ...the service received by job j at any time t' after the response time is 0. *)
      Lemma service_after_task_rt_zero :
        forall t',
          t' >= job_arrival j + R ->
          service_at sched j t' = 0.
      Proof.
        intros t' LE.
        apply service_after_job_rt_zero with (R := R); last by done.
        by apply response_time_bound.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_task_rt_zero :
        forall t' t'',
          t' >= job_arrival j + R ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        by ins; apply cumulative_service_after_job_rt_zero with (R := R);
          first by apply response_time_bound.
      Qed.

    End AllJobs.

  End BasicLemmas.

End ResponseTime.


(**************************************************************)
(*   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 List.

Require Import list_utils.
Require Import finite.

Set Implicit Arguments.

Section minimizer.

  Variable (X : Type) (f : X -> nat).

  Let minimizer_rec n ll : 1 <= length ll < n -> { a | In a ll /\ forall b, In b ll -> f a <= f b }.
  Proof.
    revert ll.
    induction n as [ | n IHn ]; intros ll (H1 & H2).
    omega.
    destruct ll as [ | a ll ].
    contradict H1; simpl; omega.
    destruct (list_dec_rec (fun b => f b < f a) ll) as [ (a' & Ha1 & Ha2) | Ha ].
    intros; apply lt_dec.

    destruct (IHn ll) as (m & H3 & H4).
    split.
    destruct ll; simpl in H2 |- *; try omega.
    destruct Ha1.
    simpl in H2; omega.
    exists m; split.
    right; auto.
    intros b [ Hb | Hb ]; auto.
    subst b; apply le_trans with (1 := H4 _ Ha1); auto; omega.

    exists a; split.
    left; auto.
    intros b [ Hb | Hb ]; auto.
    subst; auto.
    specialize (Ha _ Hb); omega.
  Qed.

  Let minimizer_list ll : ll <> nil -> { a | In a ll /\ forall b, In b ll -> f a <= f b }.
  Proof.
    intros Hll.
    apply minimizer_rec with (n := S (length ll)).
    destruct ll.
    contradict Hll; auto.
    simpl; omega.
  Qed.

  Fact minimizer_finite (P : X -> Prop) : finite P
                                       -> (exists a, P a)
                                       -> exists a, P a /\ forall b, P b -> f a <= f b.
  Proof.
    intros (ll & Hll) (a & Ha).
    destruct (@minimizer_list ll) as (m & H1 & H2).
    apply Hll in Ha.
    destruct ll.
    destruct Ha.
    discriminate.
    exists m; split.
    apply Hll; auto.
    intros b Hb; apply H2, Hll; auto.
  Qed.

  Fact minimizer_finite_t (P : X -> Prop) : finite_t P
                                         -> (exists a, P a)
                                         -> { a | P a /\ forall b, P b -> f a <= f b }.
  Proof.
    intros (ll & Hll) Ha.
    destruct (@minimizer_list ll) as (m & H1 & H2).
    destruct Ha as (a & Ha).
    apply Hll in Ha.
    destruct ll.
    destruct Ha.
    discriminate.
    exists m; split.
    apply Hll; auto.
    intros b Hb; apply H2, Hll; auto.
  Qed.

End minimizer.


Require Import init.

Require Import set_base.

Definition image {U V} (f : U → V) := λ y, ∃ x, y = f x.
Definition image_under {U V} (f : U → V) (S : U → Prop)
    := λ y, ∃ x, S x ∧ y = f x.
Definition inverse_image {U V} (f : U → V) (T : V → Prop)
    := λ x, T (f x).

Theorem image_under_in {U V} : ∀ {f : U → V} {S : U → Prop} {x},
    S x → image_under f S (f x).
Proof.
    intros f S x Sx.
    exists x.
    split.
    -   exact Sx.
    -   reflexivity.
Qed.

Theorem image_inverse_sub {U V} : ∀ (f : U → V) (S : V → Prop),
    image_under f (inverse_image f S) ⊆ S.
Proof.
    intros f S y [x [x_in eq]].
    subst y.
    exact x_in.
Qed.

Theorem image_sub {U V} :
    ∀ (f : U → V) S T, S ⊆ T → image_under f S ⊆ image_under f T.
Proof.
    intros f S T sub y [x [Sx y_eq]].
    subst y.
    apply sub in Sx.
    apply image_under_in.
    exact Sx.
Qed.

Theorem inverse_complement {U V} : ∀ (f : U → V) S,
    inverse_image f (𝐂 S) = 𝐂 (inverse_image f S).
Proof.
    intros f S.
    reflexivity.
Qed.

Theorem inverse_image_bij_inv {U V} : ∀ S (f : U → V) `{@Bijective U V f},
    (inverse_image (bij_inv f) S) = image_under f S.
Proof.
    intros S f f_bij.
    apply antisym.
    -   intros y y_in.
        unfold inverse_image in y_in.
        exists (bij_inv f y).
        split; [>exact y_in|].
        symmetry; apply inverse_eq2.
        apply bij_inv_inv.
    -   intros y [x [Sx y_eq]]; subst y.
        unfold inverse_image.
        rewrite inverse_eq1 by apply bij_inv_inv.
        exact Sx.
Qed.

Theorem bij_inverse_image {U V} : ∀ S (f : U → V),
    Bijective f → image_under f (inverse_image f S) = S.
Proof.
    intros S f f_bij.
    apply antisym; [>apply image_inverse_sub|].
    intros y Sy.
    exists (bij_inv f y).
    unfold inverse_image.
    rewrite inverse_eq2 by apply bij_inv_inv.
    split.
    -   exact Sy.
    -   reflexivity.
Qed.

Theorem inj_inverse_image {U V} : ∀ S (f : U → V),
    Injective f → inverse_image f (image_under f S) = S.
Proof.
    intros S f f_inj.
    apply antisym.
    -   intros x [y [Sy eq]].
        apply inj in eq.
        subst.
        exact Sy.
    -   intros x Sx.
        apply image_under_in.
        exact Sx.
Qed.


From LF Require Export Lists.
(*
polymorphism (abstracting functions over the types of the data they manipulate)
higher-order functions (treating functions as data).
*)
Definition odd (n:nat) :=
  (negb (even n)).
(* Coq supports polymorphic inductive types *)
Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

(* list is a function from Types to Inductive definitions;
or, to put it more concisely, list is a function from Types to Types.
For any particular type X, the type list X is the Inductively defined
set of lists whose elements are of type X. *)

Check list : Type -> Type.
Check (nil nat) : list nat.
Check (cons nat 3 (nil nat)) : list nat.

(* What is nil's type?
Intuitively, it is (X : Type) → list X.
But Coq notation is represents it as follows. *)
Check nil : forall X : Type, list X.

Check cons : forall X : Type, X -> list X -> list X.
Check (cons nat 2 (cons nat 1 (nil nat)))
    : list nat.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.
Example test_repeat1 : repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)). Proof. reflexivity. Qed.
Example test_repeat2 : repeat bool false 1 = cons bool false (nil bool). Proof. reflexivity. Qed.

Module MumbleGrumble.
Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.
Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(*
TODO:
Which of the following are well-typed elements of grumble X for some type X? (Add YES or NO to each line.)
d (b a 5)           NO since it has to use the mumble constructor
d mumble (b a 5)    YES. type grumble mumble. Uses mumble constructor, where (b a 5) is type mumble because (1 2 3) in the mumble constructor, b=1 matches, a=2 matches since a is a mumble type, and 5=3 matches since 5 is nat
d bool (b a 5)      NO, because (b a 5) expects to be a bool
e bool true         YES, type grumble bool
e mumble (b c 0)    YES, type grumble mumble
e bool (b c 0)      NO because it expocts (b c 0) to be bool
c                   YES, type mumble

*)
Check (grumble nat ).
Check (d nat).
Check (e nat).

Check (d mumble (b a 5)).
Check (e bool true).
Check (e mumble (b c 0)).
Check d mumble (b a 5).

Check list nat.
End MumbleGrumble.

(* Type Annotation Inference *)
Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.
Check repeat'
  : forall X : Type, X -> nat -> list X.
Check repeat
  : forall X : Type, X -> nat -> list X.

(* when Coq encounters a "hole" represented by underscore character _,
it will attempt to unify all locally available information
 -- the type of the function being applied, the types of the other arguments,
and the type expected by the context in which the application appears -- to determine
    what concrete type should replace the _.
     *)
Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* Implicit Arguments *)

(* The Arguments directive specifies the name of the function (or constructor)
and then lists the (leading) argument names to be treated as implicit, each surrounded by curly braces. *)
Arguments nil {X}.
Arguments cons {X}.
Arguments repeat {X}.

(* No need to supply type arg since it's explicitly told to be treated implict with Arguments declaration *)
Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(* But don't make everything implicit. Consider the following list'  *)
Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').
(* Because X is declared as implicit for the entire
inductive definition including list' itself, we now
have to write just list' whether we are talking about
lists of numbers or booleans or anything else, rather than
list' nat or list' bool or whatever; this is a step too far. *)

(* So let's stick with our original implementation of list but with
the Arguments for nil, cons defined to treat their leading terms as implicit *)

(* So we explicitly supply the generic type arg X for the list constructor, but not for the function type arg *)
Fixpoint app {X : Type} (l1 l2 : list X) : list X  :=
    match l1 with
    | nil => l2
        | cons h t => cons h (app t l2)
    end.
Fixpoint rev {X : Type} (l : list X) : list X :=
    match l with
        | nil => nil
        | cons h t => app (rev t ) (cons h nil)
    end.
Fixpoint length {X : Type} (l : list X) : nat :=
    match l with
        | nil => 0
        | cons _ t => 1 + length t
    end.

Example test_rev1 : rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)). Proof. reflexivity. Qed.
Example test_rev2: rev (cons true nil) = cons true nil. Proof. reflexivity. Qed.
Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3. Proof. reflexivity. Qed.

    (* Supplying Type Arguments Explicitly *)
Definition mynil : list nat := nil.

(* Alternatively, we can force the implicit arguments to
 be explicit by prefixing the function name with @. *)
Check nil.
Check @nil : forall X : Type, list X.
Definition mynil' := @nil nat.

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

Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
 intros X l.
 induction l as [| n l' IHl'].
 - (* l = [] *)
    reflexivity.
 - (* l = n :: l' *)
    simpl. rewrite IHl'. reflexivity.
Qed.

Theorem app_assoc : forall (X: Type), forall (l m n: list X),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
    intros X l m n.
    induction l as [| x l' IHl'].
    - (* l = [] *)
        simpl. reflexivity.
    - (* l = n :: l'*)
        simpl. rewrite <- IHl'. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
    intros X l1 l2.
    induction l1 as [| n l1' IHl1'].
    - (* l1 = [] *)
        reflexivity.
    - (* l1 = n :: l1' *)
        simpl. rewrite IHl1'. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
    intros X l1 l2.
    induction l1 as [| n l1' IHl1' ].
    - (* l1 = [] *)
        simpl. rewrite app_nil_r. reflexivity.
    - (* l1 = n :: l1' *)
        simpl. rewrite IHl1'. rewrite <- app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall (X : Type), forall (l : list X),
  rev (rev l) = l.
Proof.
    intros X l.
    induction l as [| n l' IHl'].
    - (* l = [] *)
        reflexivity.
    - (* l = n :: l' *)
        simpl. rewrite rev_app_distr. rewrite IHl'. simpl. reflexivity.
Qed.

(*  Polymorphic Pairs  *)
Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Arguments pair {X} {Y}.
Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.
(* type_scope tells Coq that this abbreviation should only be used when parsing types, not when parsing expressions.  *)

(*
It is easy at first to get (x,y) and X * Y confused. Remember that (x,y) is a value built from two other values, while X * Y is a type built from two other types. If x has type X and y has type Y, then (x,y) has type X * Y.
*)
Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.
Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(* often called zip, but calling it combine to be consistent with coq's stdlib  *)
Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
        : list (X*Y) :=
match lx, ly with
    | [], _ => []
    | _, [] => []
    | x :: tx, y :: ty => (x, y) :: (combine tx ty)
end.
Compute (combine [1;2] [false;false;true;true]).
(* [(1, false);(2, false)] *)

(* USEFUL *)
(* also known as unzip  *)
Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y):=
    match l with
        | [] => ([],[])
        | (x, y) :: t => let t' := split t in (x::(fst t'), (y::(snd t')))
    end.

Example test_split0: split [(1,false);(2,false)] = ([1;2],[false;false]). Proof. reflexivity. Qed.
Example test_split2: let t' := split [(1,false);(2,false)] in combine (fst t') (snd t') = [(1,false);(2,false)]. Proof. reflexivity. Qed.

Module OptionPlayground.
Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X}.
Arguments None {X}.
End OptionPlayground.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  end.
Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4. Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2]. Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None. Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
    match l with
        | [] => None
        | h::t => Some h
    end.

    (* Force implicit arguments to be explicit *)
Check @hd_error : forall X : Type, list X -> option X.
Example test_hd_error1 : hd_error [1;2] = Some 1. Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1]. Proof. reflexivity. Qed.

    (* Higher Order Functions *)

Definition doit3times {X : Type} (f : X->X) (n : X) : X :=
  f (f (f n)).
Check @doit3times : forall X : Type, (X -> X) -> X -> X.

Definition minustwo (n : nat) : nat :=
    (minus n 2).

Example test_doit3times: doit3times  minustwo 9 = 3. Proof. reflexivity. Qed.
Example test_doit3times': doit3times negb true = false. Proof. reflexivity. Qed.

Fixpoint filter {X : Type} (pred : X -> bool) (l : list X) : list X :=
    match l with
        | [] => []
        | h :: t => match (pred h) with
                        | true => h :: (filter pred t)
                        | false =>  (filter pred t)
                    end
    end.
Example test_filter1: filter even [1;2;3;4] = [2;4]. Proof. reflexivity. Qed.
Example test_filter2: filter negb [true;false;true] = [false]. Proof. reflexivity. Qed.
Example test_filter3: filter even [2;4;6] = [2;4;6]. Proof. reflexivity. Qed.
Example test_filter4: filter even [1;3;5] = []. Proof. reflexivity. Qed.
Example test_filter5: filter even [] = []. Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.
Example test_filter6:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ]. Proof. reflexivity. Qed.

    (* use lambda *)
Definition countoddmembers' (l:list nat) : nat :=
  length (filter (fun n => negb (even n)) l).
Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4. Proof. reflexivity. Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0. Proof. reflexivity. Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0. Proof. reflexivity. Qed.
Example test_anon_fun': doit3times (fun n => n * n) 2 = 256. Proof. reflexivity. Qed.

Example test_filter6':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

    Definition filter_even_gt7 (l : list nat) : list nat:=
        filter (fun n => (andb (even n) (geb n 7))) l.
Example test_filter_even_gt7_1 : filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8]. Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 : filter_even_gt7 [5;2;6;19;129] = []. Proof. reflexivity. Qed.

Fixpoint partition' {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
    match l with
      | [] => ([], [])
      | h::t => let t' := (partition' test t) in match (test h) with
                                | true => (h::(fst t'), (snd t'))
                                | false => ((fst t'), h::(snd t'))
                                end
    end.
Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X := ((filter test l),(filter (fun n => (negb (test n))) l)).

Example test_partition1: partition even [1;2;3;4;5] = ([2;4], [1;3;5] ).  Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).  Proof. reflexivity. Qed.

Fixpoint map { X Y : Type }  (f : X -> Y) (l : list X) : list Y :=
    match l with
        | [] => []
        | h :: t => (f h) :: (map f t)
    end.
Definition mapf := fun n => (geb n 2).
Example test_map0: (map mapf [1;2;3]) = [false;true;true].  Proof. reflexivity. Qed.
Example test_map3:
    map (fun n => [even n; (negb (even n))]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]]. Proof. reflexivity. Qed.

Lemma map_assoc : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X) ,
    (map f (l1 ++ l2)) = (map f l1) ++ (map f l2).
Proof.
    intros X Y f l1 l2.
    induction l1 as [| n l1' IHl1'].
    - (* l1 = [] *)
        reflexivity.
    - (* l1 = n :: l1' *)
        simpl. rewrite IHl1'. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [| n l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n :: l' *)
    simpl. rewrite <- IHl'.  rewrite map_assoc. simpl. reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : list Y :=
match l with
    | [] => []
    | h :: t => (f h) ++ flat_map f t
    end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4]. Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
  | None => None
  | Some x => Some (f x)
  end.

  (*
  Intuitively, the behavior of the fold operation is to insert a given binary operator f between every pair of elements in a given list. For example, fold plus [1;2;3;4] intuitively means 1+2+3+4. To make this precise, we also need a "starting element" that serves as the initial second input to f. So, for example,
       fold plus [1;2;3;4] 0
yields
       1 + (2 + (3 + (4 + 0))).
  *)
Fixpoint fold {X Y: Type} (f : X->Y->Y) (l : list X) (b : Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Example fold_example1 : fold mult [1;2;3;4] 1 = 24. Proof. reflexivity. Qed.
    (* FOLD LEFT
    1 * (2 * (3 * (4 * 1)))
    *)
Example fold_example2 :fold andb [true;true;false;true] true = false. Proof. reflexivity. Qed.
Example fold_example3 :fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4]. Proof. reflexivity. Qed.

Definition constfun {X: Type} (x: X) : nat -> X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.
Example constfun_example1 : ftrue 0 = true. Proof. reflexivity. Qed.
Example constfun_example2 : (constfun 5) 99 = 5. Proof. reflexivity. Qed.
(* "plus is a one-argument function that takes a nat and returns a one-argument function that takes another nat and returns a nat."
  RIGHT ASSOCIATIVE / PARTIAL APPLICATION *)

Definition plus3 := plus 3.
Check plus3 : nat -> nat.
Example test_plus3 :    plus3 4 = 7. Proof. reflexivity. Qed.
Example test_plus3' :   doit3times plus3 0 = 9. Proof. reflexivity. Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9. Proof. reflexivity. Qed.

Module Exercises.
Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.
Example test_fold_length1 : fold_length [4;7;0] = 3. Proof. reflexivity. Qed.

Lemma fold_length_Sn : forall X (l : list X) (n : X),
  fold_length (n :: l) = S (fold_length l).
Proof.
  (* intros X l n. *)
  reflexivity.
  (* induction l as [| n' l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n' :: l' *)
    simpl. reflexivity. *)
Qed.
Lemma fold_length_assoc : forall X (l1 l2 : list X),
  fold_length (l1 ++ l2) = fold_length l1 + fold_length l2.
Proof.
  intros X l1 l2.
  induction l1 as [| n l1' IHl1'].
  - (* l1 = [] *)
    reflexivity.
  - (* l1 = n :: l1' *)
    assert (H: (n :: l1') ++ l2 = n :: (l1' ++ l2)).
      { reflexivity.  }
    rewrite H.
    rewrite fold_length_Sn.
    rewrite fold_length_Sn.
    rewrite IHl1'.
    reflexivity.
Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l as [| n l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n :: l' *)
    simpl. rewrite <- IHl'.
    rewrite fold_length_Sn. reflexivity.
Qed.
Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun a b => f a :: b) l [].

Example test_map0: map mapf [1;2;3] = fold_map mapf [1;2;3].  Proof. reflexivity. Qed.
  (* [false;true;true] *)
Example test_map3:
    map (fun n => [even n; (negb (even n))]) [2;1;2;5]
  = fold_map (fun n => [even n; (negb (even n))]) [2;1;2;5]. Proof. reflexivity. Qed.
(*   [[true;false];[false;true];[true;false];[false;true]] *)

Theorem fold_map_correct: forall X Y (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  intros X Y f l.
  induction l as [| n l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n :: l' *)
    simpl.
    assert (H : fold_map f (n :: l') = f n :: fold_map f l' ).
    { reflexivity. }
    rewrite H.
    rewrite IHl'.
    reflexivity.
Qed.
(* f h (fold f t b) *)

(* In Coq, a function f : A → B → C really has the
type A → (B → C). That is, if you give f a value of type A,
 it will give you function f' : B → C. If you then give
 f' a value of type B, it will return a value of type C.
 This allows for partial application, as in plus3.
 Processing a list of arguments with functions that
 return functions is called currying, in honor of the
 logician Haskell Curry.
Conversely, we can reinterpret the type A → B → C as
(A * B) → C. This is called uncurrying. With an uncurried
binary function, both arguments must be given at once as
a pair; there is no partial application.
 *)
Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).
Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

(* Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5]. Proof. reflexivity. Qed. *)
Example test_map1': map (plus 3) [2;0;2] = [5;3;5]. Proof. reflexivity. Qed.
Example test_curry_inverse :  prod_curry (prod_uncurry plus) 1 2 = plus 1 2. Proof. reflexivity. Qed.
Check @prod_curry.
(* forall X Y Z : Type, (X * Y -> Z) -> X -> Y -> Z *)
Check @prod_uncurry.
(* forall X Y Z : Type, (X -> Y -> Z) -> X * Y -> Z  *)
Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  destruct p as [x y].
  reflexivity.
Qed.

Module Church.
(*
Church numerals, named after mathematician Alonzo Church, are
an alternate way of defining natural number n as a function
that takes a function f as a parameter and returns f iterated n times.
*)
Definition cnat := forall X : Type, (X -> X) -> X -> X.
Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.
Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).
Definition three : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f (f x)).
(*
Defining zero is somewhat trickier:
how can we "apply a function zero times"?
The answer is actually simple: just return the argument untouched.
*)
Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.
Definition succ (n : cnat) : cnat :=
    fun (X : Type) (f : X -> X) (x : X) => f (n _ f x).

Example succ_1 : succ zero = one. Proof. reflexivity. Qed.
Example succ_2 : succ one = two. Proof. reflexivity. Qed.
Example succ_3 : succ two = three. Proof. reflexivity. Qed.

(*
TODO
Definition pred (n : cnat) : cnat :=
    match n with
      | zero => zero
      | one => one
    end.

    fun X f x => f (n _ f x).

Example pred_1 : pred zero = zero. Proof. reflexivity. Qed.
Example pred_2 : pred one = zero. Proof. reflexivity. Qed.
Example pred_3 : pred two = one. Proof. reflexivity. Qed.       *)

Definition plus (n m : cnat) : cnat :=
  fun X f x => n _ f (m _ f x).

Example plus_1 : plus zero one = one. Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two. Proof. reflexivity. Qed.
Example plus_3 :
  plus (plus two two) three = plus one (plus three three). Proof. reflexivity. Qed.

Check plus one.
Check succ.
Check cnat.

Definition mult (n m : cnat) : cnat :=
    fun _ f x => n _ (m _ f) x.

Example mult_1 : mult one one = one. Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero. Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three. Proof. reflexivity. Qed.

Definition exp (n m : cnat) : cnat :=
  (* fun _ f => m _ ((n _ f)) .  *)
  fun X => m (X -> X) (n X).

Example exp_1 : exp two two = plus two two. Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one. Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one. Proof. reflexivity. Qed.
End Church.
End Exercises.

Module Entries.

Inductive id : Type :=
  | Id (id : nat)
  | None.
Inductive eid : Type :=
  | Eid (eid : nat). (* external id *)

Inductive entry_op : Type :=
  | Create
  | Update
  | Delete
  | Exist.

Inductive entry : Type :=
  | Asset (id : id) (eid : eid) (op : entry_op) (amt : nat).
  (* | Liability (id : id) (op : entry_op) (amt : nat)
  | IncExp (id : id) (op : entry_op) (amt : nat). *)

Definition eqb_eid (x1 x2 : eid) :=
  match x1, x2 with
  | Eid n1, Eid n2 => n1 =? n2
  end.

  (* if exist, remove one. if does not exist, do nothing. *)
Fixpoint remove_one (l : list entry) (n : eid) : (list entry) :=
  match l with
    | [] => []
    | Asset id (Eid eid) op amt :: t => if (eqb_eid (Eid eid) n) then t else (Asset id (Eid eid) op amt) :: remove_one t n
  end.
(* Reducer *)
Fixpoint parse (l : list entry) (acc : list entry) : (list entry) :=
  match l with
    | [] => acc
    | Asset id (Eid eid) op amt :: t => match id, op with
                  | None, Create => parse t (acc ++ [(Asset None (Eid eid ) Create amt)])

                    (* replace the create with update for eid *)
                  | None,  Update => let acc' := remove_one acc (Eid eid) in parse t (acc' ++ [(Asset None (Eid eid) Create amt)])

                    (* remove the create for eid *)
                  | None,  Delete => let acc' := remove_one acc (Eid eid) in parse t acc'

                  | (Id id),  Update => let acc' := remove_one acc (Eid eid) in parse t (acc' ++ [(Asset (Id id) (Eid eid) Update amt)])
                  | (Id id),  Delete => let acc' := remove_one acc (Eid eid) in parse t (acc' ++ [(Asset (Id id) (Eid eid) Delete amt)])

                    (* Do nothing *)
                  | (Id id),  Exist => parse t acc

                  (* Do nothing since these two case does not exist  *)
                  | None,  Exist => parse t acc
                  | (Id id), Create => parse t acc
                  end
  end.
  (* Add will work regardless, unless you delete? *)
  (*  Delete only if it contains ID *)

(* Add *)
Example parse_0 : parse [(Asset None (Eid 0) Create 0)] [] = [(Asset None (Eid 0) Create 0)].  Proof. reflexivity. Qed.
Example parse_1 : parse [(Asset None (Eid 0) Create 0);(Asset None (Eid 0) Delete 0)] [] = [].  Proof. reflexivity. Qed.
Example parse_2 : parse [(Asset None (Eid 0) Create 0);(Asset None (Eid 0) Update 1)] [] = [(Asset None (Eid 0) Create 1)].  Proof. reflexivity. Qed.
Example parse_2' : parse [(Asset None (Eid 0) Create 0);(Asset None (Eid 0) Update 1);(Asset None (Eid 0) Update 2)] [] = [(Asset None (Eid 0) Create 2)].  Proof. reflexivity. Qed.

  Example parse_3 : parse [(Asset None (Eid 0) Create 0);(Asset None (Eid 0) Update 1);(Asset None (Eid 0) Delete 1)] [] = [].  Proof. reflexivity. Qed.

(* Delete *)
Example parse_4 : parse [(Asset (Id 0) (Eid 0) Exist 0); (Asset (Id 0) (Eid 0) Delete 0)] [] = [(Asset (Id 0) (Eid 0) Delete 0)].  Proof. reflexivity. Qed.
Example parse_5 : parse [(Asset (Id 0) (Eid 0) Exist 0); (Asset (Id 0) (Eid 0) Update 1); (Asset (Id 0) (Eid 0) Delete 1)] [] = [(Asset (Id 0) (Eid 0) Delete 1)].  Proof. reflexivity. Qed.

(* Update *)
Example parse_6 : parse [(Asset (Id 0) (Eid 0) Exist 0); (Asset (Id 0) (Eid 0) Update 1); (Asset (Id 0) (Eid 0) Update 2)] [] = [(Asset (Id 0) (Eid 0) Update 2)].  Proof. reflexivity. Qed.

(* Combine *)
Example parse_7 :
  parse
  [
  (Asset (Id 0) (Eid 0) Exist 0);
  (Asset (Id 1) (Eid 1) Exist 0);
  (Asset None (Eid 2) Create 0);
  (Asset None (Eid 3) Create 0);

  (Asset (Id 0) (Eid 0) Update 1);
  (Asset (Id 0) (Eid 1) Update 1);
  (Asset None (Eid 2) Update 1);
  (Asset None (Eid 3) Update 1);

  (Asset (Id 0) (Eid 0) Update 2);
  (Asset (Id 0) (Eid 1) Update 2);
  (Asset None (Eid 2) Update 2);
  (Asset None (Eid 3) Update 2);

  (Asset (Id 0) (Eid 0) Delete 2);
  (Asset None (Eid 2) Delete 2)
  ] []
  =
 [Asset (Id 0) (Eid 1) Update 2; Asset None (Eid 3) Create 2;
Asset (Id 0) (Eid 0) Delete 2].
  Proof. simpl. reflexivity. Qed.

End Entries.


From Hammer Require Import Hammer.

Require Import PeanoNat Lt Le.

Local Open Scope nat_scope.

Lemma minus_n_O n : n = n - 0.
Proof. hammer_hook "Minus" "Minus.minus_n_O".
symmetry. apply Nat.sub_0_r.
Qed.

Lemma minus_Sn_m n m : m <= n -> S (n - m) = S n - m.
Proof. hammer_hook "Minus" "Minus.minus_Sn_m".
intros. symmetry. now apply Nat.sub_succ_l.
Qed.

Theorem pred_of_minus n : pred n = n - 1.
Proof. hammer_hook "Minus" "Minus.pred_of_minus".
symmetry. apply Nat.sub_1_r.
Qed.

Notation minus_diag := Nat.sub_diag (compat "8.4").

Lemma minus_diag_reverse n : 0 = n - n.
Proof. hammer_hook "Minus" "Minus.minus_diag_reverse".
symmetry. apply Nat.sub_diag.
Qed.

Notation minus_n_n := minus_diag_reverse.

Lemma minus_plus_simpl_l_reverse n m p : n - m = p + n - (p + m).
Proof. hammer_hook "Minus" "Minus.minus_plus_simpl_l_reverse".
now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub.
Qed.

Lemma plus_minus n m p : n = m + p -> p = n - m.
Proof. hammer_hook "Minus" "Minus.plus_minus".
symmetry. now apply Nat.add_sub_eq_l.
Qed.

Lemma minus_plus n m : n + m - n = m.
Proof. hammer_hook "Minus" "Minus.minus_plus".
rewrite Nat.add_comm. apply Nat.add_sub.
Qed.

Lemma le_plus_minus_r n m : n <= m -> n + (m - n) = m.
Proof. hammer_hook "Minus" "Minus.le_plus_minus_r".
rewrite Nat.add_comm. apply Nat.sub_add.
Qed.

Lemma le_plus_minus n m : n <= m -> m = n + (m - n).
Proof. hammer_hook "Minus" "Minus.le_plus_minus".
intros. symmetry. rewrite Nat.add_comm. now apply Nat.sub_add.
Qed.

Notation minus_le_compat_r :=
Nat.sub_le_mono_r (compat "8.4").

Notation minus_le_compat_l :=
Nat.sub_le_mono_l (compat "8.4").

Notation le_minus := Nat.le_sub_l (compat "8.4").
Notation lt_minus := Nat.sub_lt (compat "8.4").

Lemma lt_O_minus_lt n m : 0 < n - m -> m < n.
Proof. hammer_hook "Minus" "Minus.lt_O_minus_lt".
apply Nat.lt_add_lt_sub_r.
Qed.

Theorem not_le_minus_0 n m : ~ m <= n -> n - m = 0.
Proof. hammer_hook "Minus" "Minus.not_le_minus_0".
intros. now apply Nat.sub_0_le, Nat.lt_le_incl, Nat.lt_nge.
Qed.

Hint Resolve minus_n_O: arith.
Hint Resolve minus_Sn_m: arith.
Hint Resolve minus_diag_reverse: arith.
Hint Resolve minus_plus_simpl_l_reverse: arith.
Hint Immediate plus_minus: arith.
Hint Resolve minus_plus: arith.
Hint Resolve le_plus_minus: arith.
Hint Resolve le_plus_minus_r: arith.
Hint Resolve lt_minus: arith.
Hint Immediate lt_O_minus_lt: arith.


Require Import Unicode.Utf8.
Require Import Game.World.Addition.

(* Level 1 *)

Lemma example_1_prop (P Q : Prop) (p : P) (h : P → Q) : Q.
Proof.
  apply h.
  exact p.
Qed.

(* Level 2 *)

Lemma imp_self (P : Prop) : P → P.
Proof.
  intro p.
  exact p.
Qed.

(* Level 3 *)

Lemma maze1 (P Q R S T U: Prop)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U.
Proof.
  pose (q := h(p)).
  pose (t := j(q)).
  pose (u := l(t)).
  exact u.
Qed.

(* Level 4 *)

Lemma maze2 (P Q R S T U: Prop)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U.
Proof.
  apply l.
  apply j.
  apply h.
  exact p.
Qed.

(* Level 5 *)

Lemma example_5_prop (P Q : Prop) : P → (Q → P).
Proof.
  intro p.
  intro q.
  exact p.
Qed.

(* Level 6 *)

Lemma example_6_prop (P Q R : Prop) : (P → (Q → R)) → ((P → Q) → (P → R)).
Proof.
  intro f.
  intro g.
  intro p.
  apply f.
  exact p.
  apply g.
  exact p.
Qed.

(* Level 7 *)

Lemma imp_trans (P Q R : Prop) : (P → Q) → ((Q → R) → (P → R)).
Proof.
  intro f.
  intro g.
  intro p.
  apply g.
  apply f.
  exact p.
Qed.

(* Level 8 *)

Lemma contrapositive (P Q : Prop) : (P → Q) → (¬ Q → ¬ P).
Proof.
  (* ¬Q ↔ P → false *)
  unfold not.
  intro f.
  intro g.
  intro p.
  apply g.
  apply f.
  exact p.
Qed.

(* Level 9 *)
(* `tauto`: Automatically solve easy goals *)

Lemma example_9_prop (A B C D E F G H I J K L : Prop)
(f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F)
(f6 : F → C) (f7 : B → C) (f8 : F → G) (f9 : G → J) (f10 : I → J)
(f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
 : A → L.
Proof.
  tauto.
Qed.


Require Import Arith_base.
Require Vectors.Fin.
Import EqNotations.
Local Open Scope nat_scope.

Inductive vector A : nat -> Type :=
  | nil : vector A 0
  | cons : forall (h:A) (n:nat), vector A n -> vector A (S n).


Require Omega.
Require Export Bool List.
Export ListNotations.
Require Export Arith Arith.EqNat.
Require Export Smallest.

Inductive is_sorted : list nat -> Prop :=
  sorted_nil  : is_sorted []
| sorted_one  : forall n, is_sorted [n]
| sorted_cons : forall n tl,
    is_sorted tl -> is_smallest n (n::tl) -> is_sorted (n::tl).

Hint Constructors is_sorted.

Lemma head_is_smallest : forall (a : nat) (l : list nat),
  is_sorted (a::l) -> is_smallest a (a::l).
Proof. intros. inversion H; auto. Defined.

Lemma tail_is_sorted : forall (a : nat) (l : list nat),
  is_sorted (a::l) -> is_sorted l.
Proof. intros. inversion H; auto. Defined.

Inductive is_inserted : nat -> list nat -> list nat -> Prop :=
  ins_head : forall n tl, is_inserted n tl (n::tl)
| ins_tail : forall n m tl tl', is_inserted n tl tl' -> is_inserted n (m::tl) (m::tl').

Hint Constructors is_inserted.

Lemma smallest_head_perm a n tl : is_smallest a (n :: a :: tl) -> is_smallest a (a :: n :: tl).
Proof.
intros H; inversion H.
  rewrite H0 in H. assumption.
  inversion H4.
    apply (smallest_head a n [n] (lt_le_weak _ _ H3)). constructor.
    set (le_lt_dec n m0) as S.
      inversion S.
        apply (smallest_head a n (n :: tl) (lt_le_weak _ _ H3)).
          apply (smallest_head n m0 tl H9 H8).
        apply (smallest_head a m0 (n :: tl) H6).
          apply (smallest_tail n m0 tl H9 H8).
    omega.
Qed.

Lemma smallest_with_n a n tl : is_smallest a (a :: tl) -> a <= n -> is_smallest a (a :: n :: tl).
Proof.
intros H; inversion H; intros Hle.
  apply (smallest_head a n [n] Hle). constructor.
  apply (smallest_head_perm).
    set (le_lt_eq_dec a n Hle) as S.
      inversion S.
        apply (smallest_tail _ _ _ H4 H).
        rewrite<-H4.
          apply (smallest_head a a (a :: tl) (le_refl a) H).
  omega.
Qed.

Lemma smallest_without_n a n tl : is_smallest a (a :: n :: tl) -> is_smallest a (a :: tl).
Proof.
intros H; inversion H.
  inversion H3.
    apply smallest_unit.
    apply (smallest_head a m0 tl).
      rewrite H4 in H3, H1.
        apply (le_trans a n m0 H1 H7). assumption.
    apply (smallest_head a m tl H1). assumption.
  omega.
Qed.

Lemma smallest_than_snd a n tl : is_smallest a (a :: n :: tl) -> a <= n.
Proof.
intros H; inversion H.
  inversion H3.
    rewrite<-H6; assumption.
    rewrite<-H4; assumption.
    apply lt_le_weak.
      apply (le_lt_trans a m n H1 H7).
  omega.
Qed.

Lemma insert_bigger : forall (a b : nat) (l l' : list nat),
  is_smallest a (a::l) -> b > a -> is_inserted b l l' -> is_smallest a (a::l').
Proof.
intros a b l l' H1 H2 H3.
  induction H3.
    apply (smallest_with_n a n tl H1); omega.
    apply (smallest_with_n a m tl').
      apply IHis_inserted; try assumption.
        apply (smallest_without_n a m tl H1).
      apply (smallest_than_snd a m tl H1).
Qed.

Lemma insert_sorted : forall (a : nat) (l : list nat),
  is_sorted l -> {l' | is_inserted a l l' & is_sorted l'}.
Proof.
  intros. induction l. exists [a]; auto.
    assert (A: is_sorted l). apply (tail_is_sorted a0 l). assumption.
      apply IHl in A. inversion A.
      destruct (le_gt_dec a a0).
        exists (a::a0::l); auto. apply (sorted_cons a (a0::l)).
          auto. apply (smallest_head a a0 (a0::l)). auto.
          apply head_is_smallest. assumption.
        exists (a0::x). auto. apply sorted_cons. auto.
          apply (insert_bigger a0 a l x);
            try apply (head_is_smallest a0 l); assumption.
Defined.

Inductive is_permutation : list nat -> list nat -> Prop :=
  perm_nil  : is_permutation [] []
| perm_cons : forall n l l' m,
   is_permutation l l' -> is_inserted n l' m -> is_permutation (n::l) m.

Hint Constructors is_permutation.

Theorem sort : forall (l : list nat), {l' | is_permutation l l' & is_sorted l'}.
Proof.
  intros. induction l. exists []; auto.
    inversion IHl. apply (insert_sorted a x) in H0. inversion H0.
      exists x0. eauto. assumption.
Defined.

Print sort.

Extraction Language Ocaml.
Extraction "insort.ml" sort.

Program Fixpoint insert_sorted_fix (a : nat) (l : list nat) :
    is_sorted l -> {l' | is_inserted a l l' /\ is_sorted l'} := fun H =>
  match l with
  | nil     => [a]
  | x :: xs => if le_gt_dec a x
               then a :: l
               else x :: (insert_sorted_fix a xs _)
  end.
Next Obligation.
split; auto.
  apply sorted_cons. assumption.
    apply (smallest_head a x). assumption.
      inversion H; auto.
Qed.
Next Obligation.
inversion H; auto.
Qed.
Next Obligation.
split.
  apply ins_tail; auto.
    apply sorted_cons; auto.
      apply (insert_bigger x a xs x0); auto.
        inversion H; auto.
Defined.

Require Import Permutation.

Lemma insert_sorted_fix_perm (a : nat) (l : list nat) (H : is_sorted l) :
    Permutation (a :: l) (proj1_sig (insert_sorted_fix a l H)).
Proof.
  generalize dependent H.
    generalize dependent a.
      induction l.
        intros a H. unfold insert_sorted_fix; simpl; auto.
        intros b H; simpl.
          destruct (le_gt_dec b a) eqn: Hab; simpl.
            apply Permutation_refl.
            apply (@perm_trans _ (b :: a :: l) (a :: b :: l)); auto.
              apply perm_swap.
Qed.

(*
Program Fixpoint sort_prog (l : list nat) :
    {l' | Permutation l l' /\ is_sorted l'} :=
  match l with
  | nil     => nil
  | x :: xs => insert_sorted_fix x (sort_prog xs) _
  end.
Next Obligation.
  Admitted.
  split.
  admit.
Defined.
*)

(* Realization w/o dependent types *)

Fixpoint insert_fun a l :=
  match l with
  | nil     => [a]
  | x :: xs => if le_gt_dec a x
               then a :: l
               else x :: (insert_fun a xs)
  end.

Fixpoint insert_sort l :=
  match l with
  | nil     => nil
  | x :: xs => insert_fun x (insert_sort xs)
  end.

Lemma smallest_in : forall l a, is_smallest a l -> (forall x, In x l -> a <= x).
Proof.
induction l.
  intros a  H1 x H2. inversion H2.
  intros a0 H1 x H2. destruct H2.
    rewrite H in H1. clear a H.
      inversion H1; auto. apply lt_le_weak; auto.
    inversion H1.
      rewrite <- H4 in H; inversion H.
      apply (le_trans a m x H4).
        apply (IHl _ H5 _ H).
      apply IHl; auto.
Qed.

Lemma smallest_in_perm : forall a l l',
  is_smallest a l -> Permutation l l' -> (forall x, In x l' -> a <= x).
Proof.
intros a l l' H1 H2 x H3.
  apply (smallest_in l a H1).
    apply (Permutation_in x (Permutation_sym H2) H3).
Qed.

Lemma smallest_dec : forall l, l <> [] -> {x | is_smallest x l}.
Proof.
induction l. intros H; exfalso; auto.
  intros _.
    destruct l. exists a; auto.
      assert (n :: l <> []) as H. intros H. inversion H.
      apply IHl in H; destruct H.
        destruct (le_lt_dec a x).
          exists a. apply (smallest_head a x); auto.
          exists x. apply smallest_tail; auto.
Qed.

Lemma smallest_in_list : forall a l, is_smallest a l -> In a l.
Proof.
induction l; intros H; inversion H.
  constructor; auto.
  constructor; auto.
  right. apply (IHl H4).
Qed.

Lemma in_list_smallest : forall l a,
  In a l -> (forall x, In x l -> a <= x) -> is_smallest a l.
Proof.
induction l.
  intros a H; inversion H.
  intros b H1 H2.
    destruct H1.
      rewrite <- H in H2. rewrite <- H. clear b H.
        destruct l; auto.
        pose (smallest_dec (n::l)) as H3.
          assert (n::l <> []) as H4. intros H0. inversion H0.
          apply H3 in H4. destruct H4.
            assert (a <= x) as H5. apply H2. right.
              apply (smallest_in_list _ _ i).
            apply (smallest_head _ x); auto.
      assert (b <= a) as H1. apply H2. left; auto.
      destruct (le_lt_eq_dec _ _ H1).
        apply smallest_tail; auto.
          apply IHl; auto.
            intros x H3. apply H2; right; auto.
        rewrite e. rewrite e in H2, H. clear b H1 e.
          apply (smallest_head _ a). apply le_refl.
            apply IHl; auto. intros x H3. apply H2.
              right; auto.
Qed.

Lemma smallest_perm : forall a l l', is_smallest a l -> Permutation l l' -> is_smallest a l'.
Proof.
intros a l l' H1 H2.
  apply in_list_smallest.
    apply (Permutation_in _ H2). apply (smallest_in_list _ _ H1).
    apply (smallest_in_perm _ _ _ H1 H2).
Qed.

Lemma insert_fun_to_sort : forall a l, is_sorted l ->
  Permutation (insert_fun a l) (a :: l) /\ is_sorted (insert_fun a l).
Proof.
intros a l. induction l; intros H.
  split; auto. unfold insert_fun; auto.
  assert (is_sorted l) as H1. inversion H; auto.
    unfold insert_fun.
      destruct (le_gt_dec a a0) eqn: H2; fold insert_fun.
        split; auto; constructor; auto.
          apply (smallest_head _ a0); auto.
            apply head_is_smallest; auto.
        split.
          eapply (@perm_trans _ _ (a0 :: a :: l)); constructor.
            apply (IHl H1).
          destruct (IHl H1). constructor; auto.
            apply (smallest_perm a0 (a0 :: a :: l)).
              apply smallest_head_perm.
                apply smallest_tail; auto.
                  apply head_is_smallest; auto.
              constructor. apply Permutation_sym. auto.
Qed.

Theorem insert_sort_is_sort :
  forall l, Permutation (insert_sort l) l /\  is_sorted (insert_sort l).
Proof.
intros l; induction l; simpl; auto.
  destruct IHl as [H1 H2].
    pose (H := insert_fun_to_sort a (insert_sort l)).
      destruct H as [H3 H4]; auto.
       split; auto. eapply (@perm_trans _ _ (a :: insert_sort l)); auto.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (lf3 : natural) : natural := plus lf1 lf3.


(*
Theorem plus_0_r_firsttry : forall n:nat,
  n + 0 = n.
Proof.
intros.
induction n.
simpl. reflexivity.
simpl. rewrite IHn.
simpl. reflexivity.
Qed.
*)

Fixpoint minus (m n : nat) :=
match m, n with
  | O   , _    => O
  | S _ , O    => n
  | S m', S n' => minus m' n'
  end.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
induction n.
simpl. reflexivity.
simpl. rewrite IHn.
simpl. reflexivity.
Qed.

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
intros.
induction m.
simpl. reflexivity.
simpl. reflexivity.
Qed.

Theorem mult_0_plus'_1 : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
intros n m.
simpl. reflexivity.
Qed.

Theorem mult_0_plus'_2 : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
intros.
assert (H: 0+n=n).
simpl. reflexivity.
rewrite H.
simpl. reflexivity.
Qed.

(*

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
intros.
assert (H : n+m = m+n).
simpl.
*)


Global Set Automatic Coercions Import.
Set Implicit Arguments.

Require Import Arith.
Require Compare_dec.
Require EqNat.
Require Import Omega.

Fixpoint cond_eq (T: nat -> Set) n m {struct n}: forall c, T (c + n) -> T (c + m) -> Prop :=
  match n, m return forall c, T (c + n) -> T (c + m) -> Prop with
  | 0, 0 => fun c x y => x = y
  | S n', S m' => fun c x y => cond_eq T n' m' (S c)
      (eq_rec_r T x (plus_n_Sm c n'))
      (eq_rec_r T y (plus_n_Sm c m'))
  | _, _ => fun _ _ _ => True
  end.

Lemma cond_eq_eq (T: nat -> Set) n c (x y: T (c + n)): cond_eq T n n c x y = (x = y).
Proof with auto.
  induction n in c, x, y |- *...
  simpl.
  intros.
  rewrite IHn.
  unfold eq_rec_r.
  unfold eq_rec.
  unfold eq_rect.
  simpl plus.
  case (sym_eq (plus_n_Sm c n))...
Qed.

Lemma cond_eq_neq (T: nat -> Set) n m c (x: T (c + n)) (y: T (c + m)): n <> m -> cond_eq T n m c x y = True.
Proof with auto.
  induction n in m, c, x, y |- *...
    destruct m...
    intros.
    elimtype False...
  destruct m...
  intros.
  simpl.
  apply IHn.
  intro.
  apply H.
  subst...
Qed.

Inductive natBelow: nat -> Set := mkNatBelow (v p: nat): natBelow (S (v + p)).

Definition nb_val {n: nat} (nb: natBelow n): nat := match nb with mkNatBelow m _ => m end.

Coercion nb_val: natBelow >-> nat.

Lemma natBelow_unique n (x y: natBelow n): nb_val x = nb_val y -> x = y.
Proof with auto.
  cut (forall n (x: natBelow n) m (y: natBelow m), nb_val x = nb_val y -> cond_eq natBelow n m 0 x y); [|clear x y]; intros.
    set (H n x n y H0).
    rewrite cond_eq_eq in c...
  destruct x.
  destruct y.
  simpl in H.
  subst.
  destruct (eq_nat_dec p p0).
    subst.
    rewrite cond_eq_eq...
  rewrite cond_eq_neq...
  intro.
  omega.
Qed.

Lemma natBelow_uneq n (x y: natBelow n): nb_val x <> nb_val y -> x <> y.
Proof. intros. intro. subst. auto. Qed.

Lemma natBelow_eq_dec n (x y: natBelow n): { x = y } + { x <> y }.
Proof with auto.
  intros. destruct (eq_nat_dec x y); [left | right].
    apply natBelow_unique...
  apply natBelow_uneq...
Qed.

Definition nb0 n: natBelow (S n) := mkNatBelow 0 n.

Definition Snb n (nb: natBelow n): natBelow (S n) :=
  match nb in (natBelow n0) return (natBelow (S n0)) with
  | mkNatBelow v p => mkNatBelow (S v) p
  end.


Require Import Coq.Relations.Relations.

Require Export Misc.
Require Export CatSem.CAT.category.
Require Import CatSem.CAT.product.
Require Import CatSem.CAT.initial_terminal.
Require Import CatSem.CAT.coproduct.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section SET.

Section SET_data.

Variable A B:Set.

Definition SET_hom_equiv:
   relation (A -> B) := fun f g => forall x, f x = g x.

Lemma SET_hom_oid_prf: @Equivalence (A -> B)
                       (fun f g => forall x, f x = g x).
Proof.
  constructor;
  unfold Reflexive;
  unfold Symmetric;
  unfold Transitive;
  intros;
  etransitivity;
  eauto.
Qed.

Definition SET_hom_oid := Build_Setoid SET_hom_oid_prf.

End SET_data.

Obligation Tactic := cat; try unf_Proper;
  intros; repeat rew_hyp; auto.

Program Instance SET_catstruct : Cat_struct (fun a b : Set => a -> b) := {
   mor_oid a b := SET_hom_oid a b;
   id a := fun x: a => x;
   comp a b c f g := fun x => g (f x)
}.

Definition SET := Build_Cat SET_catstruct.

End SET.

Section SET_INIT_TERM.

Inductive Empty : Set := .

Obligation Tactic := simpl; intros;
  repeat match goal with [H:Empty |- _ ] => elim H end;
      cat.

Program Instance SET_INIT : Initial SET := {
   Init := Empty }.

Hint Extern 3 (?a = ?b) => elim a.

Program Instance SET_TERM : Terminal SET := {
    Term := unit;
    TermMor A := fun x => tt
}.

End SET_INIT_TERM.

Section SET_COPROD.

Inductive SET_COPROD_ob (A B: Set): Set :=
  | INL : A -> SET_COPROD_ob A B
  | INR : B -> SET_COPROD_ob A B.

Obligation Tactic := simpl; intros;
  repeat unf_Proper;
  intros;
  repeat match goal with
      [x : SET_COPROD_ob _ _ |- _ ] => destruct x end;
  elim_conjs;
  auto.

Program Instance SET_COPROD : Cat_Coprod SET := {
  coprod a b := SET_COPROD_ob a b;
  inl a b x := INL (A:=a) b x;
  inr a b x := INR a x;
  coprod_mor a b d f g :=
         fun x => match x with INL a => f a |
                               INR b => g b end
}.

End SET_COPROD.

Section SET_PROD.

Obligation Tactic := simpl; intros;
   try unf_Proper;
   intros; elim_conjs;
   repeat rew_hyp;
   cat.

Hint Extern 1 (_ = _ ) => apply injective_projections; simpl.

Program Instance SET_PRODUCT: Cat_Prod (SET) := {
  product a b := prod a b;
  prl a b x := fst x;
  prr a b x := snd x;
  prod_mor a c d f g := fun x => (f x, g x)
}.

End SET_PROD.


(**
The Little Prover の memb?/remb をCoqで解いてみる
 *)

Require Import Bool.
Require Import List.
Require Import Program.
Set Implicit Arguments.

(** * はじめに *)

(**
The Little Prover (TLP) の第6章では、memb?/remb という定理が扱われています。
これは、リニアなリストの要素から、文字 '?' を削除する関数 remb と、
これは、リニアなリストの要素に、文字 '?' が含まれるかを判定する関数 memb? が
定義されているとき、
任意のリスト xs に対して、(memb? (remb xs)) が必ず False になるというものです。

オリジナルはLisp系の言語なので、リストの要素は任意のデータでよいのですが、
Coqの場合は、false と true からなる bool型のリストとし、もじ '?' の代わりに true とします。
  *)

(**
ソースコードは、
#<a href="https://github.com/suharahiromichi/coq/blob/master/prog/coq_membp_remb_2.v">
ここ
</a>
にあります。
 *)

(**
まず、membp (memb? に対応する) の自然数のリストに 0 が含まれていることを判定する関数を定義ましす。
リストの先頭から見ていき 0 が含まれていたらそこで True を返します。
*)

Fixpoint membp (xs : list nat) : Prop :=
  match xs with
  | nil => False
  | 0 :: xs' => True
  | _ :: xs' => membp xs'
  end.

Compute membp (1 :: 0 :: 2 :: nil).         (** ==> [True] *)

Compute membp (1 :: 2 :: 3 :: nil).         (** ==> [False] *)

Compute membp nil.                          (** ==> [False] *)

(**
ついで、remb のリストから 0 を削除する関数を定義します。
リストの先頭から見ていき 0 なら、それを含まない結果を返し
false なら、それを含む結果を返します。
*)

Fixpoint remb (xs : list nat) : list nat :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb xs'
  | x :: xs' => x :: remb xs'
  end.

Compute remb (0 :: 1 :: 0 :: nil).         (** ==> [[1]] *)

(** * memb?/remb の証明 *)

(**
memb?/remb に対応する membp_remb は、文字通りの定義です。
結果は偽であるため、「~」がついています。
 *)

Definition membp_remb (xs : list nat) := ~ membp (remb xs).

(** 以下に、membp_remb を証明します。線形リスト xs に対する帰納法と、
要素 x に対する場合分けだけで証明されています。
なお、帰納法の仮定IHxsは、ふたつめとみっつめのnowでトリビアルに使われます。
 *)

Lemma le_membp_remb : forall (xs : list nat), membp_remb xs.
Proof.
  unfold membp_remb.
  induction xs as [|x xs IHxs].
  - now simpl.
  (** x が 0 か 0 でないかで場合分けする。 *)
  - case x as [| x']; simpl.
    (** ここで帰納法の仮定を使う。 *)
    + now trivial.
    + now trivial.

  Restart.
  unfold membp_remb.
  intros xs.
  induction xs as [|x xs IHxs]; try auto.
  now case x.
Qed.

(**
memb?/remb は定理としては自明ですが、 0 が含まれないことをチェックする関数membpによって、
 0 を削除する関数rembが正しく動作していることを証明する、と考えることができます。

これは、関数の定義とその証明を同時におこなう証明駆動開発の一例となります。
Coqにはそれをサポートする「Program」コマンドがあります。
これを使って remb を再定義してみましょう。

remb' の値は、単なる list nat ではなく、
[{ys : list nat | ~ membp ys}]
すなわち、
[~ membp ys] を満たす [ys] の集合の要素、
となります。

これだと、最初に想定した型と違うので困ると思うかもしれませんが、
「Program」コマンドの中では、そのサブタイプ・コアーションの機能によって、
list boot 型と同一視されます。

remb' の結果が普通にconsされていることに気づいてください。

「Program」コマンドの中では、そのサブタイプ・コアーションは、
再帰呼び出しのみならず、他の（定義済みの）任意な関数に適用されます。
 *)

Program Fixpoint remb' (xs : list nat) : {ys : list nat | ~ membp ys} :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb' xs'
  | x :: xs' => x :: remb' xs'
  end.
Obligation 2.
Proof.
  case x as [| x']; simpl.
  - generalize (H xs'); intro H'.
    exfalso.
    now apply H'.
  - now trivial.
Defined.

Compute ` (remb' (0 :: 1 :: 0 :: nil)).     (** ==> [[1]] *)

Extraction remb'.
(**
生成されたコードには、rembp は含まれていない。

[[
val remb' : nat list -> nat list,

let rec remb' = function
| Nil -> Nil
| Cons (x, xs') ->
  (match x with
   | O -> remb' xs'
   | S n -> let x0 = S n in Cons (x0, (remb' xs')))
]]
*)

(** * 証明駆動開発 *)

(**
これからは、TLP の範囲を越える事項ですが、
remb' の定義を「リストから 0 を除去する関数」の証明付き定義と考えると問題があります。

membp は 0 の有無しかチェックしていませんから、
remb の本体が「つねにnil」を返すような定義であっても問題なくパスします。これではだめです。

remb の厳密な定義は、(1)に加えて(2)も満たさないといけません。

(1) 結果のリストに 0 が含まれないこと。

(2) 結果のリストがもとのリストのサブリストであること。
 *)

(** サブリストを定義します。  *)

Section Sublist.
  Variable A : Type.
  Variable f : A -> bool.

  (** Sublist l' l <==> l' ⊆ l *)

  Inductive Sublist : list A -> list A -> Prop :=
  | SL_nil l : Sublist nil l
  | SL_skip x l' l : Sublist l' l -> Sublist l' (x :: l)
  | SL_cons x l' l : Sublist l' l -> Sublist (x :: l') (x :: l).

End Sublist.

Hint Constructors Sublist.

(**
定理を直接証明します。
(1) と (2) を連言(/\)でつなぎます。
また let ... in は普通の意味で、ys は構文的な意味しかもちません。
*)

Goal forall (xs : list nat),
    let ys := remb xs in
    ~ membp (remb xs) /\ Sublist ys xs.
Proof.
  intros xs.
  split.
  - apply le_membp_remb.
  - induction xs as [| x' xs' IHxs]; simpl.
    + now auto.                             (** SL_nil を使う。 *)
    + case x' as [|x''].
      * now auto.                           (** SL_Skip を使う。 *)
      * now auto.                           (** SL_cons を使う。 *)
Qed.

(**
「Program」コマンドでの定義に条件を追加します。
*)

Program Fixpoint remb'' (xs : list nat) :
  {ys : list nat | ~ membp (remb xs) /\ Sublist ys xs} :=
  match xs with
  | nil => nil
  | 0 :: xs' => remb'' xs'
  | x :: xs' => x :: remb'' xs'
  end.
Obligation 3.
Proof.
  split.
  - case x as [| x']; simpl.
    + generalize (H xs'); intro H'.
      exfalso.
      now apply H'.
    + now trivial.
  - now auto.                               (** SL_cons を使う。 *)
Defined.

Compute ` (remb'' (0 :: 1 :: 0 :: nil)).    (** ==> [[1]] *)

Extraction remb''.

(**
生成されたコードには、Sublist は含まれていません。

[[
val remb'' : nat list -> nat list

let rec remb'' = function
| Nil -> Nil
| Cons (b, xs') ->
  (match b with
   |  0  -> remb'' xs'
   | False -> Cons (False, (remb'' xs')))
]]
 *)

(** * 帰納法の公理 *)

(**
TLPにもどって、帰納法による証明について考えてみましょう。
TLPでは、（例によって、天から降ってきた）「inductive claim」を証明しています。
これの導きかたは第6章の最後に記載されていますが、Coqの場合は、
リストの型定義にもとづく「公理」を使います。
 *)

Check list_ind : forall (A : Type) (P : list A -> Prop),
    P [] ->
    (forall (a : A) (l : list A), P l -> P (a :: l)) ->
    forall l : list A, P l.

(**
これを membp_remb に適用すると次を得ます。
繰り返しますが、これは証明するべきものではなく、「公理」です。
 *)

Check list_ind membp_remb :
  membp_remb [] ->
  (forall (a : nat) (l : list nat), membp_remb l -> membp_remb (a :: l)) ->
  forall l : list nat, membp_remb l.

(**
この公理を使うなら、

[forall l : list nat, membp_remb l]

を証明するには、

[membp_remb []]

と

[forall (a : nat) (l : list nat), membp_remb l -> membp_remb (a :: l)]

とを証明すればよいことになります。後者は、TLPでは、l は nil でないことを条件に、
[(cdr l)] をとっていて、つまり、

[forall (l : list nat  ), membp_remb (tl l) -> membp_remb l]

となっています。おなじですね。
 *)

(**
実際の証明は、以下の通りです。
 *)

Goal forall xs, membp_remb xs.
Proof.
  intros xs.
  apply (list_ind membp_remb).
  - now simpl.
  - intros x' xs' IHxs.
    case x'; simpl.
    + now trivial.
    + now trivial.
Qed.

(**
最初の証明では、

[induction xs] というタクティクを使いましたが、

この公理を

[apply (list_ind membp_remb)]

として、適用することと同じです。
 *)

(* END *)


Require Import PeanoNat.
Local Open Scope nat_scope.

Require Import List.
Import ListNotations.

Inductive btree : Type :=
  | empty : btree
  | node : btree->nat->btree->btree.

Definition tree :=node (node empty 7 (node empty 2 empty)) 1 (node(node empty 10 empty)8 (node empty 3 empty)).

Print List.
(*[] == nli*)
Check [].
(*cons pentru a adauga in lista*)
Check (cons 4 []).
Check (cons 5 nil).
Check [4;5].

Definition myList := [4;5].

Compute 6 :: myList.
 (*Concatenarea a doua liste*)
Compute myList++myList.

Fixpoint returnNodeValue(t :btree):nat :=
  match t with
  |empty=>0
  |node l v r =>v
end.

Fixpoint preorderCrossing(b:btree):list nat :=
  match b with
  | empty => []
  | node l n r =>
    n :: (preorderCrossing l) ++ (preorderCrossing r)
end.

Compute (preorderCrossing tree).
(*Parcurgerea inordine*)

(*Exercitiu 1*)
Fixpoint inorderCrossing(t:btree):list nat :=
  match t with
  |empty => []
  | node l n r =>
    (inorderCrossing l)++[n]++(inorderCrossing r)
end.

Compute (inorderCrossing tree).

(*Exercitiul 2*)
Fixpoint sibling (t:btree) (a:nat):list nat :=
  match t with
  | node l v r => if (returnNodeValue l) =? a
                  then [(returnNodeValue r)]
                  else if (returnNodeValue r)=? a
                        then [(returnNodeValue l)]
                          else (sibling l a)++(sibling r a)
  | empty => []

end.

Compute (sibling tree 8).
Fixpoint parent (t:btree) (a:nat) : list nat :=
  match t with
  | empty => []
  | node l v r => if orb ((returnNodeValue l) =? a) ((returnNodeValue r)=?a)
                    then [v]
                     else (parent l a)++(parent r a)
end.

Fixpoint returnListValue (l:list nat) : nat :=
  match l with
  | [] => 0
  | cons v list => v
end.

Fixpoint isRoot(t:btree):bool :=
 match t with
  | empty => false
  | node l v r => true
end.

Compute parent tree 7.
Compute returnListValue myList.

Fixpoint degree (t original:btree) (a:nat) : list nat :=
  match t with
  | empty => []
  | node empty v empty => if negb( a =? v)
                          then []
                          else if length(parent original v)=? 0
                                then [0]
                                else [1]
  | node l v empty => if negb (a =? v)
                      then []++(degree l original a)
                      else if length(parent original v)=? 0
                            then [1]
                            else [2]

  | node empty v r => if negb ( a=? v)
                      then []++(degree r original a)
                      else if length(parent original v)=? 0
                            then [1]
                            else [2]

  | node l v r => if negb ( a =? v)
                    then (degree l original a)++(degree r original a)
                    else if length(parent original v) =? 0
                          then [2]
                          else [3]
end.
Compute length [2].
Compute degree tree tree 7.

Fixpoint findTheRighestNode (t:btree) : nat :=
  match t with
  | empty => 0
  | node l v empty => v
  | node l v r => findTheRighestNode r
end.

Fixpoint deleteTheRighestNode (t original:btree):btree :=
  match t with
  | empty => empty
  | node empty v empty => empty
  | node l v r => deleteTheRighestNode r original

end.

Compute deleteTheRighestNode tree tree.
Print tree.


Require
  MathClasses.implementations.stdlib_binary_integers MathClasses.theory.integers MathClasses.orders.semirings.
Require Import
  Coq.Setoids.Setoid Bignums.SpecViaZ.NSig Bignums.SpecViaZ.NSigNAxioms Coq.NArith.NArith Coq.ZArith.ZArith Coq.Program.Program Coq.Classes.Morphisms
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.integers
  MathClasses.interfaces.orders MathClasses.interfaces.additional_operations.

Module NType_Integers (Import anyN: NType).

Module axioms := NTypeIsNAxioms anyN.

#[global]
Instance NType_equiv : Equiv t := eq.
#[global]
Instance NType_plus : Plus t := add.
#[global]
Instance NType_0 : Zero t := zero.
#[global]
Instance NType_1 : One t := one.
#[global]
Instance NType_mult : Mult t := mul.

#[global]
Instance: Setoid t | 10 := {}.

#[global]
Program Instance: ∀ x y: t, Decision (x = y) := λ x y, match compare x y with
  | Eq => left _
  | _ => right _
  end.
Next Obligation.
  apply Zcompare_Eq_eq. now rewrite <-spec_compare.
Qed.
Next Obligation.
  rewrite spec_compare in *. intros E.
  apply Zcompare_Eq_iff_eq in E. auto.
Qed.

Ltac unfold_equiv := unfold equiv, NType_equiv, eq in *.

Lemma  NType_semiring_theory: semi_ring_theory zero one add mul eq.
Proof. repeat split; repeat intro; axioms.zify; auto with zarith. Qed.

#[global]
Instance: SemiRing t | 10 := rings.from_stdlib_semiring_theory NType_semiring_theory.

#[global]
Instance inject_NType_N: Cast t N := to_N.

#[global]
Instance: Proper ((=) ==> (=)) to_N.
Proof. intros x y E. unfold equiv, NType_equiv, eq in E. unfold to_N. now rewrite E. Qed.

#[global]
Instance: SemiRing_Morphism to_N.
Proof.
  repeat (split; try apply _); unfold to_N; intros.
     now rewrite spec_add, Z2N.inj_add by apply spec_pos.
    unfold mon_unit, zero_is_mon_unit, NType_0. now rewrite spec_0.
   now rewrite spec_mul, Z2N.inj_mul by apply spec_pos.
  unfold mon_unit, one_is_mon_unit, NType_1. now rewrite spec_1.
Qed.

#[global]
Instance inject_N_NType: Cast N t := of_N.
#[global]
Instance: Inverse to_N := of_N.

#[global]
Instance: Surjective to_N.
Proof.
  split; try apply _. intros x y E.
  rewrite <-E. unfold to_N, inverse, compose. rewrite spec_of_N.
  apply N2Z.id.
Qed.

#[global]
Instance: Injective to_N.
Proof.
  split; try apply _. intros x y E.
  unfold equiv, NType_equiv, eq. unfold to_N in E.
  rewrite <-(Z2N.id (to_Z x)), <-(Z2N.id (to_Z y)) by now apply spec_pos.
  now rewrite E.
Qed.

#[global]
Instance: Bijective to_N := {}.

#[global]
Instance: Inverse of_N := to_N.

#[global]
Instance: Bijective of_N.
Proof. apply jections.flip_bijection. Qed.

#[global]
Instance: SemiRing_Morphism of_N.
Proof. change (SemiRing_Morphism (to_N⁻¹)). split; apply _. Qed.

#[global]
Instance: NaturalsToSemiRing t := naturals.retract_is_nat_to_sr of_N.
#[global]
Instance: Naturals t := naturals.retract_is_nat of_N.

#[global]
Instance inject_NType_Z: Cast t Z := to_Z.

#[global]
Instance: Proper ((=) ==> (=)) to_Z.
Proof. now intros x y E. Qed.

#[global]
Instance: SemiRing_Morphism to_Z.
Proof.
  repeat (split; try apply _).
     exact spec_add.
    exact spec_0.
   exact spec_mul.
  exact spec_1.
Qed.

(* Order *)
#[global]
Instance  NType_le: Le t := le.
#[global]
Instance  NType_lt: Lt t := lt.

#[global]
Instance: Proper ((=) ==> (=) ==> iff) NType_le.
Proof.
  intros ? ? E1 ? ? E2. unfold NType_le, le. unfold equiv, NType_equiv, eq in *.
  now rewrite E1, E2.
Qed.

#[global]
Instance: SemiRingOrder NType_le.
Proof.
  apply (semirings.projected_srorder to_Z).
   reflexivity.
  intros x y E. exists (sub y x).
  unfold_equiv. rewrite spec_add, spec_sub.
  rewrite Z.max_r by now apply Z.le_0_sub.
  ring.
Qed.

#[global]
Instance: OrderEmbedding to_Z.
Proof. now repeat (split; try apply _). Qed.

#[global]
Instance: TotalRelation NType_le.
Proof. now apply (maps.projected_total_order to_Z). Qed.

#[global]
Instance: FullPseudoSemiRingOrder NType_le NType_lt.
Proof.
  rapply semirings.dec_full_pseudo_srorder.
  intros x y. split.
   intro. split.
    apply axioms.lt_eq_cases. now left.
   intros E. destruct (irreflexivity (<) (to_Z x)). now rewrite E at 2.
  intros [E1 E2].
  now destruct (proj1 (axioms.lt_eq_cases _ _) E1).
Qed.

(* Efficient comparison *)
#[global]
Program Instance: ∀ x y: t, Decision (x ≤ y) := λ x y, match (compare x y) with
  | Gt => right _
  | _ => left _
  end.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Z.compare_spec (to_Z x) (to_Z y)); try discriminate.
  now apply orders.lt_not_le_flip.
Qed.
Next Obligation.
  rewrite spec_compare in *.
  destruct (Z.compare_spec (to_Z x) (to_Z y)); try discriminate; try intuition.
   now apply Zeq_le.
  now apply orders.lt_le.
Qed.

Lemma NType_succ_1_plus x : succ x = 1 + x.
Proof.
  unfold_equiv. rewrite spec_succ, rings.preserves_plus, rings.preserves_1.
  now rewrite commutativity.
Qed.

Lemma NType_two_2 : two = 2.
Proof.
  unfold_equiv. rewrite spec_2.
  now rewrite rings.preserves_plus, rings.preserves_1.
Qed.

(* Efficient [nat_pow] *)
#[global]
Program Instance NType_pow: Pow t t := pow.

#[global]
Instance: NatPowSpec t t NType_pow.
Proof.
  split.
    intros x1 y1 E1 x2 y2 E2.
    now apply axioms.pow_wd.
   intros x1. apply axioms.pow_0_r.
  intros x n.
  unfold_equiv. unfold "^", NType_pow.
  rewrite <-axioms.pow_succ_r by (red; rewrite spec_0; apply spec_pos).
  now rewrite NType_succ_1_plus.
Qed.

(* Efficient [shiftl] *)
#[global]
Program Instance NType_shiftl: ShiftL t t := shiftl.

#[global]
Instance: ShiftLSpec t t NType_shiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x y.
  unfold additional_operations.pow, NType_pow, additional_operations.shiftl, NType_shiftl.
  unfold_equiv. simpl.
  rewrite rings.preserves_mult, spec_pow.
  rewrite spec_shiftl, Z.shiftl_mul_pow2 by apply spec_pos.
  now rewrite <-NType_two_2, spec_2.
Qed.

(* Efficient [shiftr] *)
#[global]
Program Instance: ShiftR t t := shiftr.

End NType_Integers.


Require Export TopologicalSpaces.
Require Export InverseImage.
Require Export Continuity.

Section StrongTopology.

Variable A:Type.
Variable X:forall a:A, TopologicalSpace.
Variable Y:Type.
Variable f:forall a:A, point_set (X a) -> Y.

Definition strong_open (S:Ensemble Y) : Prop :=
  forall a:A, open (inverse_image (f a) S).

Definition StrongTopology : TopologicalSpace.
refine (Build_TopologicalSpace Y strong_open _ _ _).
intros.
red; intro.
assert (inverse_image (f a) (FamilyUnion F) =
  IndexedUnion (fun U:{ U:Ensemble Y | In F U } =>
                 inverse_image (f a) (proj1_sig U))).
apply Extensionality_Ensembles; red; split; red; intros.
destruct H0.
inversion H0.
exists (exist _ S H1).
constructor.
exact H2.

destruct H0.
destruct H0.
destruct a0 as [U].
constructor.
exists U; trivial.

rewrite H0.
apply open_indexed_union.
intros.
destruct a0 as [U].
simpl.
apply H; trivial.

intros.
red; intro.
rewrite inverse_image_intersection.
apply open_intersection2; (apply H || apply H0).

red; intro.
rewrite inverse_image_full.
apply open_full.
Defined.

Lemma strong_topology_makes_continuous_funcs:
  forall a:A, continuous (f a) (Y:=StrongTopology).
Proof.
intros.
red.
intros.
auto.
Qed.

Lemma strong_topology_strongest: forall (T':Ensemble Y->Prop)
  (H1:_) (H2:_) (H3:_),
  (forall a:A, continuous (f a)
          (Y:=Build_TopologicalSpace Y T' H1 H2 H3)) ->
  forall V:Ensemble Y, T' V -> strong_open V.
Proof.
intros.
unfold continuous in H.
simpl in H.
red; intros; apply H; trivial.
Qed.

End StrongTopology.

Arguments StrongTopology [A] [X] [Y].