(** In this lecture, we start to learn the first approach of describing program
specification and/or program semantics. *)

(* ################################################################# *)
(** * Assertions *)

(** In order to talk about what properties a program does/should satisfy, we
have to be able to talk about properties of program states (程序状态) first. *)

(**

                    To talk about specifications of programs, the
                    first thing we need is a way of making asser-
                    tions about properties that hold at particular
                    points during a program's execution — i.e.,
                    claims about the current state of the memory
                    when execution reaches that point.

                          --- << Software Foundation, Volume 2 >>
*)

(** Informally, an assertion (断言) is a proposition (命题) which describes a
particular property of program states. Using the following C function as an
example,

  int fib(int n) {
    int a0 = 0, a1 = 1, a2;
    int i;
    for (i = 0; i < n; ++ i) {
      a2 = a0 + a1;
      a0 = a1;
      a1 = a2;
    }
    return a0;
  }

In this C function, there are only 5 program variables, [a0], [a1], [a2], [i]
and [n]. A program state is determined by these program variables' values and
the followings are typical program assertions.

[ {[a0]} = 0 AND {[a1]} = 1     ]

[ {[a0]} < {[a1]}              ]

[ EXISTS k, {[a0]} = fib(k) AND {[a1]} = fib(k+1) AND {[a2]} = fib(k + 2) ]

*)

(** In more general cases, a C program state contains program variables' value,
program variables' address, memory contents etc. In the last lecture, we have
seen a wrong program which computes the sum of elements in a linked list. Here
is a correct program.

  struct list {unsigned int head; struct list *tail;};

  unsigned int sumlist (struct list * t) {
    unsigned int s = 0;
    while (t) {
      s = s + (t->head);
      t = t->tail;
    }
    return s;
  }

And here is an assertion.

[   ( {[t]} |-> 0 ) AND ( {[t]} + 4 |-> NULL ) AND ( {[s]} = 0 )   ]

We introduce a new predicate in this assertion [X |-> Y]. It means that the
value stored on address [X] is [Y].

*)

(* ================================================================= *)
(** ** What is a "proposition"? *)

(** As mentioned above, an assertion is a proposition which describes a property
of program states. And we have seen many assertions already. You may still ask:
what is a proposition, formally? *)

(** Mainly, it is a philosophical question. We have two answers to it. Answer 1:
a proposition is the sentence itself which describes the property. Answer 2: a
proposition is the meaning of the sentence. The math definitions of "proposition"
beyond these two answers are different. For example, assertions may be defined
as syntax trees (sentences) or sets of program states (meaning of sentences).
Both approaches are accepted by mathematicians and computer scientists. In this
course, we will just say "propositions" when we do not need to distinguish these
two representations. *)

(* ================================================================= *)
(** ** Assertions v.s. boolean functions *)

(** On one hand, assertions and boolean functions are different. *)

(** 1. Not all assertions can be represented as boolean function. Here is an
example:

[ FORALL k, k < {[n]} OR (k is_prime) OR (fib(k) is_not_prime) ]

*)

(** 2. Not all boolean functions can be represented as assertions. There can be
side effects. *)

(** 3. Assertions and boolean functions are categorically different. Assertions
describes properties but boolean functions are mainly about computation. *)

(** On the other hand, there are some connections between them. Many dynamic
program analysis tools do use boolean functions to represent assertions. *)

(* ################################################################# *)
(** * Assertion equivalence and comparison *)

(** Given two assertions [P] and [Q], if every program state [m] which satisfies
[P] also satisfies [Q], we say that [P] is stronger than [Q], or written as
[P |-- Q]. If [P] is stronger than [Q] and [Q] is stronger than [P] at the same
time, we say that [P] and [Q] are equivalent with each other. We write
[P --||-- Q]. *)

(* ################################################################# *)
(** * A formally defined toy language *)

(** Before we go on and introduce more advanced concepts, it is important that
we can make things really formal. Specifically, we will have a formal
programming language (but a simple one) and a formal assertion language. Since
it is the first time that we use Coq formal definitions in this course, we hide
those Coq code but only show some examples. *)

Require Import PL.Imp.

Import Assertion_S.
Import Concrete_Pretty_Printing.

(** We pack those definitions in another Coq file and we "import" it in Coq by
this line of code above. *)

(** The following instructions tell you how do that on your
own laptop. You can also find this instruction from << Software Foundation >>
volume 1, Chapter 2, Induction (slightly different). *)

(** BEGINNING of instruction from << Software Foundation >>. *)

(** For the [Require Import] to work, Coq needs to be able to
    find a compiled version of [Imp.v], called [Imp.vo], in a directory
    associated with the prefix [PL].  This file is analogous to the [.class]
    files compiled from [.java] source files and the [.o] files compiled from
    [.c] files.

    First create a file named [_CoqProject] containing the following line
    (if you obtained the whole volume "Logical Foundations" as a single
    archive, a [_CoqProject] should already exist and you can skip this step):

      [-Q . PL]

    This maps the current directory ("[.]", which contains [Imp.v],
    [Induction.v], etc.) to the prefix (or "logical directory") "[PL]".
    PG and CoqIDE read [_CoqProject] automatically, so they know to where to
    look for the file [Imp.vo] corresponding to the library [PL.Imp].

    Once [_CoqProject] is thus created, there are various ways to build
    [Imp.vo]:

     - In Proof General: The compilation can be made to happen automatically
       when you submit the [Require] line above to PG, by setting the emacs
       variable [coq-compile-before-require] to [t].

     - In CoqIDE: Open [Imp.v]; then, in the "Compile" menu, click
       on "Compile Buffer".

     - From the command line: Generate a [Makefile] using the [coq_makefile]
       utility, that comes installed with Coq (if you obtained the whole
       volume as a single archive, a [Makefile] should already exist
       and you can skip this step):

         [coq_makefile -f _CoqProject *.v -o Makefile]

       Note: You should rerun that command whenever you add or remove Coq files
       to the directory.

       Then you can compile [Imp.v] by running [make] with the corresponding
       [.vo] file as a target:

         [make Imp.vo]

       All files in the directory can be compiled by giving no arguments:

         [make]

       Under the hood, [make] uses the Coq compiler, [coqc].  You can also
       run [coqc] directly:

         [coqc -Q . PL Imp.v]

       But [make] also calculates dependencies between source files to compile
       them in the right order, so [make] should generally be prefered over
       explicit [coqc].

    If you have trouble (e.g., if you get complaints about missing
    identifiers later in the file), it may be because the "load path"
    for Coq is not set up correctly.  The [Print LoadPath.] command
    may be helpful in sorting out such issues.

    In particular, if you see a message like

        [Compiled library Foo makes inconsistent assumptions over
        library Bar]

    check whether you have multiple installations of Coq on your machine.
    It may be that commands (like [coqc]) that you execute in a terminal
    window are getting a different version of Coq than commands executed by
    Proof General or CoqIDE.

    - Another common reason is that the library [Bar] was modified and
      recompiled without also recompiling [Foo] which depends on it.  Recompile
      [Foo], or everything if too many files are affected.  (Using the third
      solution above: [make clean; make].)

    One more tip for CoqIDE users: If you see messages like [Error:
    Unable to locate library Imp], a likely reason is
    inconsistencies between compiling things _within CoqIDE_ vs _using
    [coqc] from the command line_.  This typically happens when there
    are two incompatible versions of [coqc] installed on your
    system (one associated with CoqIDE, and one associated with [coqc]
    from the terminal).  The workaround for this situation is
    compiling using CoqIDE only (i.e. choosing "make" from the menu),
    and avoiding using [coqc] directly at all. *)

(** END of instruction from << Software Foundation >>. *)

Module Playground_for_Program_Variables_and_Assertions.

(** This toy language only have one kind of program variables---variables with
integer type. And we can introduce some new program variables as below. *)

Local Instance a0: var := new_var().
Local Instance a1: var := new_var().
Local Instance a2: var := new_var().

(** And now, we can use assertions to talk about some properties. *)

Definition assert1: Assertion := {[a0]} = 0 AND {[a1]} = 1.
Definition assert2: Assertion := {[a0]} < {[a1]}.

(** Fibonacci numbers can be easily defined in Coq. But we do not bother to
define it here; we assume that such function exists. *)

Hypothesis fib: Z -> Z.

(** Z means integer in math. And this hypothesis says [fib] is a function from
integers to integers. We can use this function in Coq-defined Assertions as
well. *)

Definition assert3: Assertion :=
  EXISTS k, {[a0]} = fib(k) AND {[a1]} = fib(k+1) AND {[a2]} = fib(k + 2).

End Playground_for_Program_Variables_and_Assertions.

(** To make things simple, we only allow two different kinds of expressions in
this toy language. Also, only limited arithmetic operators, logical operators
and programs commands are supported. Here is a brief illustration of its syntax.

    a ::= Z
        | var
        | a + a
        | a - a
        | a * a

    b ::= true
        | false
        | a == a
        | a <= a
        | ! b
        | b && b

    c ::= Skip
        | var ::= a
        | c ;; c
        | If b Then c Else c Endif
        | While b Do c EndWhile

No function call, pointer, no memory space, no break or continue commands are in
this language. Also, we assume that there is no bound on arithmetic results.

Although this language is simple, it is enough for us to write some interesting
programs. *)

Module Playground_for_Programs.

Local Instance A: var := new_var().
Local Instance B: var := new_var().
Local Instance TEMP: var := new_var().

Definition swap_two_int: com :=
  TEMP ::= A;;
  A ::= B;;
  B ::= TEMP.

Definition decrease_to_zero: com :=
  While ! (A <= 0) Do
    A ::= A - 1
  EndWhile.

Definition ABSOLUTE_VALUE: com :=
  If A <= 0
  Then B ::= 0 - A
  Else B ::= A
  EndIf.

End Playground_for_Programs.

(** One important property of this simple programming language is that it is
type-safe, i.e. there is no run-time-error problem. We intensionally delete "/"
and pointer operations to achieve this. This enables us to introduce new
concepts and theories in a concise way. But these theories can all be
generalized to complicated real programming languages, like C. *)

(* ################################################################# *)
(** * Pre/postconditions *)

(** Remark. Some material in this section and the next section is from <<
Software Foundation >> volume 2. *)

(** Next, we need a way of making formal claims about the behavior of commands.

In general, the behavior of a command is to transform one state to another, so
it is natural to express claims about commands in terms of assertions that are
true before and after the command executes:

      - "If command [c] is started in a state satisfying assertion
        [P], and if [c] eventually terminates in some final state,
        then this final state will satisfy the assertion [Q]."

Such a claim is called a _Hoare Triple_ (霍尔三元组).  The assertion [P] is
called the _precondition_ (前条件) of [c], while [Q] is the _postcondition_
(后条件).  *)

(** This kind of claims about programs are widely used as specifications.
Computer scientists use the following notation to represent it.

     {{ P }} c {{ Q }}
*)

(* ################################################################# *)
(** * Hoare triples as program semantics *)

(** Till now, we have learnt to use pre/postconditions to make formal claims
about programs. In other words, given a pair of precondition and postcondition,
we get a program specification. *)

(** Now, we turn to the other side. We will use Hoare triples to describe
program behavior. Formally speaking, we will use Hoare triples to define the
program semantics of our simple imperative programming language (指令式编程语言).
*)

(** Remark 1. We have not yet describe how a program of [com] will execute! We
only have some intuition on it by the similarity between this simple language
and some other practical languages. Now we will do it formally for the first
time. *)

(** Remark 2. When we talk about "program specification", we say whether a
specific program satisfies a program specification or not. When we talk about
"program semantics", we say the program semantics of some programming language,
which defines the behavior of specific programs. *)

(* ================================================================= *)
(** ** Sequence *)

(** The following axiom defines the behavior of sequential compositions. *)

Axiom hoare_seq : forall (P Q R: Assertion) (c1 c2: com),
  {{P}} c1 {{Q}} ->
  {{Q}} c2 {{R}} ->
  {{P}} c1;;c2 {{R}}.

(** This axiom says, if the command [c1] takes any state where [P] holds to a
state where [Q] holds, and if [c2] takes any state where [Q] holds to one where
[R] holds, then doing [c1] followed by [c2] will take any state where [P] holds
to one where [R] holds.
*)

(** Remark. If we instantiate [P], [Q], [R] and [c1], [c2] with concrete
commands and assertions, this rule is only about the logical relation among
three concrete Hoare triples, or in other words, only describe how the behavior
of two concrete program [c1] and [c2] relates to their sequential combination.
But this rule is not about concrete programs and concrete assertions! It talks
about sequential combination in general. That's why we say that we are using
the relation among Hoare triples to define the semantics of this simple
programming language. *)

(* ================================================================= *)
(** ** Example: Swapping *)

(** We want to prove that the following program always swaps the values of
variables [X] and [Y]. Or, formally, for any [x] and [y],

       {{ {[X]} = x AND {[Y]} = y }}
       TEMP ::= X;;
       X ::= Y;;
       Y ::= TEMP
       {{ {[X]} = y AND {[Y]} = x }}.

First, the following three triples are obviously true.

    1. {{ {[X]} = x AND {[Y]} = y }}
       TEMP ::= X
       {{ {[Y]} = y AND {[TEMP]} = x }}

    2. {{ {[Y]} = y AND {[TEMP]} = x }}
       X ::= Y
       {{ {[X]} = y AND {[TEMP]} = x }}

    3. {{ {[X]} = y AND {[TEMP]} = x }}
       Y ::= TEMP
       {{ {[X]} = y AND {[Y]} = x }}.

Then, from 2 and 3, we know:

    4. {{ {[Y]} = y AND {[TEMP]} = x }}
       X ::= Y;;
       Y ::= TEMP
       {{ {[X]} = y AND {[Y]} = x }}.

In the end, from 1 and 4:

    5. {{ {[X]} = x AND {[Y]} = y }}
       TEMP ::= X;;
       X ::= Y;;
       Y ::= TEMP
       {{ {[X]} = y AND {[Y]} = x }}.
*)

(* ================================================================= *)
(** ** Example: Swapping Using Addition and Subtraction *)

(** Here is a program that swaps the values of two variables using addition and
subtraction instead of by assigning to a temporary variable.

       X ::= X + Y;;
       Y ::= X - Y;;
       X ::= X - Y

Again, we can prove it correct by three triples for assignments and [hoare_seq].
*)

(**

    1. {{ {[X]} = x AND {[Y]} == y }}
       X ::= X + Y
       {{ {[X]} = x + y AND {[Y]} = y }}

    2. {{ {[X]} = x + y AND {[Y]} = y }}
       Y ::= X - Y
       {{ {[X]} = x + y AND {[Y]} = x }}

    3. {{ {[X]} = x + y AND {[Y]} = x }}
       X ::= X - Y
       {{ {[X]} = y AND {[Y]} = x }}.
*)

(* ================================================================= *)
(** ** Skip *)

(** Since [Skip] doesn't change the state, it preserves any assertion [P]. *)

Axiom hoare_skip : forall P,
  {{P}} Skip {{P}}.

(* ================================================================= *)
(** ** Condition *)

(** What sort of rule do we want for describing the behavior of if-commands?

Certainly, if the same assertion [Q] holds after executing either of the
branches, then it holds after the whole conditional. So we might be tempted to
write: *)

Axiom hoare_if_first_try : forall P Q b c1 c2,
  {{P}} c1 {{Q}} ->
  {{P}} c2 {{Q}} ->
  {{P}} If b Then c1 Else c2 EndIf {{Q}}.

(** But we can say something more precise. In the "then" branch, we know that
the boolean expression [b] evaluates to [true], and in the "else" branch, we
know it evaluates to [false]. Making this information available in the premises
of the rule forms a more complete definition of program semantics. Here is the
Coq formalization: *)

Axiom hoare_if : forall P Q b c1 c2,
  {{ P AND {[b]} }} c1 {{ Q }} ->
  {{ P AND NOT {[b]} }} c2 {{ Q }} ->
  {{ P }} If b Then c1 Else c2 EndIf {{ Q }}.

(* Thu Mar 5 01:20:37 CST 2020 *)


(* http://adam.chlipala.net/cpdt/html/Subset.html *)

From mathcomp Require Import all_ssreflect.
Print Nat.pred.

Lemma zgtz: 0 > 0 -> False.
Proof. done. Qed.

Definition pred_strong1 {n: nat}: n > 0 -> nat :=
  match n with
  | O => fun (pf: 0 > 0) => match zgtz pf with end
  | S n' => fun _ => n'
  end.

Lemma two_gt0: 2 > 0.
Proof. done. Qed.

Eval compute in pred_strong1 two_gt0.

Print sig.
Locate "{ _ : _ | _ }".

Definition pred_strong2 (s: {n: nat | n > 0}): nat :=
  match s with
  | exist O pf => match zgtz pf with end
  | exist (S n') _ => n'
  end.
Eval compute in pred_strong2 (exist _ 2 two_gt0).


Require Import Iron.Language.SystemF2Data.Type.

(* Literal values. *)
Inductive lit : Type :=
 (* Literal natural number. *)
 | LNat   : nat  -> lit

 (* Literal boolean. *)
 | LBool  : bool -> lit.

Fixpoint typeOfLit (l : lit) : ty :=
 match l with
 | LNat  _   => TCon TyConNat
 | LBool _   => TCon TyConBool
 end.


(**
 * This is a simplistic Hoare logic verifier for Java programs.
 * There are a few simplifications.
 * Exceptions aren't modeled.
 * Floating point numbers aren't modeled.
 * *** Add stuff as I find it ***
 *)

Require Export SfLib.
Require Export Arith.
Require Export Arith.Div2.

(* In java, all integers are two's complement and signed *)
(* They are stored as a sequence of bits (ie. booleans) *)

(**
 * Promotion rules (Binary):
 * *** Floating point rules ***
 * Otherwise, if either operand is of type long, the other is converted to long.
 * Otherwise, both operands are converted to type int.
 *
 * Promotion rules (Binary):
 * *** Floating point rules ***
 * Otherwise, if the operand is of compile-time type byte, short, or char, it is promoted to a value of type int by a widening primitive conversion.
 * Otherwise, a unary numeric operand remains as is and is not converted.
 *)

Inductive jnum :=
| jend: bool -> jnum
| jbit: bool -> jnum -> jnum.

Definition jnum_promotion (n1 n2: nat): nat :=
  match (leb n1 n2), (leb n1 31), (leb n2 31) with
  | true, _, true => 31
  | true, _, false => n2
  | false, true, _ => 31
  | false, false, _ => n1
  end.

(* Treat the java number as unsigned and convert it into a natural number *)
Fixpoint jnum_width (n: jnum): nat :=
  match n with
  | jend _ => 0
  | jbit _ n' => 1 + jnum_width n'
  end.

Fixpoint jnum_to_nat (n: jnum): nat :=
  match n with
  | jend false => 0
  | jend true => 1
  | jbit false n' => 2 * jnum_to_nat n'
  | jbit true n' => 1 + 2 * jnum_to_nat n'
  end.

Fixpoint oddb (n: nat): bool :=
  match n with
  | O => false
  | S O => true
  | S (S n') => oddb n'
  end.

Theorem oddb_false: forall n,
  oddb (2 * n) = false.
Proof.
  simpl.
  induction n.
    reflexivity.

    simpl. rewrite <- plus_n_Sm. assumption.
  Qed.

Theorem oddb_true: forall n,
  oddb (1 + 2 * n) = true.
Proof.
  simpl.
  induction n.
    reflexivity.

    simpl. rewrite <- plus_n_Sm. assumption.
  Qed.

Fixpoint nat_to_jnum (n width: nat): jnum :=
  match width with
  | O => jend (oddb n)
  | S width' => jbit (oddb n) (nat_to_jnum (div2 n) width')
  end.

Theorem jconversion_reflexive: forall jn,
  nat_to_jnum (jnum_to_nat jn) (jnum_width jn) = jn.
Proof.
  intros jn.
  induction jn.
    simpl.
    destruct b; reflexivity.

    simpl. rewrite plus_0_r.
    assert(jnum_to_nat jn + jnum_to_nat jn = 2 * jnum_to_nat jn). simpl. rewrite plus_0_r. trivial.
    rewrite H.

    destruct b.
      rewrite oddb_true. rewrite div2_double_plus_one. rewrite IHjn. trivial.

      rewrite oddb_false. rewrite div2_double. rewrite IHjn. trivial.
  Qed.

Fixpoint jnum_is_neg (n: jnum): bool :=
  match n with
  | jend b => b
  | jbit _ n' => jnum_is_neg n'
  end.

Fixpoint jnum_promote (jn: jnum) (n: nat): jnum :=
  match n with
  | O =>
    match jn with
    | jend b => jend b
    | jbit b jn' => jend b
    end
  | S n' =>
    match jn with
    | jend b => jbit b (jnum_promote jn n')
    | jbit b jn' => jbit b (jnum_promote jn' n')
    end
  end.

Fixpoint jnum_zero (n: nat): jnum :=
  match n with
  | O => jend false
  | S n' => jbit false (jnum_zero n')
  end.

Fixpoint jnum_one (n: nat): jnum :=
  match n with
  | O => jend true
  | S n' => jbit true (jnum_zero n')
  end.

Fixpoint jnum_append (n1 n2: jnum): jnum :=
  match n1 with
  | jend b => jbit b n2
  | jbit b n1' => jbit b (jnum_append n1' n2)
  end.

Fixpoint jnum_negb (n: jnum): jnum :=
  match n with
  | jend b => jend (negb b)
  | jbit b n' => jbit (negb b) (jnum_negb n')
  end.

Fixpoint jnum_orb (n1 n2: jnum): jnum :=
  match n1, n2 with
  | jbit b1 n1', jbit b2 n2' => jbit (orb b1 b2) (jnum_orb n1' n2')
  | jbit b1 n1', jend b2 => jbit (orb b1 b2) (jnum_orb n1' n2)
  | jend b1, _ => if b1
                  then jnum_one (jnum_width n2)
                  else n2
  end.

Fixpoint jnum_andb (n1 n2: jnum): jnum :=
  match n1, n2 with
  | jbit b1 n1', jbit b2 n2' => jbit (orb b1 b2) (jnum_orb n1' n2')
  | jbit b1 n1', jend b2 => jbit (orb b1 b2) (jnum_orb n1' n2)
  | jend b1, _ => if b1
                  then n2
                  else jnum_zero (jnum_width n2)
  end.

Fixpoint jnum_xorb (n1 n2: jnum): jnum :=
  match n1, n2 with
  | jbit b1 n1', jbit b2 n2' => jbit (xorb b1 b2) (jnum_orb n1' n2')
  | jbit b1 n1', jend b2 => jbit (xorb b1 b2) (jnum_orb n1' n2)
  | jend b1, _ => if b1
                  then jnum_negb n2
                  else n2
  end.

Definition bool_sum (b1 b2 b3: bool): bool :=
  match b1, b2, b3 with
  | true, true, true => true
  | false, false, true => true
  | false, true, false => true
  | true, false, false => true
  | _, _, _ => false
  end.

Definition bool_sum_carry (b1 b2 b3: bool): bool :=
  match b1, b2, b3 with
  | true, true, true => true
  | true, true, _ => true
  | true, _, true => true
  | _, true, true => true
  | _, _, _ => false
  end.

Fixpoint jnum_plus0_fix (n: jnum) (c: bool): jnum :=
  if c
  then
    match n with
    | jbit b n' => jbit (negb b) (jnum_plus0_fix n' b)
    | jend b => jbit (negb b) (jend b)
    end
  (* Nothing to change, short circuit *)
  else n.

Theorem jnum_plus0_correct: forall n c,
  jnum_to_nat (jnum_plus0_fix n c) = jnum_to_nat (jend c) + jnum_to_nat n.
Proof.
  intros n.
  induction n.
    simpl. destruct b; destruct c; reflexivity.

    simpl. destruct b; destruct c; simpl; try rewrite IHn; simpl;
    repeat rewrite <- plus_n_Sm; reflexivity.
  Qed.

Fixpoint jnum_plus_uns (n1 n2: jnum) (c: bool): jnum :=
  match n1, n2 with
  | jbit b1 n1', jbit b2 n2' => jbit (bool_sum b1 b2 c) (jnum_plus_uns n1' n2' (bool_sum_carry b1 b2 c))
  | jbit b1 n1', jend b2 => jbit (bool_sum b1 b2 c) (jnum_plus0_fix n1' (bool_sum_carry b1 b2 c))
  | jend b1, jbit b2 n2' => jbit (bool_sum b1 b2 c) (jnum_plus0_fix n2' (bool_sum_carry b1 b2 c))
  | jend b1, jend b2 => jbit (bool_sum b1 b2 c) (jend (bool_sum_carry b1 b2 c))
  end.

Theorem jnum_plus_correct: forall n1 n2 c,
  jnum_to_nat (jnum_plus_uns n1 n2 c) =
  jnum_to_nat (jend c) + jnum_to_nat n1 + jnum_to_nat n2.
Proof.
  intros n1.
  induction n1.
    induction n2.
      simpl. destruct b; destruct b0; destruct c; reflexivity.

      simpl. destruct b; destruct b0; destruct c; simpl; rewrite jnum_plus0_correct;
      simpl; repeat rewrite <- plus_n_Sm; reflexivity.

    induction n2.
      simpl. destruct b; destruct b0; destruct c; simpl; rewrite jnum_plus0_correct;
      simpl; repeat rewrite <- plus_n_Sm; repeat rewrite plus_0_r; reflexivity.

      assert (jnum_to_nat n2 + (jnum_to_nat n1 + jnum_to_nat n2) = jnum_to_nat n1 + (jnum_to_nat n2 + jnum_to_nat n2)).
        repeat rewrite plus_assoc. rewrite (plus_comm (jnum_to_nat n1) (jnum_to_nat n2)). trivial.
      simpl. destruct b; destruct b0; destruct c; simpl;
        rewrite IHn1; simpl; repeat rewrite plus_0_r; repeat rewrite <- plus_n_Sm;
        repeat rewrite <- plus_assoc; try rewrite H; trivial.
  Qed.

Definition jnum_plus (n1 n2: jnum): jnum :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    jnum_promote (jnum_plus_uns (jnum_promote n1 n) (jnum_promote n2 n) false) n.

(* ~n + 1 *)
Definition jnum_neg_uns (n: jnum): jnum :=
  jnum_plus0_fix (jnum_negb n) true.

Definition jnum_neg (jn: jnum): jnum :=
  let n := jnum_promotion (jnum_width jn) 0 in
    jnum_promote (jnum_neg_uns (jnum_promote jn n)) n.

Definition jnum_sub_uns (n1 n2: jnum) (c: bool): jnum :=
  jnum_plus_uns n1 (jnum_neg_uns n2) c.

Definition jnum_sub (n1 n2: jnum): jnum :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    jnum_promote (jnum_sub_uns (jnum_promote n1 n) (jnum_promote n2 n) false) n.

(**
 * sum = 0
 * if (n1 & 1) {
 *   sum += n2
 * }
 * if (n1 & 2) {
 *   sum += n2 << 1
 * }
 * if (n1 & 4) {
 *   sum += n2 << 2
 * }
 * ...
 *)
Fixpoint jnum_mult_uns (n1 n2: jnum): jnum :=
  match n1 with
  | jbit b1 n1' => if b1
                   then jnum_plus_uns (jbit false (jnum_mult_uns n1' n2)) n2 false
                   else jbit false (jnum_mult_uns n1' n2)
  | jend b1     => if b1
                   then n2
                   else jend false
  end.

Compute jnum_to_nat (jnum_mult_uns (nat_to_jnum 3 1) (nat_to_jnum 3 1)).

Theorem jnum_mult_correct: forall n1 n2,
  jnum_to_nat (jnum_mult_uns n1 n2) = (jnum_to_nat n1) * (jnum_to_nat n2).
Proof.
  intros n1.
  induction n1.
    intros n2.
    induction n2;
      destruct b; destruct b0;
        simpl; repeat rewrite plus_0_r; trivial.

    intros n2.
    induction n2.
      simpl. destruct b; destruct b0; simpl; try rewrite jnum_plus0_correct;
      simpl; rewrite IHn1; simpl; repeat rewrite plus_0_r; repeat rewrite mult_1_r;
      repeat rewrite mult_0_r; trivial.

      simpl. destruct b; destruct b0; simpl; repeat rewrite plus_0_r;
      try rewrite jnum_plus_correct; simpl; rewrite IHn1; simpl; repeat rewrite plus_0_r;
      repeat rewrite <- mult_n_Sm; repeat rewrite mult_plus_distr_l;
      repeat rewrite mult_plus_distr_r; omega.
  Qed.

Definition jnum_mult (n1 n2: jnum): jnum :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    jnum_promote (jnum_mult_uns (jnum_promote n1 n) (jnum_promote n2 n)) n.

Fixpoint jnum_is_zero (n: jnum): bool :=
  match n with
  | jbit b n' => if b then false else jnum_is_zero n'
  | jend b => negb b
  end.

Theorem jnum_is_zero_correct: forall n,
  jnum_is_zero (nat_to_jnum 0 n) = true.
Proof.
  induction n.
    reflexivity.

    simpl. assumption.
  Qed.

Theorem jnum_is_zero_correct2: forall n,
  jnum_to_nat n = 0 ->
  jnum_is_zero n = true.
Proof.
  induction n.
    simpl. intros H. destruct b. inversion H. reflexivity.

    simpl. intros H. destruct b. inversion H.
      apply IHn. destruct (jnum_to_nat n).
        reflexivity.

        inversion H.
  Qed.

Theorem jnum_zero_implies: forall n,
  jnum_is_zero n = true ->
  jnum_to_nat n = 0.
Proof.
  induction n.
    simpl. intros H. destruct b. inversion H. reflexivity.

    simpl. intros H. destruct b. inversion H.
      rewrite IHn.
        reflexivity.

        assumption.
  Qed.

Fixpoint jnum_eq_uns (n1 n2: jnum): bool :=
  match n1, n2 with
  | jbit b1 n1', jbit b2 n2' => if xorb b1 b2 then false else jnum_eq_uns n1' n2'
  | jend b1, jend b2 => if xorb b1 b2 then false else true
  | jbit b1 n1', jend b2 => if xorb b1 b2 then false else jnum_is_zero n1'
  | jend b1, jbit b2 n2' => if xorb b1 b2 then false else jnum_is_zero n2'
  end.

Definition jnum_eq (n1 n2: jnum): bool :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    jnum_eq_uns (jnum_promote n1 n) (jnum_promote n2 n).

Fixpoint jnum_leq_uns (n1 n2: jnum): bool :=
  match n1, n2 with
  | jbit b1 n1', jbit b2 n2' => if jnum_eq_uns n1' n2' then orb b2 (negb b1) else jnum_leq_uns n1' n2'
  | jend b1, jend b2 => orb b2 (negb b1)
  | jbit b1 n1', jend b2 => if jnum_is_zero n1' then orb b2 (negb b1) else false
  | jend b1, jbit b2 n2' => if jnum_is_zero n2' then orb b2 (negb b1) else true
  end.

Definition jnum_leq (n1 n2: jnum): bool :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    match jnum_is_neg n1, jnum_is_neg n2 with
    | true, false => false
    | false, true => true
    | _, _ => jnum_leq_uns (jnum_promote n1 n) (jnum_promote n2 n)
    end.

Require Export Bool.

Theorem jnum_eq_correct: forall n1 n2,
  jnum_to_nat n1 = jnum_to_nat n2 ->
  jnum_eq_uns n1 n2 = true.
Proof.
  induction n1; induction n2.
    destruct b; destruct b0; simpl; intros H; inversion H; reflexivity.

    destruct b; destruct b0; simpl; repeat rewrite plus_0_r;
    repeat rewrite <- plus_n_Sm; intros H; inversion H; simpl in IHn2.
      destruct (jnum_to_nat n2) eqn:Hn2; repeat rewrite <- plus_n_Sm in H; inversion H.
      apply jnum_is_zero_correct2. assumption.

      destruct (jnum_to_nat n2); repeat rewrite <- plus_n_Sm in H; inversion H.

      destruct (jnum_to_nat n2) eqn:Hn2; repeat rewrite <- plus_n_Sm in H; inversion H.
      apply jnum_is_zero_correct2. assumption.

    destruct b; destruct b0; simpl; repeat rewrite plus_0_r;
    repeat rewrite <- plus_n_Sm; intros H; inversion H; simpl in IHn1.
      destruct (jnum_to_nat n1) eqn:Hn1; repeat rewrite <- plus_n_Sm in H; inversion H.
      apply jnum_is_zero_correct2. assumption.

      destruct (jnum_to_nat n1); repeat rewrite <- plus_n_Sm in H; inversion H.

      destruct (jnum_to_nat n1) eqn:Hn1; repeat rewrite <- plus_n_Sm in H; inversion H.
      apply jnum_is_zero_correct2. assumption.

    destruct b; destruct b0; simpl; repeat rewrite plus_0_r;
    repeat rewrite <- plus_n_Sm; intros H; inversion H; simpl in IHn1.
      apply IHn1. destruct (jnum_to_nat n1); destruct (jnum_to_nat n2); inversion H1.
        reflexivity.

        omega. (* Magic *)

      omega.

      omega.

      apply IHn1. omega.
  Qed.

Fixpoint jnum_mod_uns (n1 n2: jnum): jnum :=
  match n1 with
  (* 0 % 1 = 0, 1 % 1 = 0, 0 % ...1 = 0, 1 % ...1 = 1 *)
  | jend b1 => if jnum_leq_uns n2 n1 then jend false else jend b1
  | jbit b1 n1' => let n := jbit b1 (jnum_mod_uns n1' n2) in
                     if jnum_leq_uns n2 n
                     then jnum_promote (jnum_sub_uns n n2 false) (jnum_width n2)
                     else n
  end.

Definition jnum_mod (n1 n2: jnum): jnum :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    jnum_promote (jnum_mod_uns (jnum_promote n1 n) (jnum_promote n2 n)) n.

Fixpoint jnum_div_uns (n1 n2: jnum): jnum :=
  match n1 with
  | jend b1 => if jnum_leq_uns n2 n1 then jend true else jend false
  | jbit b1 n1' => let n := jnum_div_uns n1' n2 in
                     let n' := jnum_promote (jbit b1 (jnum_sub_uns n1' (jnum_mult_uns n2 n) false)) (jnum_width n2) in
                       if jnum_leq_uns n2 n' then jbit true n else jbit false n
  end.

Definition jnum_div (n1 n2: jnum): jnum :=
  let n := jnum_promotion (jnum_width n1) (jnum_width n2) in
    jnum_promote (jnum_div_uns (jnum_promote n1 n) (jnum_promote n2 n)) n.

Compute jnum_mod_uns (nat_to_jnum 41 16) (nat_to_jnum 7 16).
Compute jnum_div_uns (nat_to_jnum 41 16) (nat_to_jnum 7 16).
Compute jnum_to_nat (jnum_div_uns (nat_to_jnum 289 16) (nat_to_jnum 17 16)).

(*Theorem jnum_div_correct: forall n1 n2,
  jnum_to_nat n2 <> 0 ->
  jnum_to_nat (jnum_plus_uns (jnum_mult_uns (jnum_div_uns n1 n2) n2) (jnum_mod_uns n1 n2) false) = jnum_to_nat n1.
Proof.
  intros n1.
  induction n1.
    intros n2.
    rewrite jnum_plus_correct. simpl. rewrite jnum_mult_correct. simpl.
    induction n2.
      simpl. destruct b; destruct b0; simpl; try reflexivity.
        intros H; apply ex_falso_quodlibet; apply H; reflexivity.

      simpl. destruct b; destruct b0; simpl;
      destruct (jnum_is_zero n2) eqn:Hn2; simpl; repeat rewrite plus_0_r;
      try trivial.
        rewrite jnum_zero_implies.
          reflexivity.

          assumption.

        rewrite jnum_zero_implies.
          intros H. apply ex_falso_quodlibet; apply H; reflexivity.

          assumption.

        rewrite jnum_zero_implies.
          intros H. apply ex_falso_quodlibet; apply H; reflexivity.

          assumption.

    intros n2.
    rewrite jnum_plus_correct. simpl. rewrite jnum_mult_correct. simpl.
    induction n2.
      destruct b0; try (intros H; apply ex_falso_quodlibet; apply H; reflexivity).
      simpl. destruct b; simpl.

    admit.
  Qed.*)

Definition jnum_256 := nat_to_jnum 256 31.
Definition jnum_65536 := jnum_mult jnum_256 jnum_256.
Definition jnum_2_32 := jnum_mult jnum_65536 jnum_65536.

Compute jnum_to_nat jnum_2_32.
Compute jnum_mod_uns jnum_256 jnum_65536.
Compute jnum_div_uns jnum_65536 jnum_256.

Fixpoint jnum_shl_fix (n1: jnum) (n2: nat): jnum :=
  match n2 with
  | O => n1
  | S n2' => jbit false (jnum_shl_fix n1 n2')
  end.

Fixpoint jnum_shr_fix (n1: jnum) (n2: nat): jnum :=
  match n2 with
  | O => n1
  | S n2' =>
    match n1 with
    | jend _ => jend false
    | jbit _ n1' => jnum_shr_fix n1' n2'
    end
  end.


(* Universe hierarchy *)

Check Type.

Set Printing Universes.

Check Type.

Universes i j.

Fail Constraint i < Set.
Fail Constraint i = Set.

Constraint i < j.

Check Type@{i} : Type@{j}.

Fail Check Type@{j} : Type@{i}.

Check Type@{i} -> Type@{i}.

Check ((forall (P : Prop), nat -> P) : Prop).
(*
Parameter (A : Type@{i}).
Parameter (B: A -> Type@{i}).

Check ((forall (x:A), B x) ).
Check (Type@{i} -> Type@{i}).
 *)

Check(Type@{i}).
Check ((forall (A : Type), A -> False) : Prop).

Fail Check ((forall (A : Type), A -> Empty_set) : Set).
Universes k l.

Check ((forall (A : Type@{k}), A -> Empty_set) : Type@{l}).

(** Type eliminations *)

Section TypeElim.
  Variable b : bool.

  Check (match b return Type with
         | true => nat
         | false => bool
         end).

  Check (match b return Prop with
         | true => True
         | false => False
         end).

  Check (match b return (nat : Set) with
         | true => 0
         | false => 1
         end).

End TypeElim.

(** Prop eliminations *)
Section PropElim.
  Variable P : Prop.
  Variable b : or P P.

  Fail Check (match b return Type with
              | or_introl _ => nat
              | or_intror _ => bool
              end).

  Fail Check (match b return Prop with
         | or_introl _ => P
         | or_intror _ => P
         end).

  Fail Check (match b return (nat : Set) with
         | or_introl _ => 0
         | or_intror _ => 1
         end).

  Check (match b return P with
         | or_introl p => p
         | or_intror p => p
         end).

End PropElim.

Section PropSingleton.
  Variable b : (True : Prop).

  Check (match b return Type with
              | I => nat
              end).

  Check (match b return Prop with
         | I => False
         end).

  Check (match b return (nat : Set) with
         | I => 0
         end).

  Check (match b return True with
         | I => I
         end).

End PropSingleton.

Section PropSingletonEq.
  Variables (A : Type) (x y : A).
  Variable b : (@eq A x y : Prop).

  Check (match b return Type with
              | eq_refl => nat
              end).

  Variable (P : A -> Type).

  Check (match b in eq _ y return P y -> P x with
         | eq_refl => fun x : P x => x
         end).

End PropSingletonEq.

Section PropExElim.
  Variables (A : Type) (P : A -> Prop).
  (* [exist x : A, P x] is a notation for [ex A P]
     where:

     Inductive ex (A : Type) (P : A -> Prop) : Prop :=
       ex_intro : forall x : A, P x -> exists y, P y
  *)
  Fail Definition project (e : exists x : A, P x) : A :=
    match e return A with
    | ex_intro _ witness proof => witness
    end.

  (* [{ x : A | P x} is a notation for [sig A P] where:

  Inductive sig (A : Type) (P : A -> Prop) : Type :=
	exist : forall x : A, P x -> {x : A | P x}
  *)
  Definition project (e' : { x : A | P x }) : A :=
   match e' return A with
      | exist _ witness proof => witness
   end.
End PropExElim.

Require Import Arith.

Inductive collatz : nat -> Set :=
| collatz_terminates : collatz 1
| collatz_0 n : n mod 2 = 0 -> collatz (n / 2) -> collatz n
| collatz_1 n : n mod 2 = 1 -> collatz (3 * n + 1) -> collatz n.

Fixpoint collatz_steps {n : nat} (c : collatz n) : nat :=
  match c with
  | collatz_terminates => 0
  | collatz_0 n _ c => S (collatz_steps c)
  | collatz_1 n _ c => S (collatz_steps c)
  end.

Inductive squash (A : Type) : Prop :=
| sq : A -> squash A.

Axiom collatz_conjecture: forall n, squash (collatz n).

(** Elimination restrictions ensure "irrealizable" axioms in [Prop] do not endanger the
    computations in Type. E.g. we cannot get "non-standard" numbers.
*)

Fail Definition collatz_steps_of (n : nat) : nat :=
  match collatz_conjecture n with
  | sq _ collatzn => collatz_steps collatzn
  end.


(* -----------------Description------------------------------------------

This file is about Individual Rational (IR) matchings. It contains a
function to convert any matching to an IR matching, it also contains
existensial results of IR matching. The file contains a function produce_IR, which converts any matching M into a Individual Rational matching.

Some important results:

Theorem exists_IR_matching : matching_in B A M ->
(exists M': list fill_type, bids_of M = bids_of M' /\ asks_of M = asks_of M'
/\ matching_in B A M' /\ Is_IR M').

*)

Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.

Require Export BidAsk.
Require Export DecList.
Require Export Matching.

Section IndRat.

(* ----------------- There exists an Individual Rational Matching------------------------ *)

Fixpoint produce_IR (M:list fill_type):(list fill_type):=
  match M with
  |nil => nil
  |m::M' => (Mk_fill (bid_of m) (ask_of m) (sp (ask_of m)))::(produce_IR M')
  end.
(*Change it to mid-price of the bid-ask price rather than ask price *)

Lemma fst_same_IR (M: list fill_type) :
  forall m', In m' (produce_IR M) -> exists m, In m M /\ (bid_of m = bid_of m') /\ (ask_of m = ask_of m').
Proof. { intros m' H. induction M. simpl in H. contradiction.
         simpl in H.  destruct H. exists a. split. auto.
         subst m'. simpl;auto. auto.
         assert (H1:  exists m : fill_type, In m M /\ (bid_of m = bid_of m') /\
                                       (ask_of m = ask_of m')); auto.
         destruct H1 as [m H1]. destruct H1.  exists m. split; eauto. } Qed.

Lemma same_bids (M:list fill_type):
  (bids_of M) = (bids_of (produce_IR M)).
Proof. { induction M. simpl. auto. simpl. rewrite IHM. auto. } Qed.

Lemma same_asks (M:list fill_type):
  (asks_of M) = (asks_of (produce_IR M)).
Proof. { induction  M. simpl. auto. simpl. rewrite IHM. auto. } Qed.

Lemma produce_IR_is_matching (M: list fill_type) (B: list Bid) (A: list Ask):
  matching_in B A M-> (matching_in B A (produce_IR M)).
Proof. { intro H0. unfold matching_in. unfold matching.
          unfold All_matchable.   split. split.
           { intros m' H1.
           assert (H2: exists m, (In m M) /\ ((bid_of m = bid_of m') /\
           (ask_of m = ask_of m'))). apply fst_same_IR. auto.
            destruct H2 as [m H2]. destruct H2 as [H2 H3].
            destruct H3 as [H3 H4]. rewrite <- H3. rewrite <- H4.
            apply H0. auto. }
        { replace (bids_of (produce_IR M)) with (bids_of M).
          replace (asks_of (produce_IR M)) with (asks_of M). apply H0.
          apply same_asks. apply same_bids. }
           { replace (bids_of (produce_IR M)) with (bids_of M).
          replace (asks_of (produce_IR M)) with (asks_of M). apply H0.
          apply same_asks. apply same_bids. }
          } Qed.

Lemma produce_IR_trade_ask_same (M:list fill_type):
  forall m: fill_type, In m (produce_IR M) -> sp (ask_of m)=(tp m).
Proof. {  intros m H0. induction M. simpl in H0. contradiction.
           simpl in H0. destruct H0. subst m. simpl. unfold ask_of. simpl. auto. auto. } Qed.

Lemma produce_IR_is_IR (M: list fill_type) (B: list Bid) (A: list Ask):
 matching_in B A M-> Is_IR (produce_IR M).

Proof. { intro H0. unfold Is_IR. intro m'. intro H.
         unfold rational. replace (tp m') with (sp (ask_of m')). 2:{
         apply produce_IR_trade_ask_same with (M:=M). auto. } split. 2:{ auto. }
         assert (H1: exists m, In m M /\ (bid_of m = bid_of m') /\ (ask_of m = ask_of m')).
         apply fst_same_IR;auto.
         destruct H1 as [m H1]. destruct H1 as [H1 H2].
         destruct H2 as [H2 H3]. rewrite <- H2. rewrite <-H3. destruct H0 as [H0 H4].
         unfold matching in H0. destruct H0 as [H0 H5].
         unfold All_matchable in H0. apply H0.
         exact. } Qed.

Theorem exists_IR_matching (M: list fill_type) (B: list Bid) (A:list Ask):
  matching_in B A M -> (exists M': list fill_type, bids_of M = bids_of M' /\ asks_of M = asks_of M'
                                               /\ matching_in B A M' /\ Is_IR M').
Proof. { intros  H.   exists (produce_IR M). split. apply same_bids. split. apply same_asks.
         split. apply produce_IR_is_matching. auto. eapply produce_IR_is_IR. eauto. } Qed.

End IndRat.


Require Import DirectedGraphs Ascii ExtrOcamlString.
Require Import MSets MSetFacts PArith DirectedGraphs_morph.

Module myGraph <: DirectedGraphs.

  Require Import MSetRBT.
  Require Import ZArith.
  Module pos :=  PositiveOrderedTypeBits.

  Module Vertices := MSetRBT.Make pos.
  Definition node := pos.t.
  Module Edge := PairOrderedType pos pos.
  Module Edges := MSetRBT.Make Edge.

  Module vert_facts := WFacts (Vertices).
  Module edge_facts := WFacts (Edges).
  Module vert_prop := WProperties (Vertices).
  Module edge_prop := WProperties (Edges).

  Definition edge := Edges.elt.
  Definition v_set := Vertices.t.
  Definition e_set := Edges.t.

  Definition ok  (V : v_set) (E : e_set) : Prop :=
    forall (e : edge), Edges.In e E ->
                       (Vertices.In (fst e) V) /\ (Vertices.In (snd e) V).

  Record Graph :=
    mkgraph {
        graphVertices: v_set;
        graphEdges : e_set;
        graphOk : ok graphVertices graphEdges
      }.

  Notation vertex := Vertices.elt.

  Definition buildEdge (n n1 : vertex): Edges.elt :=
    (n,n1).

  Definition t := Graph.

  Open Scope positive_scope.

  Program Definition empty := mkgraph Vertices.empty Edges.empty _.
  Next Obligation.
    unfold ok.
    intros.
    inversion H.
  Qed.

  Definition buildPair : vertex -> vertex -> vertex * vertex :=
    fun x y => (x,y).

  Definition destructEdge : Edge.t -> (vertex * vertex) :=
    fun X : Edge.t => let (p, p0) := X in (p, p0).

  Definition isemptyP : v_set -> e_set -> Prop :=
    fun (x : v_set) (y : e_set) => Vertices.Empty x  /\ Edges.Empty y.

  Definition  IsEmpty : Graph -> Prop :=
    fun G : Graph =>
      Vertices.Empty (graphVertices G) /\ Edges.Empty (graphEdges G).

  Definition IsVertex : Vertices.elt -> Graph -> Prop :=
    fun (n : Vertices.elt) (G : Graph)  =>
      Vertices.In n (graphVertices G).

  Definition IsEdge : Edges.elt -> Graph -> Prop :=
    fun (e : Edges.elt) (G : Graph) =>
      Edges.In e (graphEdges G).

  Definition isEmpty : Graph -> bool :=
    fun (G : Graph) => andb (Vertices.is_empty (graphVertices G))
                            (Edges.is_empty (graphEdges G)).

  Definition isVertex : Vertices.elt -> Graph -> bool :=
    fun (v : Vertices.elt) (G : Graph)  =>
      Vertices.mem v (graphVertices G).

  Definition isEdge : Edges.elt -> Graph -> bool :=
    fun (e : Edges.elt) (G : Graph) =>
      Edges.mem e (graphEdges G).

  Lemma IsEmpty_reflect :
    forall G : Graph, reflect (IsEmpty G) (isEmpty G).
  Proof.
    intros.
    unfold IsEmpty.
    unfold isEmpty.
    destruct G.
    apply iff_reflect.
    rewrite <- Vertices.is_empty_spec.
    rewrite <- Edges.is_empty_spec.
    split; intros; try apply andb_true_iff; auto.
  Qed.

  Lemma IsVertex_reflect :
    forall (G : Graph) (v : node),
      reflect (IsVertex v G) (isVertex v G).
  Proof.
    intros.
    destruct G.
    simpl.
    apply iff_reflect.
    split; intros; try apply Vertices.mem_spec; auto.
  Qed.

  Lemma IsEdge_reflect :
    forall (G : Graph) (e : Edges.elt), reflect (IsEdge e G) (isEdge e G).
  Proof.
    intros.
    destruct G.
    apply iff_reflect.
    unfold IsEdge, isEdge.
    split; try apply Edges.mem_spec; auto.
  Qed.

  Definition enumVertices : Graph -> Vertices.t :=
    fun (g : Graph) => graphVertices g.

  Definition enumEdges : Graph -> Edges.t :=
    fun (G : Graph) => (graphEdges G).

  Lemma Empty : IsEmpty empty.
  Proof.
    unfold empty.
    unfold IsEmpty.
    split.
    apply Vertices.empty_spec.
    apply Edges.empty_spec.
  Qed.

  Lemma Empty_vertices :
    forall G : Graph, IsEmpty G -> Vertices.Empty (enumVertices G).
  Proof.
    intros.
    destruct G.
    simpl in *.
    destruct H.
    auto.
  Qed.

  Lemma Empty_edges :
    forall G : t, IsEmpty G -> Edges.Empty (enumEdges G).
  Proof.
    intros [V E] H. simpl in *; destruct H.
    auto.
  Qed.

  Lemma IsVertexEnum :
    forall (G : t) (v : Vertices.elt),
      IsVertex v G <-> Vertices.In v (enumVertices G).
  Proof.
    intros [V E] v; split; simpl; intros; auto.
  Qed.

  Lemma IsEdgeEnum :
    forall (G : t) (e : Edges.elt), IsEdge e G <-> Edges.In e (enumEdges G).
  Proof.
    intros [V E] v; split; simpl; intros; auto.
  Qed.

  Lemma Edge_exists1 :
    forall (G : t) (e : Edges.elt),
      IsEdge e G -> IsVertex (fst (destructEdge e)) G.
  Proof.
    intros G e H.
    unfold destructEdge.
    destruct G.
    unfold IsVertex.
    unfold IsEdge in H.
    simpl in *.
    specialize (graphOk0 e H).
    destruct e.
    apply graphOk0.
  Qed.

  Lemma Edge_exists2 :
    forall G e, IsEdge e G -> IsVertex (snd (destructEdge e)) G.
  Proof.
    intros.
    unfold destructEdge, IsVertex, IsEdge in *.
    destruct G.
    simpl in *.
    specialize (graphOk0 e H).
    destruct e.
    apply graphOk0.
  Qed.

  Program Definition addVertex  (v : vertex) (G : t) : t :=
    mkgraph (Vertices.add v (graphVertices G)) (graphEdges G) _.
  Next Obligation.
    destruct G.
    unfold ok in *.
    simpl.
    intros.
    specialize (graphOk0 e H).
    split;
      apply Vertices.add_spec;
      right;
      apply graphOk0.
  Qed.

  Lemma add_ok : forall e G,
      Vertices.In (fst e) (graphVertices G) ->
      Vertices.In (snd e) (graphVertices G) ->
      ok (graphVertices G) (Edges.add e (graphEdges G)).
  Proof.
    unfold ok.
    intros. apply Edges.add_spec in H1;
              destruct e; destruct e0;
                destruct H1.
    inversion H1;  inversion H2; inversion H3; simpl in *; auto.
    simpl.
    destruct G.
    simpl in *.
    specialize (graphOk0 _ H1).
    auto.
  Qed.

  Lemma Vertices_in_dec1 : forall (e : vertex*vertex) G,
      {Vertices.In (fst e) (graphVertices G)} +
      {~ Vertices.In (fst e) (graphVertices G)}.
  Proof.
    intros.
    case_eq (Vertices.mem (fst e) (graphVertices G));
      intros H.
    rewrite Vertices.mem_spec in H; left; auto.
    right; intros H1. rewrite <- Vertices.mem_spec in H1.
    rewrite H in H1. inversion H1.
  Qed.

  Lemma Vertices_in_dec2 : forall (e : vertex*vertex) G,
      {Vertices.In (snd e) (graphVertices G)} +
      {~ Vertices.In (snd e) (graphVertices G)}.
  Proof.
    intros.
    case_eq (Vertices.mem (snd e) (graphVertices G));
      intros H.
    rewrite Vertices.mem_spec in H; left; auto.
    right; intros H1. rewrite <- Vertices.mem_spec in H1.
    rewrite H in H1. inversion H1.
  Qed.

  Lemma Vertices_in_dec :
    forall (e : vertex*vertex) G,
      {Vertices.In (fst e) (graphVertices G) /\
       Vertices.In (snd e) (graphVertices G)} +
      {~ (Vertices.In (fst e) (graphVertices G) /\
          Vertices.In (snd e) (graphVertices G))}.
  Proof.
    intros.
    destruct (Vertices_in_dec1 e G);
      destruct (Vertices_in_dec2 e G);
      [left; auto | right | right | right]; intros H;
        destruct H; auto.
  Qed.

  Program Definition addEdge (e : edge) (G : t) : t :=
    if (Vertices_in_dec e G)
    then mkgraph (graphVertices G)
                 (Edges.add e (graphEdges G))
                 _
    else G.
  Next Obligation.
  Proof.
    apply add_ok; auto.
  Defined.

  Lemma annoyingProper : forall v,
      Proper (eq * eq ==> eq)
             (fun x : Edges.elt => negb (fst x =? v) && negb (snd x =? v)).
  Proof.
    unfold Proper.
    unfold respectful.
    intros v x y H.
    destruct H.
    rewrite H,H0.
    auto.
  Qed.

  Notation "V1 =V= V2" := (Vertices.eq V1 V2) (at level 60).
  Notation "V1 <V> V2" := (~ Vertices.eq V1 V2) (at level 60).
  Notation "E1 =E= E2" := (Edges.eq E1 E2) (at level 60).
  Notation "E1 <E> E2" := (~ Edges.eq E1 E2) (at level 60).
  Notation "v1 =v= v2" := (Vertices.E.eq v1 v2) (at level 60).
  Notation "v1 <v> v2" := (~ Vertices.E.eq v1 v2) (at level 60).
  Notation "e1 =e= e2" := (Edges.E.eq e1 e2) (at level 60).
  Notation "e1 <e> e2" := (~ Edges.E.eq e1 e2) (at level 60).

  Program Definition removeVertex  (v : vertex) (G : t) : t :=
    let newE := Edges.filter (fun x => (negb (Pos.eqb (fst x) v)) &&  negb (Pos.eqb (snd x)  v)) (graphEdges G) in
    mkgraph (Vertices.remove v (graphVertices G)) (newE) _.
  Next Obligation.
    intros e H.
    destruct G.
    simpl in *.
    unfold ok in graphOk0.
    apply Edges.filter_spec in H.
    destruct H.
    apply andb_true_iff in H0.
    destruct H0.
    rewrite negb_true_iff in H1,H0.
    rewrite Pos.eqb_neq in H0,H1.
    split;
      apply vert_prop.Dec.F.remove_2;
      auto;
      try apply graphOk0;
      auto.
    apply annoyingProper.
  Defined.

  Program Definition removeEdge  (e : edge) (G : t) : t :=
    mkgraph (graphVertices G) (Edges.remove e (graphEdges G)) _.
  Next Obligation.
    intros e1 H.
    destruct G.
    simpl in *.
    apply graphOk0.
    apply Edges.remove_spec in H.
    apply H.
  Defined.

  Lemma addVertex_spec1 :
    forall G v, IsVertex v (addVertex v G).
  Proof.
    intros [V G pf] v.
    unfold IsVertex.
    simpl.
    apply Vertices.add_spec.
    auto.
  Qed.

  Lemma addVertex_spec2 :
    forall G v1 v2, ~ Vertices.E.eq v1 v2 ->
                    IsVertex v1 G <-> IsVertex v1 (addVertex v2 G).
  Proof.
    intros [V E pf] v1 v2 H.
    unfold IsVertex.
    simpl.
    unfold not in H.
    split; intros; auto.
    apply Vertices.add_spec.
    auto.
    apply Vertices.add_spec in H0.
    destruct H0; auto.
    apply H in H0.
    destruct H0.
  Qed.

  Lemma addVertex_spec3 :
    forall G v e,
      IsEdge e G <-> IsEdge e (addVertex v G).
  Proof.
    intros [V E pf] v e.
    unfold IsEdge.
    simpl.
    split; intros; auto.
  Qed.

  Lemma addEdge_spec1 :
    forall G e,
      IsVertex (fst (destructEdge e)) G->
      IsVertex (snd (destructEdge e)) G->
      IsEdge e (addEdge e G).
  Proof.
    intros G e. unfold addEdge; intros.
    destruct (Vertices_in_dec e G).
    unfold IsEdge.
    simpl.
    apply Edges.add_spec.
    auto.
    unfold IsVertex in *.
    destruct e.
    unfold not in n.
    assert (False).
    apply n.
    auto.
    destruct H1.
  Qed.

  Lemma addEdge_spec2 :
    forall G e1 e2, e1 <e> e2 ->
                    IsEdge e1 G <-> IsEdge e1 (addEdge e2 G).
  Proof.
    intros.
    split; unfold addEdge; intros; unfold IsEdge; simpl.
    destruct (Vertices_in_dec e2 G).
    simpl.
    apply Edges.add_spec.
    auto.
    auto.
    unfold graphEdges.
    destruct G.
    simpl in *.
    destruct (Vertices_in_dec e2) in H0.
    simpl in *.
    unfold IsEdge in H0.
    simpl in H0.
    apply Edges.add_spec in H0.
    destruct H0; auto.
    unfold not in H.
    assert (False).
    apply H.
    auto. destruct H1.
    auto.
  Qed.

  Lemma addEdge_spec3 : forall G v e,
      IsVertex v G <-> IsVertex v  (addEdge e G).
  Proof.
    intros.
    split; unfold IsVertex, addEdge; intros.
    destruct (Vertices_in_dec e G).
    simpl.
    auto.
    auto.
    destruct (Vertices_in_dec e G) in H; auto.
  Qed.

  Lemma removeVertex_spec1 :
    forall G v, ~ IsVertex v (removeVertex v G).
  Proof.
    intros G v H.
    unfold IsVertex in H.
    simpl in H.
    apply Vertices.remove_spec in H.
    destruct H.
    unfold not in H0.
    auto.
  Qed.

  Lemma removeVertex_spec2 :
    forall G v1 v2, v1 <v> v2 ->
                    IsVertex v1 G <-> IsVertex v1 (removeVertex v2 G).
  Proof.
    intros G v1 v2 H.
    split;
      intros H0;
      unfold IsVertex in *;
      simpl in *;
      try apply vert_prop.Dec.F.remove_2;
      try apply vert_prop.Dec.F.remove_3 in H0;
      auto.
  Qed.

  Lemma removeVertex_spec3 :
    forall G v e,
      IsEdge e (removeVertex v G) <->
      IsEdge e G /\
      (fst (destructEdge e)) <v> v /\
      (snd (destructEdge e)) <v> v.
  Proof.
    intros G v e.
    unfold IsEdge.
    split; intros H.
    {
      split.
      unfold graphEdges in *.
      destruct G.
      simpl in *.
      apply Edges.filter_spec in H.
      apply H.
      apply annoyingProper.
      unfold destructEdge.
      destruct e.
      simpl.
      unfold removeVertex in H.
      simpl in H.
      apply Edges.filter_spec in H.
      destruct H.
      apply andb_true_iff in H0.
      destruct H0.
      simpl in *.
      rewrite negb_true_iff in H0,H1.
      rewrite Pos.eqb_neq in H0,H1.
      auto.
      apply annoyingProper.
    }
    {
      destruct H.
      destruct H0.
      destruct e.
      simpl in H,H0,H1.
      apply Edges.filter_spec.
      apply annoyingProper.
      split.
      auto.
      apply andb_true_iff.
      do 2 rewrite negb_true_iff.
      simpl.
      do 2  rewrite Pos.eqb_neq.
      auto.
    }
  Qed.

  Lemma my_neg_iff_prop : forall p p0 v,
      negb (fst (p, p0) =? v) && negb (snd (p, p0) =? v) = true ->
      fst (p, p0) <> v /\  snd (p, p0) <> v .
  Proof.
    intros.
    simpl in *.
    apply andb_true_iff in H.
    destruct H.
    rewrite negb_true_iff in H, H0.
    rewrite Pos.eqb_neq in H,H0.
    auto.
  Qed.

  Lemma  removeVertex_spec4 :
    forall G v e,
      IsEdge e G ->
      (fst (destructEdge e) =v= v) \/
      (snd (destructEdge e) =v= v) ->
      ~ IsEdge e (removeVertex v G).
    intros G v e H H0 Hnot.
    destruct e.
    simpl in *.
    destruct H0;
      unfold IsEdge in Hnot.
    apply Edges.filter_spec in Hnot.
    destruct Hnot.
    apply andb_true_iff in H2.
    do 2 rewrite negb_true_iff in H2.
    destruct H2.
    rewrite Pos.eqb_neq in H2,H3.
    auto.
    apply annoyingProper.
    apply Edges.filter_spec in Hnot.
    destruct Hnot.
    apply andb_true_iff in H2.
    do 2 rewrite negb_true_iff in H2.
    destruct H2.
    rewrite Pos.eqb_neq in H2,H3.
    auto.
    apply annoyingProper.
  Qed.

  Lemma removeEdge_spec1 :
    forall G e, ~ IsEdge e (removeEdge e G).
  Proof.
    intros G e Hnot.
    unfold IsEdge in Hnot.
    simpl in Hnot.
    apply edge_prop.Dec.F.remove_1 in Hnot.
    destruct Hnot.
    auto.
  Qed.

  Lemma removeEdge_spec2 :
    forall G e1 e2, e1 <e> e2 ->
                    IsEdge e1 G <-> IsEdge e1 (removeEdge e2 G).
  Proof.
    intros G e1 e2 H.
    unfold IsEdge.
    split; intros H0; auto.
    simpl.
    apply edge_prop.Dec.F.remove_2.
    intros Hnot.
    destruct Hnot.
    unfold not in H.
    apply H.
    constructor; auto.
    auto.
    unfold graphEdges in *.
    simpl in *.
    destruct G.
    simpl in *.
    apply Edges.remove_spec in H0.
    destruct H0.
    auto.
  Qed.
  Lemma removeEdge_spec3 :
    forall G v e,
      IsVertex v G <-> IsVertex v (removeEdge e G).
  Proof.
    reflexivity.
  Qed.

  Definition g := addEdge (1,3) (addVertex 3 (addVertex 1 empty)).

  Definition graph1 :=  (addEdge (1,2) (addEdge (1,3) (addVertex 1 (addVertex 2 (addVertex 3 (addVertex 4 (addVertex 5 empty))))))).

  Definition graph2 :=  (addEdge (1,2) (addEdge (1,3) (addVertex 1 (addVertex 2 (addVertex 3 (addVertex 4 (addVertex 5 empty))))))).

  Definition neighborhood (v : vertex) (G : t): Vertices.t :=
    Edges.fold (fun edge e =>
                  if Pos.eqb (fst edge) v then Vertices.add (snd edge) e
                  else e) (enumEdges G) Vertices.empty.
  Definition test := map ascii_of_pos (Vertices.elements (neighborhood 1 graph2)).
  Require Import List.

  Definition graph_contains (x : vertex) (g : t) : bool :=
    Vertices.mem x (graphVertices g).

  Definition graph_Contains (x : vertex)  (g: t) : Prop :=
    Vertices.In x (graphVertices g).

  Lemma graph_containsP : forall x g,
      reflect (graph_Contains x g) (graph_contains x g).
  Proof.
    intros.
    apply iff_reflect.
    unfold graph_Contains, graph_contains.
    split; intros H; apply Vertices.mem_spec; auto.
  Qed.

  Definition isNeighbor (x y : vertex) (g : t) : Prop :=
    Edges.In (x,y) (graphEdges g).

  Inductive path (g : t) : node -> node -> list node -> Prop :=
  | start : forall x, graph_Contains x g -> path g x x (x::nil)
  | step  : forall x y z l,
      graph_Contains x g ->
      path g y z (y::l) ->
      isNeighbor x y g ->
      path g x z (x::y::l).

End myGraph.

Module g_prop :=  DirectedGraphMorph myGraph.

Extract Inductive bool => "bool" [ "true" "false" ].

Extract Inductive list => "list" [ "[]" "(::)" ].
(* Extract Inductive positive => int [ "XI" "XO" "XH" ] *)
(*    "let rec int_of_pos p = *)
(*   (match p with *)
(*    |XH -> 1 *)
(*    |XO p' -> 2 * (int_of_pos p') *)
(*    |XI p' -> 2* (int_of_pos p') + 1)". *)
(* Extraction "myGraph.ml"  myGraph. *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Bool ZMulOrder NZParity.

(** Some more properties of [even] and [odd]. *)

Module Type ZParityProp (Import Z : ZAxiomsSig')
                        (Import ZP : ZMulOrderProp Z).

Include NZParityProp Z Z ZP.

Lemma odd_pred : forall n, odd (P n) = even n.
Proof.
 intros. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ.
Qed.

Lemma even_pred : forall n, even (P n) = odd n.
Proof.
 intros. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ.
Qed.

Lemma even_opp : forall n, even (-n) = even n.
Proof.
 assert (H : forall n, Even n -> Even (-n)).
  intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv.
 intros. rewrite eq_iff_eq_true, !even_spec.
 split. rewrite <- (opp_involutive n) at 2. apply H.
 apply H.
Qed.

Lemma odd_opp : forall n, odd (-n) = odd n.
Proof.
 intros. rewrite <- !negb_even. now rewrite even_opp.
Qed.

Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m).
Proof.
 intros. now rewrite <- add_opp_r, even_add, even_opp.
Qed.

Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m).
Proof.
 intros. now rewrite <- add_opp_r, odd_add, odd_opp.
Qed.

End ZParityProp.


(***************************************************************************)
(*   This is part of FA_Completeness, it is distributed under the terms    *)
(*           of the GNU Lesser General Public License version 3            *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Import t1.
Require Export Seq.

Theorem MCTup : ∀ a y,
  Increase a -> Boundup_Seq y a -> ∃ ξ, Limit a ξ.
Proof.
  intros; red in H, H0.
  set (J:= /{ r | ∃ t, r = (a t) /}).
  assert (exists p, supremum p J).
  { apply SupremumT.
    - red; exists (a 1); constructor; eauto.
    - exists y; red; intros. destruct H1, H1; rewrite H1; auto. }
  destruct H1 as [z H1]; pose proof H1; destruct H1.
  exists z; red; intros. eapply Cor_supremum in H2; eauto.
  destruct H2 as [x [[[n H2]]]]; subst x. exists n; intros.
  apply -> Ab1; split; apply Theorem188_1 with (Θ:=z); Simpl_R.
  - rewrite Theorem175; unfold Minus_R in H4. eapply Theorem172; eauto.
  - assert (a n0 ∈ J). { constructor; eauto. }
    apply H1 in H6; eapply Theorem172.
    left; split; eauto. rewrite Theorem175; apply Pl_R; auto.
Qed.

Theorem MCTdown : ∀ a y,
  Decrease a -> Bounddown_Seq y a -> ∃ ξ, Limit a ξ.
Proof.
  intros; red in H, H0.
  assert (∃ ξ, Limit (minus_Seq a) ξ).
  { apply (MCTup _ (-y)); red; intros;
    unfold minus_Seq; apply -> LEminus; auto. }
  destruct H1 as [ξ H1]. exists (-ξ); red; intros.
  apply H1 in H2; destruct H2 as [N H2].
  exists N; intros; unfold minus_Seq in H2.
  unfold Minus_R; rewrite <- Theorem178, Theorem180; Simpl_R.
Qed.


Require Import HoTT.

(** The diagonal of a function with two arguments. *)
Definition diag2
           {X Z : Type}
           (f : X -> X -> Z)
  : X -> Z
  := fun x => f x x.

(** `ap` on the diagonal of a function. *)
Definition ap_diag2
           {X Z : Type}
           (f : X -> X -> Z)
           {x₁ x₂ : X}
           (p : x₁ = x₂)
  : ap (diag2 f) p = ap (fun z => f x₁ z) p @ ap (fun z => f z x₂) p
  := match p with
     | idpath => idpath
     end.

(** Curries a function on a product. *)
Definition curry
           {X Y Z : Type}
           (f : X * Y -> Z)
  : X -> Y -> Z
  := fun x y => f(x, y).

(** `ap` on an uncurried function. *)
Definition uncurry_ap
           {X Y Z : Type}
           (f : X -> Y -> Z)
           {x₁ x₂ : X} {y₁ y₂ : Y}
           (p : x₁ = x₂) (q : y₁ = y₂)
  : ap (uncurry f) (path_prod' p q)
    =
    ap (fun z => f z y₁) p @ ap (f x₂) q
  := match p, q with
     | idpath, idpath => idpath
     end.

(** `ap` on a curried function. *)
Definition curry_ap
           {X Y Z : Type}
           (f : X * Y -> Z)
           {x₁ x₂ : X * Y}
           (p : x₁ = x₂)
  : ap f p
    =
    (ap (fun z => curry f z (snd x₁)) (ap fst p))
      @ (ap (fun z => curry f (fst x₂) z) (ap snd p))
  := match p with
     | idpath => idpath
     end.

(** `ap` on `λx.(x,y)` with `y` constant. *)
Definition ap_pair_l
           {X Y : Type}
           {x₁ x₂ : X} (y : Y)
           (p : x₁ = x₂)
  : ap (fun x => (x, y)) p = path_prod' p idpath
  := match p with
     | idpath => idpath
     end.

(** `ap` on `λy.(x,y)` with `x` constant. *)
Definition ap_pair_r
           {X Y : Type}
           (x : X) {y₁ y₂ : Y}
           (q : y₁ = y₂)
  : ap (pair x) q = path_prod' idpath q
  := match q with
     | idpath => idpath
     end.

(** Univalence says when two types are equal.
    We can also use this to say when two sets are equal and this is given by `path_hset`.
    We study some properties of `path_hset`.
 *)
Section path_hset_prop.
  Context `{Univalence}.

  (** This function says when two paths given by `path_hset` are equal. *)
  Definition path_trunctype_eq
             {n : trunc_index}
             {A B : TruncType n}
             (f : A <~> B) (g : A <~> B)
             (fg_eq : equiv_fun f == equiv_fun g)
    : path_trunctype f = path_trunctype g.
  Proof.
    refine (ap path_trunctype _).
    apply path_equiv.
    exact (path_forall _ _ fg_eq).
  Qed.
End path_hset_prop.

(** The analogue of `transport_idmap_ap` for `hSets. *)
Definition transport_idmap_ap_set
           {A : Type}
           (P : A -> hSet)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (u : P a₁)
  : transport P p u = transport (idmap : hSet -> hSet) (ap P p) u
  := match p with
     | idpath => idpath
     end.

(** This computes `transport idmap` (on types) to `transport idmap` (on `hSet`). *)
Definition transport_hpath_to_transport_idmap
           {B C : Type}
           {BS : IsHSet B} {CS : IsHSet C}
           (p : B = C)
           (u : B)
           `{Univalence}
  : transport (idmap : hSet -> hSet)
              (ap (fun u0 : {X : Type & IsHSet X} => @BuildhSet u0.1 u0.2)
                  (path_sigma_hprop (B;BS) (C;CS) p))
              u
    = transport idmap p u.
Proof.
  induction p ; cbn.
  assert(CS = BS) as ->.
  { apply path_ishprop. }
  unfold path_sigma_hprop, path_sigma_uncurried.
  cbn.
  induction (center _).
  reflexivity.
Defined.

(** The analogue of `transport_path_universe` for `hSet`. *)
Definition transport_path_hset
           {B C : hSet}
           (f : Equiv B C)
           (u : B)
           `{Univalence}
  : transport (idmap : hSet -> hSet) (path_hset f) u
    =
    f u.
Proof.
  cbn.
  rewrite concat_1p, concat_p1.
  rewrite transport_hpath_to_transport_idmap.
  apply transport_path_universe_uncurried.
Defined.

(** Next we prove the truncation of a production is equivalent to the product of truncations. *)
Definition Trunc_prod
           {A B : Type}
           (n : trunc_index)
  : Trunc n A * Trunc n B -> Trunc n (A * B).
Proof.
  intros x.
  simple refine (Trunc_rec _ (fst x)) ; intros y₁.
  simple refine (Trunc_rec _ (snd x)) ; intros y₂.
  exact (tr(y₁,y₂)).
Defined.

Definition Trunc_prod_inv
           {A B : Type}
           (n : trunc_index)
  : Trunc n (A * B) -> Trunc n A * Trunc n B.
Proof.
  apply Trunc_rec.
  exact (fun x => (tr (fst x), tr (snd x))).
Defined.

Global Instance Trunc_prod_isequiv
       {A B : Type}
       (n : trunc_index)
  : IsEquiv (@Trunc_prod A B n).
Proof.
  simple refine (isequiv_adjointify _ (Trunc_prod_inv n) _ _) ; unfold Sect.
  - simple refine (Trunc_ind _ _).
    reflexivity.
  - intros [x₁ x₂]. revert x₁.
    simple refine (Trunc_ind _ _) ; intros y₁ ; simpl.
    revert x₂.
    simple refine (Trunc_ind _ _) ; intros y₂ ; simpl.
    reflexivity.
Defined.

(** If the index is at least `0`, then the sum of `n`-types is again an `n`-type. *)
Global Instance Truncated_sum
       {A B : Type}
       (n : trunc_index)
       (H : trunc_index_leq 0 n)
       `{IsTrunc n A} `{IsTrunc n B}
  : IsTrunc n (A + B).
Proof.
  apply trunc_sum' ; try apply _.
  exact (trunc_leq H).
Defined.

(** If the index is at least `0`, then truncation of the sum is equivalent to the sum of the truncations. *)
Definition Trunc_sum
           {A B : Type}
           (n : trunc_index)
  : Trunc n A + Trunc n B -> Trunc n (A + B).
Proof.
  intros [x | x].
  - simple refine (Trunc_rec _ x) ; intros y.
    exact (tr(inl y)).
  - simple refine (Trunc_rec _ x) ; intros y.
    exact (tr(inr y)).
Defined.

Definition Trunc_sum_inv
           {A B : Type}
           (n : trunc_index)
           (H : trunc_index_leq 0 n)
  : Trunc n (A + B) -> Trunc n A + Trunc n B.
Proof.
  simple refine (Trunc_rec _).
  - apply (Truncated_sum n H).
  - intros [x | x].
    + exact (inl (tr x)).
    + exact (inr (tr x)).
Defined.

Global Instance Trunc_sum_isequiv
       {A B : Type}
       (n : trunc_index)
       (H : trunc_index_leq 0 n)
  : IsEquiv (@Trunc_sum A B n).
Proof.
  simple refine (isequiv_adjointify _ (Trunc_sum_inv n H) _ _) ; unfold Sect.
  - simple refine (Trunc_ind _ _).
    intros [a | a] ; reflexivity.
  - intros [x | x] ; revert x ; simple refine (Trunc_ind _ _).
    * intros a.
      pose (@Truncated_sum (Trunc n A) (Trunc n B) n H).
      apply _.
    * reflexivity.
    * intros a.
      pose (@Truncated_sum (Trunc n A) (Trunc n B) n H).
      apply _.
    * reflexivity.
Defined.

Definition ap_precompose
           `{Funext}
           {A B C : Type}
           {f g : A -> B}
           (h : B -> C)
           (e : f == g)
  : ap (fun z : A -> B => h o z) (path_forall f g e)
    =
    path_forall (h o f) (h o g) (fun z : A => ap h (e z))
  := @ap_functor_forall _ _ _ _ _ idmap (fun _ => h) f g e.

Definition ap_postcompose
           `{Funext}
           {A B C : Type}
           {f g : B -> C}
           (h : A -> B)
           (e : f == g)
  : ap (fun z : B -> C => z o h) (path_forall f g e)
    =
    path_forall (f o h) (g o h) (e o h).
Proof.
  refine (@ap_functor_forall _ B _ A (fun _ => C) h (fun _ => idmap) f g e @ _).
  apply ap.
  funext x.
  apply ap_idmap.
Defined.


From Undecidability.L Require Export Tactics.

(** * Scott encoding of numbers *)

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

Lemma enc_proc m :
  proc (enc m).
Proof.
  induction m; value.
Qed.

Hint Resolve enc_proc : cbv.

Lemma enc_injective m n : enc m = enc n -> m = n.
Proof.
  revert n; induction m; intros n; destruct n; inversion 1; eauto.
Qed.

Lemma enc_inj m n : enc m ≡ enc n -> m = n.
Proof.
  intros. destruct (enc_proc m) as [? []], (enc_proc n) as [? []]. rewrite H1, H3 in H.
  eapply unique_normal_forms in H; value. subst. eapply enc_injective; congruence.
Qed.

Definition Zero : term := .\"z","s"; "z".
Definition Succ : term := .\"n","z","s"; "s" "n".

Hint Unfold Zero Succ : cbv.

Lemma Succ_correct n : Succ (enc n) ≻* enc (S n).
Proof.
  solvered.
Qed.

Definition Add  := Eval cbn in rho (.\ "a", "n", "m"; "n" "m" (.\"n"; !Succ ("a" "n" "m"))).

Hint Unfold Add : cbv.

Lemma Add_correct n m :
  Add (enc n) (enc m) ≡ enc (n + m).
Proof.
  induction n; solveeq.
Qed.

(** * Scott encoding of terms *)

Fixpoint tenc t :=
  lambda ( (* var *) lambda ( (* app *) lambda ( (* lambda *)
     match t with
       | var n => (var 2) (enc n)
       | app s t => (var 1) (tenc s) (tenc t)
       | lambda s => (var 0) (tenc s)
     end
  ))).

Lemma tenc_proc s : proc (tenc s).
Proof.
  induction s; value.
Qed.

Hint Resolve tenc_proc : cbv.

Lemma tenc_injective s t : tenc s = tenc t -> s = t.
Proof.
  revert t; induction s; intros t; destruct t; inversion 1.
  - eauto using enc_injective.
  - erewrite IHs1, IHs2; eauto.
  - erewrite IHs; eauto.
Qed.

Lemma tenc_inj s t : tenc s ≡ tenc t -> s = t.
Proof.
  intros. destruct (tenc_proc t) as [? []], (tenc_proc s) as [? []]. rewrite H1, H3 in H.
  eapply unique_normal_forms in H; value. eapply tenc_injective. congruence.
Qed.

Definition Var : term := .\"n";     .\"v","a","l"; "v" "n".
Definition App : term := .\"s","t"; .\"v","a","l"; "a" "s" "t".
Definition Lam : term := .\"s";     .\"v","a","l"; "l" "s".

Lemma Var_correct n : Var (enc n) ≡ tenc (n).
Proof.
  solveeq.
Qed.

Lemma App_correct s t : App (tenc s) (tenc t) ≡ tenc (s t).
Proof.
  solveeq.
Qed.

Lemma Lam_correct s : Lam (tenc s) ≡ tenc (lambda s).
Proof.
  solveeq.
Qed.

Definition N := rho ( .\"N", "n"; "n"
   !(tenc Zero)
   (.\"n"; !Lam (!Lam (!App !(tenc 0) ("N" "n"))))).

Lemma N_correct n : N (enc n) ≡ tenc(enc n).
Proof.
  induction n; solveeq.
Qed.

Definition Q := Eval cbn in rho ( .\"Q", "s"; "s"
   (.\"n";     !Lam (!Lam (!Lam (!App !(tenc 2) (!N "n")))))
   (.\"s","t"; !Lam (!Lam (!Lam (!App (!App !(tenc 1) ("Q" "s")) ("Q" "t")))))
   (.\"s";     !Lam (!Lam (!Lam (!App !(tenc 0) ("Q" "s"))))) ).

Lemma Q_correct s : Q (tenc s) ≡ tenc(tenc s).
Proof.
  induction s; (try assert (R:=N_correct n)); solveeq.
Qed.

(** ** Scott encoding of booleans *)

Definition benc (b:bool) : term := if b then T else F.
Hint Unfold T F : cbv.

Lemma benc_proc b : proc (benc b).
Proof.
  destruct b; value.
Qed.
Hint Resolve benc_proc : cbv.

Lemma T_equiv_F : ~ T ≡ F.
Proof.
  cbv. intros H. eapply unique_normal_forms in H; value. inv H.
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 :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf2 : lst) : natural := len (Cons (double Zero) lf2).


From Coq Require Import ssreflect ssrfun ssrbool.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Coq.Program.Equality.
Require Import Coq.Init.Datatypes.
Require Export Bool.
Require Import Unicode.Utf8.

Inductive TermType := | Value | Type_ | rule_jugd .

Inductive Symbol (x : TermType) :=
  | initial : Symbol x
  | next : Symbol x -> Symbol x.

Inductive TypeDef :=
  | SimplyT : Symbol Type_ -> TypeDef
  | Arrow : TypeDef -> TypeDef -> TypeDef
  | Udnf : TypeDef.

Inductive Expression :=
  |Var : Symbol Value -> TypeDef -> Expression
  |Abs : Expression -> Expression -> TypeDef -> Expression
  |App : Expression -> Expression -> TypeDef -> Expression.

Definition type_of_T (e' : Expression) :=
  match e' return TypeDef with
    |Var _ t => t
    |Abs _ _ t => t
    |App _ _ t => t
  end.

Inductive Enviroment :=
  |empty : Enviroment
  |bind : ∀ T {H : T <> Udnf}, Expression -> Enviroment -> Enviroment.

Notation "T*" := Enviroment.

Notation "{}" := empty.

Inductive Judgment env (P : Enviroment -> Prop) :=
  |Assume : P env -> Judgment env P.

Fixpoint same_symbol {F} (x : Symbol F) (y : Symbol F) :=
  match (x, y) with
    |(next _ k, next _ k') => same_symbol k k'
    |(initial _, initial _) => true
    |_ => false
  end.

Fixpoint same_type (x : TypeDef) (y : TypeDef) :=
  match (x, y) with
    | (SimplyT k, SimplyT k') => same_symbol k k'
    | (Arrow k k', Arrow u u') => (same_type k u) && (same_type k' u')
    | (Udnf, Udnf) => true
    | _ => false
  end.

Fixpoint has_type (x : TypeDef) (env : Enviroment) : bool :=
  match env with
    |empty => false
    |bind T LT es => match T with
                          |Udnf => (has_type x es)
                          |_ => if (same_type x T) then true else (has_type x es)
                        end
  end.

Fixpoint same_expression (x : Expression) (y : Expression) : bool :=
  match (x, y) with
    | (Var x t, Var y t') => same_type t t' && same_symbol x y
    | (Abs s x t, Abs s' x' t') => same_type t t' && same_expression s s' && (same_expression x x')
    | (App x y t, App x' y' t') => same_type t t'&& same_expression x x' && same_expression y y'
    | _ => false
  end.

Fixpoint varType (x : Expression) (env : Enviroment) : TypeDef :=
  match env with
    |empty => Udnf
    |bind T LT es => if (same_expression x LT) then T else varType x es
  end.

Notation "x |- y" := (Judgment x (fun p => (has_type (varType y x) x) = true)) (at level 202, right associativity).
Notation "x |- { y ::: T }" := (Judgment x (fun p => (has_type (varType y x) x) = true /\ (varType y x) = T)) (at level 201, right associativity).
Notation "x ∈ y" := (varType x y <> Udnf) (at level 50, left associativity, only parsing).

Definition ArrowIsDef : ∀ T1 T2, Arrow T1 T2 <> Udnf. by []. Defined.

Inductive typed_rules : T* -> Symbol Value -> Expression -> Type :=
  |Tvar : ∀ (env : Enviroment) (s : Symbol _) T {H' : T <> Udnf}, (env |- {(Var s T) ::: T}) -> typed_rules env s (Var s T)
  |TAbs : ∀ (env : Enviroment) (k : Symbol Value) x T2 {H' : T2 <> Udnf} s,
    typed_rules env k x -> (env |- {(Var s T2) ::: T2}) ->
      (fun t =>
        typed_rules (@bind (Arrow T2 (type_of_T x)) (ArrowIsDef _ _) t env) (next _ k) t) (Abs (Var s T2) x (Arrow T2 (type_of_T x)))
  |TApp : ∀ (env : Enviroment) (k : Symbol Value) (x : Expression) T T' T1 T2 {H : T2 <> Udnf},
    typed_rules env k x -> (env |- {T ::: Arrow T1 T2}) -> (env |- {T' ::: T1}) ->
      (fun t => (typed_rules (@bind T2 H t env) k t)) (App T T' T2).

Theorem well_typed_context_has_type : ∀ {K} (env : Enviroment) (s : Symbol _) (H : typed_rules env s K), (env |- K) -> K ∈ env.
intros.
destruct H0;destruct (varType K env); cbv.
discriminate.
discriminate.
have : ∀ env, has_type Udnf env = false.
move => H'; elim : H'; trivial.
intros.
rewrite <- H1.
destruct T.
auto.
auto.
simpl; trivial.
assert (∀ x, x = false -> x <> true).
move => H'.
destruct H'; move => SH.
discriminate.
discriminate.
move => l;contradiction (H0 _ (l env)).
Qed.

Lemma H0_symbol : ∀ {T} (s : Symbol T), same_symbol s s = true.
move => f; elim; trivial.
Defined.

Hint Resolve H0_symbol.

Lemma H1_expression : ∀ e, same_expression e e = true.

have : ∀ s', same_type s' s' = true.
elim.
move => //=.
move => Eq k k' H.
move => /=.
rewrite k H.
done.
done.

move => H.
elim.
move => /= s t.
rewrite -> (H t).
move => //=.
move => s e t H' t0 /=.
rewrite e H' (H t0); move => /=; intuition.
move => e e0 t H' t0 //=.
rewrite e0 H'; intuition.
Defined.

Lemma H3_type : ∀ e, same_type e e = true.
elim.
move => q /=; by [].
move => q k' v H' /=.
rewrite k' //.
done.
Defined.

Ltac type_eq_solver :=
  let rewrite_type_axioms :=
    try (do ! (rewrite -> (H0_symbol _)));
    try (do ! (rewrite -> (H1_expression _)));
    try (do ! (rewrite -> (H3_type _))) in
  let rewrite_type_axioms_H H :=
    try (do ! (rewrite (H0_symbol _)) in H);
    try (do ! (rewrite (H1_expression _)) in H);
    try (do ! (rewrite -> (H3_type _)) in H) in
    do ! (simpl; rewrite_type_axioms); match goal with
    |  [ H : _ |- _ ] => generalize H; do ! (simpl; rewrite_type_axioms_H H); clear H; type_eq_solver; intro H
    |  [ |- _ ] => match goal with
            | [ H : _ |- _ ] => fail 1
            | [ |- _ ] => simpl
            end
  end.

Theorem type_context_abs :
  ∀ (env : Enviroment) (s : Symbol _) T k y (H : typed_rules env s (Abs k y T)), (env |- {(Abs k y T) ::: T}).
intros.

have :
  has_type (varType (Abs k y T) env) env = true /\ varType (Abs k y T) env = T -> Judgment env (fun _ : T* => has_type (varType (Abs k y T) env) env = true /\ varType (Abs k y T) env = T).
move => D; constructor; trivial.
apply.

remember (Abs k y T).
destruct H.
discriminate Heqe.
constructor.
- simpl; destruct j; type_eq_solver; reflexivity.
- destruct j.
  generalize (Abs (Var s T2) x (Arrow T2 (type_of_T x))).
  case;simpl.
  move => s' t';type_eq_solver.
  injection Heqe; trivial.
  intros;type_eq_solver.
  simpl;injection Heqe; intros; assumption.
  intros;type_eq_solver;simpl;injection Heqe; intros; assumption.
- inversion Heqe.
Qed.

Theorem Types_of_terms_are_well_defined : ∀ T x s env, typed_rules env s x -> varType x env = T -> T <> Udnf.
intros.
destruct H.
do 2 destruct j as [j].
rewrite -> H in H0;rewrite H0 in H'.
exact H'.
do 2 destruct j as [j].
subst;type_eq_solver.
apply : ArrowIsDef.
do 2 destruct j as [j];do 2 destruct j0 as [j0].
subst;simpl;type_eq_solver;assumption.
Qed.

Lemma conservation_of_types : ∀ T x s env, typed_rules env s x -> varType x env = T -> type_of_T x = T.
intros.
set H' := (@Types_of_terms_are_well_defined _ _ _ _ H H0).
induction env.
simpl in H0;cbv in H'.
destruct (H' (eq_sym H0)).
destruct H.
do 2 destruct j as [j];simpl in *;clear H';rewrite -> e0 in H0.
assumption.
do 2 destruct j as [j].
simpl in *;subst;type_eq_solver; reflexivity.
do 2 destruct j as [j].
do 2 destruct j0 as [j0].
subst.
simpl.
type_eq_solver.
trivial.
Qed.

Theorem type_context :
  ∀ (env : Enviroment) (s : Symbol _) T K (H : typed_rules env s K), type_of_T K = T -> (env |- {K ::: T}).
intros.

have : has_type (varType K env) env = true /\ varType K env = T -> Judgment env
  (fun _ : T* => has_type (varType K env) env = true /\ varType K env = T).
move => H'.
destruct H'.
constructor.
constructor.
assumption.
assumption.
apply.

constructor.
destruct H.
do 2 destruct j as [j].
assumption.
simpl;type_eq_solver;trivial;subst.
do 2 destruct j as [j].
do 2 destruct j0 as [j0].
type_eq_solver;destruct T2.
trivial.
trivial.
contradiction H;trivial.
destruct H.
do 2 destruct j as [j].
simpl in H0.
rewrite <- H0.
assumption.
do 2 destruct j as [j].
subst;simpl;type_eq_solver;trivial.
do 2 destruct j as [j];do 2 destruct j0 as [j0].
subst;type_eq_solver; trivial.
Qed.

Lemma eq_symb : ∀ {T} (x : Symbol T) y, same_symbol x y = true -> x = y.
intros.
(*try to proof this normally induction is bit hard cause' the x and y are evaluated in same time so the
  induction have to reason about two mutually, so a new mutual scheme was set*)
set mutually_symbol := fun (x : TermType) (P : Symbol x -> Symbol x -> Prop)
        (f_2initial : P (initial x) (initial x))
        (f_2next : forall s s' : Symbol x,
                    P s s' -> P (next x s) (next x s'))
        (f_contr0' : forall s s' : Symbol x,
                      P s s' -> P (initial x) (next x s'))
        (f_contr1' : forall s s' : Symbol x,
                      P s s' -> P (next x s) (initial x)) =>
        fix Ffix (x0 : Symbol x) : forall x1 : Symbol x, P x0 x1 :=
        match x0 as c return (forall x1 : Symbol x, P c x1) with
          | initial _ =>
            fix Ffix0 (x1 : Symbol x) : P (initial x) x1 :=
              match x1 as c return (P (initial x) c) with
                | initial _ => f_2initial
                | next _ x2 => f_contr0' (initial x) x2 (Ffix0 x2)
              end
          | next _ x1 =>
              fun x2 : Symbol x =>
              match x2 as c return (P (next x x1) c) with
                | initial _ => f_contr1' x1 (initial x) (Ffix x1 (initial x))
                | next _ x3 => f_2next x1 x3 (Ffix x1 x3)
              end
        end.
move : H.
elim/mutually_symbol : x/y.
done.
move => /= s s' H q.
set f := (H q).
rewrite -> f.
done.
done.
done.
Qed.

(*A specialized ssreflect based tatic for working induction in equal types*)
Ltac induction_eqType k y:=
  move => k; move => y;
  set type_mutual_induction := (fun (P : TypeDef -> TypeDef -> Prop)
        (f_2SimplyT : forall k k' : Symbol Type_, P (SimplyT k) (SimplyT k'))
        (f_2Udnf : P Udnf Udnf)
        (f_Simply_Arrow : forall (k : Symbol Type_) (s s' : TypeDef),
                          P (SimplyT k) (Arrow s s'))
        (f_Arrow_Simply : forall (k : Symbol Type_) (s s' : TypeDef),
                          P (Arrow s s') (SimplyT k))
        (f_Simply_Udnf : forall k : Symbol Type_, P (SimplyT k) Udnf)
        (f_Udnf_Simply : forall k : Symbol Type_, P Udnf (SimplyT k))
        (f_2Arrow : forall s s' q q' : TypeDef,
                    P s q -> P s' q' -> P (Arrow s s') (Arrow q q'))
        (f_Arrow_Udnf : forall s s' : TypeDef, P (Arrow s s') Udnf)
        (f_Udnf_Arrow : forall s s' : TypeDef, P Udnf (Arrow s s')) =>
          fix Ffix (x : TypeDef) : forall x0 : TypeDef, P x x0 :=
            match x as c return (forall x0 : TypeDef, P c x0) with
              | SimplyT x0 =>
                fun x1 : TypeDef =>
                  match x1 as c return (P (SimplyT x0) c) with
                    | SimplyT x2 => f_2SimplyT x0 x2
                    | Arrow x2 x3 => f_Simply_Arrow x0 x2 x3
                    | Udnf => f_Simply_Udnf x0
                  end
              | Arrow x0 x1 =>
                fix Ffix0 (x2 : TypeDef) : P (Arrow x0 x1) x2 :=
                  match x2 as c return (P (Arrow x0 x1) c) with
                    | SimplyT x3 => f_Arrow_Simply x3 x0 x1
                    | Arrow x3 x4 =>
                      f_2Arrow x0 x1 x3 x4 (Ffix x0 x3) (Ffix x1 x4)
                    | Udnf => f_Arrow_Udnf x0 x1
                  end
              | Udnf =>
                fun x0 : TypeDef =>
                  match x0 as c return (P Udnf c) with
                    | SimplyT x1 => f_Udnf_Simply x1
                    | Arrow x1 x2 => f_Udnf_Arrow x1 x2
                    | Udnf => f_2Udnf
                  end
            end);
  elim/type_mutual_induction : k/y; clear.

Lemma eq_type : ∀ k y, same_type k y = true-> k = y.
induction_eqType k y.
intros.
unfold same_type in H.
rewrite -> (eq_symb _ _ H).
trivial.
trivial.
intros;inversion H.
intros;inversion H.
intros;inversion H.
intros;inversion H.
intros.
simpl in H1.
apply andb_true_iff in H1.
destruct H1.
apply H in H1.
apply H0 in H2.
rewrite H1 H2.
trivial.
intros; inversion H.
intros; inversion H.
Qed.

(*False injection was the more easy way to prove somes check that the typed_rules do is wrong,
  fortunately the "bind" construct a false injection equality*)

Lemma False_injection_nextC : ∀ (t : TypeDef) t0, t = Arrow t0 t -> False.
induction t.
intros.
discriminate.
move => H H1.
injection H1.
intros.
rewrite -> H2 in H1.
injection H1.
intros.
apply IHt2 in H3.
trivial.
discriminate.
Qed.

Theorem lambda_type_return :
  ∀ (env : Enviroment) (s : Symbol _) k y T1 T2 x (H : typed_rules env s x), x = (Abs k y (Arrow T1 T2)) ->
    (env |- {(Abs k y (Arrow T1 T2)) ::: Arrow T1 T2}) -> (env |- {y ::: T2}).
intros.
remember s; destruct H.
inversion H0.
constructor.
simpl in *; injection H0; intros; destruct H1.
destruct y; simpl in *.
constructor.
subst; do 2 destruct j as [j].
type_eq_solver.
destruct (same_type (varType (Var s0 t) env) (Arrow T1 t)); trivial.
assert(type_of_T (Var s0 t) = t).
trivial.
pose(type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
destruct (same_type (varType (Var s1 t) env) (Arrow T1 t)).
trivial.
assumption.
destruct (same_type (varType (Var s1 t) env) (Arrow T1 t)).
trivial.
assert(type_of_T (Var s1 t) = t).
trivial.
pose (type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
assumption.
destruct a.
destruct j.
destruct a.
injection H0; intros.
rewrite <- H4; rewrite <- H2.
pose(type_context _ _ _ _ H H9).
do 2 destruct j as [j].
subst; assumption.
constructor.
do 2 destruct j as [j].
subst; type_eq_solver.
case : (same_type t (Arrow T1 t) && same_expression y1 (Var s0 T1) &&
  same_expression y2 (Abs y1 y2 t)).
type_eq_solver; trivial.
destruct (same_type (varType (Abs y1 y2 t) env) (Arrow T1 t)).
trivial.
assert(type_of_T (Abs y1 y2 t) = t).
trivial.
pose(type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
trivial.

do 2 destruct j as [j].
simpl in *; subst; type_eq_solver.
remember (if
  same_type t (Arrow T1 t) && same_expression y1 (Var s0 T1) &&
  same_expression y2 (Abs y1 y2 t)
    then Arrow T1 t
    else varType (Abs y1 y2 t) env).
remember (same_type t (Arrow T1 t)).
remember (same_expression y1 (Var s0 T1) && same_expression y2 (Abs y1 y2 t)).
destruct b.
symmetry in Heqb; apply eq_type in Heqb; destruct (False_injection_nextC _ _ Heqb).
simpl in Heqt0; rewrite -> Heqt0.
assert(type_of_T (Abs y1 y2 t) = t).
trivial.
pose (type_context _ _ _ _ H H2).
do 2 destruct j0 as [j0].
assumption.

subst; type_eq_solver; constructor.
destruct (same_type (varType (App y1 y2 t) env) (Arrow T1 t)).
trivial.
destruct H.
do 2 destruct j0 as [j0]; exact j0.
type_eq_solver; trivial.
simpl in *; type_eq_solver; destruct T2; trivial.
trivial.
contradiction H; apply : eq_refl.
remember (App y1 y2 t); destruct H.
do 2 destruct j0 as [j0].
inversion Heqe.
simpl in *; type_eq_solver.
inversion Heqe.
simpl in *; type_eq_solver; injection Heqe; intros; assumption.
inversion H0.
Qed.

(*this lemma is a counter implication of conservation_of_types so, we able to construct a strong <-> relation between enviroment and their types*)
Lemma strong_enviroment_conservation : ∀ T2 env y, same_type (varType y env) T2 = true -> varType y env = T2.
move => t2 d; elim.
move => y g Heq.
induction y.
destruct d.
destruct t2; simpl in Heq.
inversion Heq.
inversion Heq.
trivial; simpl; simpl in Heq.
move : Heq; generalize (if
  match e with
  | Var y t' =>
      same_type g t' &&
      match y with
      | initial _ => true
      | next _ _ => false
      end
  | _ => false
  end
    then T
    else varType (Var (initial Value) g) d).
move => t0; apply : eq_type.
destruct d; simpl in *.
apply IHy in Heq; assumption.
apply eq_type in Heq; trivial.
intros; apply eq_type in H1; trivial.
intros;apply eq_type in H1;trivial.
Qed.