(* Copyright (c) 2008-2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import CpdtTactics.

Definition bad : unit := tt.

Set Implicit Arguments.
(* end hide *)

(** %\chapter{Infinite Data and Proofs}% *)

(** In lazy functional programming languages like %\index{Haskell}%Haskell, infinite data structures are everywhere%~\cite{whyfp}%.  Infinite lists and more exotic datatypes provide convenient abstractions for communication between parts of a program.  Achieving similar convenience without infinite lazy structures would, in many cases, require acrobatic inversions of control flow.

%\index{laziness}%Laziness is easy to implement in Haskell, where all the definitions in a program may be thought of as mutually recursive.  In such an unconstrained setting, it is easy to implement an infinite loop when you really meant to build an infinite list, where any finite prefix of the list should be forceable in finite time.  Haskell programmers learn how to avoid such slip-ups.  In Coq, such a laissez-faire policy is not good enough.

We spent some time in the last chapter discussing the %\index{Curry-Howard correspondence}%Curry-Howard isomorphism, where proofs are identified with functional programs.  In such a setting, infinite loops, intended or otherwise, are disastrous.  If Coq allowed the full breadth of definitions that Haskell did, we could code up an infinite loop and use it to prove any proposition vacuously.  That is, the addition of general recursion would make CIC _inconsistent_.  For an arbitrary proposition [P], we could write:
[[
Fixpoint bad (u : unit) : P := bad u.
]]

This would leave us with [bad tt] as a proof of [P].

There are also algorithmic considerations that make universal termination very desirable.  We have seen how tactics like [reflexivity] compare terms up to equivalence under computational rules.  Calls to recursive, pattern-matching functions are simplified automatically, with no need for explicit proof steps.  It would be very hard to hold onto that kind of benefit if it became possible to write non-terminating programs; we would be running smack into the halting problem.

One solution is to use types to contain the possibility of non-termination.  For instance, we can create a "non-termination monad," inside which we must write all of our general-recursive programs; several such approaches are surveyed in Chapter 7.  This is a heavyweight solution, and so we would like to avoid it whenever possible.

Luckily, Coq has special support for a class of lazy data structures that happens to contain most examples found in Haskell.  That mechanism,%\index{co-inductive types}% _co-inductive types_, is the subject of this chapter. *)

(** * Computing with Infinite Data *)

(** Let us begin with the most basic type of infinite data, _streams_, or lazy lists.%\index{Vernacular commands!CoInductive}% *)

Section stream.
  Variable A : Type.

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

(* begin hide *)
(* begin thide *)
CoInductive evilStream := Nil.
(* end thide *)
(* end hide *)

(** The definition is surprisingly simple.  Starting from the definition of [list], we just need to change the keyword [Inductive] to [CoInductive].  We could have left a [Nil] constructor in our definition, but we will leave it out to force all of our streams to be infinite.

   How do we write down a stream constant?  Obviously, simple application of constructors is not good enough, since we could only denote finite objects that way.  Rather, whereas recursive definitions were necessary to _use_ values of recursive inductive types effectively, here we find that we need%\index{co-recursive definitions}% _co-recursive definitions_ to _build_ values of co-inductive types effectively.

   We can define a stream consisting only of zeroes.%\index{Vernacular commands!CoFixpoint}% *)

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

(* EX: Define a stream that alternates between [true] and [false]. *)
(* begin thide *)

(** We can also define a stream that alternates between [true] and [false]. *)

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.
(* end thide *)

(** Co-inductive values are fair game as arguments to recursive functions, and we can use that fact to write a function to take a finite approximation of a stream. *)

(* EX: Define a function to calculate a finite approximation of a stream, to a particular length. *)
(* begin thide *)

Fixpoint approx A (s : stream A) (n : nat) : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: approx t n'
      end
  end.

Eval simpl in approx zeroes 10.
(** %\vspace{-.15in}% [[
     = 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: nil
     : list nat
     ]]
     *)

Eval simpl in approx trues_falses 10.
(** %\vspace{-.15in}% [[
     = true
       :: false
          :: true
             :: false
                :: true :: false :: true :: false :: true :: false :: nil
     : list bool
      ]]
*)

(* end thide *)

(* begin hide *)
(* begin thide *)
Definition looper := 0.
(* end thide *)
(* end hide *)

(** So far, it looks like co-inductive types might be a magic bullet, allowing us to import all of the Haskeller's usual tricks.  However, there are important restrictions that are dual to the restrictions on the use of inductive types.  Fixpoints _consume_ values of inductive types, with restrictions on which _arguments_ may be passed in recursive calls.  Dually, co-fixpoints _produce_ values of co-inductive types, with restrictions on what may be done with the _results_ of co-recursive calls.

The restriction for co-inductive types shows up as the%\index{guardedness condition}% _guardedness condition_.  First, consider this stream definition, which would be legal in Haskell.
[[
CoFixpoint looper : stream nat := looper.
]]

<<
Error:
Recursive definition of looper is ill-formed.
In environment
looper : stream nat

unguarded recursive call in "looper"
>>

The rule we have run afoul of here is that _every co-recursive call must be guarded by a constructor_; that is, every co-recursive call must be a direct argument to a constructor of the co-inductive type we are generating.  It is a good thing that this rule is enforced.  If the definition of [looper] were accepted, our [approx] function would run forever when passed [looper], and we would have fallen into inconsistency.

Some familiar functions are easy to write in co-recursive fashion. *)

Section map.
  Variables A B : Type.
  Variable f : A -> B.

  CoFixpoint map (s : stream A) : stream B :=
    match s with
      | Cons h t => Cons (f h) (map t)
    end.
End map.

(* begin hide *)
(* begin thide *)
Definition filter := 0.
(* end thide *)
(* end hide *)

(** This code is a literal copy of that for the list [map] function, with the [nil] case removed and [Fixpoint] changed to [CoFixpoint].  Many other standard functions on lazy data structures can be implemented just as easily.  Some, like [filter], cannot be implemented.  Since the predicate passed to [filter] may reject every element of the stream, we cannot satisfy the guardedness condition.

   The implications of the condition can be subtle.  To illustrate how, we start off with another co-recursive function definition that _is_ legal.  The function [interleave] takes two streams and produces a new stream that alternates between their elements. *)

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
      | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

(** Now say we want to write a weird stuttering version of [map] that repeats elements in a particular way, based on interleaving. *)

Section map'.
  Variables A B : Type.
  Variable f : A -> B.
(* begin thide *)
  (** %\vspace{-.15in}%[[
  CoFixpoint map' (s : stream A) : stream B :=
    match s with
      | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t))
    end.
    ]]
    %\vspace{-.15in}%We get another error message about an unguarded recursive call. *)

End map'.

(** What is going wrong here?  Imagine that, instead of [interleave], we had called some other, less well-behaved function on streams.  Here is one simpler example demonstrating the essential pitfall.  We start by defining a standard function for taking the tail of a stream.  Since streams are infinite, this operation is total. *)

Definition tl A (s : stream A) : stream A :=
  match s with
    | Cons _ s' => s'
  end.

(** Coq rejects the following definition that uses [tl].
[[
CoFixpoint bad : stream nat := tl (Cons 0 bad).
]]

Imagine that Coq had accepted our definition, and consider how we might evaluate [approx bad 1].  We would be trying to calculate the first element in the stream [bad].  However, it is not hard to see that the definition of [bad] "begs the question": unfolding the definition of [tl], we see that we essentially say "define [bad] to equal itself"!  Of course such an equation admits no single well-defined solution, which does not fit well with the determinism of Gallina reduction.

Coq's complete rule for co-recursive definitions includes not just the basic guardedness condition, but also a requirement about where co-recursive calls may occur.  In particular, a co-recursive call must be a direct argument to a constructor, _nested only inside of other constructor calls or [fun] or [match] expressions_.  In the definition of [bad], we erroneously nested the co-recursive call inside a call to [tl], and we nested inside a call to [interleave] in the definition of [map'].

Coq helps the user out a little by performing the guardedness check after using computation to simplify terms.  For instance, any co-recursive function definition can be expanded by inserting extra calls to an identity function, and this change preserves guardedness.  However, in other cases computational simplification can reveal why definitions are dangerous.  Consider what happens when we inline the definition of [tl] in [bad]:
[[
CoFixpoint bad : stream nat := bad.
]]
This is the same looping definition we rejected earlier.  A similar inlining process reveals an alternate view on our failed definition of [map']:
[[
CoFixpoint map' (s : stream A) : stream B :=
  match s with
    | Cons h t => Cons (f h) (Cons (f h) (interleave (map' t) (map' t)))
  end.
]]
Clearly in this case the [map'] calls are not immediate arguments to constructors, so we violate the guardedness condition. *)
(* end thide *)

(** A more interesting question is why that condition is the right one.  We can make an intuitive argument that the original [map'] definition is perfectly reasonable and denotes a well-understood transformation on streams, such that every output would behave properly with [approx].  The guardedness condition is an example of a syntactic check for%\index{productivity}% _productivity_ of co-recursive definitions.  A productive definition can be thought of as one whose outputs can be forced in finite time to any finite approximation level, as with [approx].  If we replaced the guardedness condition with more involved checks, we might be able to detect and allow a broader range of productive definitions.  However, mistakes in these checks could cause inconsistency, and programmers would need to understand the new, more complex checks.  Coq's design strikes a balance between consistency and simplicity with its choice of guard condition, though we can imagine other worthwhile balances being struck, too. *)

(** * Infinite Proofs *)

(** Let us say we want to give two different definitions of a stream of all ones, and then we want to prove that they are equivalent. *)

CoFixpoint ones : stream nat := Cons 1 ones.
Definition ones' := map S zeroes.

(** The obvious statement of the equality is this: *)

Theorem ones_eq : ones = ones'.

(* begin hide *)
(* begin thide *)
Definition foo := @eq.
(* end thide *)
(* end hide *)

  (** However, faced with the initial subgoal, it is not at all clear how this theorem can be proved.  In fact, it is unprovable.  The [eq] predicate that we use is fundamentally limited to equalities that can be demonstrated by finite, syntactic arguments.  To prove this equivalence, we will need to introduce a new relation. *)
(* begin thide *)

Abort.

(** Co-inductive datatypes make sense by analogy from Haskell.  What we need now is a _co-inductive proposition_.  That is, we want to define a proposition whose proofs may be infinite, subject to the guardedness condition.  The idea of infinite proofs does not show up in usual mathematics, but it can be very useful (unsurprisingly) for reasoning about infinite data structures.  Besides examples from Haskell, infinite data and proofs will also turn out to be useful for modelling inherently infinite mathematical objects, like program executions.

We are ready for our first %\index{co-inductive predicates}%co-inductive predicate. *)

Section stream_eq.
  Variable A : Type.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2,
    stream_eq t1 t2
    -> stream_eq (Cons h t1) (Cons h t2).
End stream_eq.

(** We say that two streams are equal if and only if they have the same heads and their tails are equal.  We use the normal finite-syntactic equality for the heads, and we refer to our new equality recursively for the tails.

We can try restating the theorem with [stream_eq]. *)

Theorem ones_eq : stream_eq ones ones'.
  (** Coq does not support tactical co-inductive proofs as well as it supports tactical inductive proofs.  The usual starting point is the [cofix] tactic, which asks to structure this proof as a co-fixpoint. *)

  cofix.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq ones ones'

   ]]

   It looks like this proof might be easier than we expected! *)

  assumption.
  (** <<
Proof completed.
>>

  Unfortunately, we are due for some disappointment in our victory lap.
  [[
Qed.
]]

<<
Error:
Recursive definition of ones_eq is ill-formed.

In environment
ones_eq : stream_eq ones ones'

unguarded recursive call in "ones_eq"
>>

Via the Curry-Howard correspondence, the same guardedness condition applies to our co-inductive proofs as to our co-inductive data structures.  We should be grateful that this proof is rejected, because, if it were not, the same proof structure could be used to prove any co-inductive theorem vacuously, by direct appeal to itself!

Thinking about how Coq would generate a proof term from the proof script above, we see that the problem is that we are violating the guardedness condition.  During our proofs, Coq can help us check whether we have yet gone wrong in this way.  We can run the command [Guarded] in any context to see if it is possible to finish the proof in a way that will yield a properly guarded proof term.%\index{Vernacular commands!Guarded}%
     [[
Guarded.
]]

     Running [Guarded] here gives us the same error message that we got when we tried to run [Qed].  In larger proofs, [Guarded] can be helpful in detecting problems _before_ we think we are ready to run [Qed].

     We need to start the co-induction by applying [stream_eq]'s constructor.  To do that, we need to know that both arguments to the predicate are [Cons]es.  Informally, this is trivial, but [simpl] is not able to help us. *)

  Undo.
  simpl.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq ones ones'

   ]]

   It turns out that we are best served by proving an auxiliary lemma. *)

Abort.

(** First, we need to define a function that seems pointless at first glance. *)

Definition frob A (s : stream A) : stream A :=
  match s with
    | Cons h t => Cons h t
  end.

(** Next, we need to prove a theorem that seems equally pointless. *)

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s; reflexivity.
Qed.

(** But, miraculously, this theorem turns out to be just what we needed. *)

Theorem ones_eq : stream_eq ones ones'.
  cofix.

  (** We can use the theorem to rewrite the two streams. *)

  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq (frob ones) (frob ones')

   ]]

   Now [simpl] is able to reduce the streams. *)

  simpl.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq (Cons 1 ones)
     (Cons 1
        ((cofix map (s : stream nat) : stream nat :=
            match s with
            | Cons h t => Cons (S h) (map t)
            end) zeroes))

            ]]

  Note the [cofix] notation for anonymous co-recursion, which is analogous to the [fix] notation we have already seen for recursion.  Since we have exposed the [Cons] structure of each stream, we can apply the constructor of [stream_eq]. *)

  constructor.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq ones
     ((cofix map (s : stream nat) : stream nat :=
         match s with
         | Cons h t => Cons (S h) (map t)
         end) zeroes)

         ]]

  Now, modulo unfolding of the definition of [map], we have matched our assumption. *)

  assumption.
Qed.

(** Why did this silly-looking trick help?  The answer has to do with the constraints placed on Coq's evaluation rules by the need for termination.  The [cofix]-related restriction that foiled our first attempt at using [simpl] is dual to a restriction for [fix].  In particular, an application of an anonymous [fix] only reduces when the top-level structure of the recursive argument is known.  Otherwise, we would be unfolding the recursive definition ad infinitum.

   Fixpoints only reduce when enough is known about the _definitions_ of their arguments.  Dually, co-fixpoints only reduce when enough is known about _how their results will be used_.  In particular, a [cofix] is only expanded when it is the discriminee of a [match].  Rewriting with our superficially silly lemma wrapped new [match]es around the two [cofix]es, triggering reduction.

   If [cofix]es reduced haphazardly, it would be easy to run into infinite loops in evaluation, since we are, after all, building infinite objects.

   One common source of difficulty with co-inductive proofs is bad interaction with standard Coq automation machinery.  If we try to prove [ones_eq'] with automation, like we have in previous inductive proofs, we get an invalid proof. *)

Theorem ones_eq' : stream_eq ones ones'.
  cofix; crush.
  (** %\vspace{-.25in}%[[
  Guarded.
  ]]
  %\vspace{-.25in}%
  *)
Abort.

(** The standard [auto] machinery sees that our goal matches an assumption and so applies that assumption, even though this violates guardedness.  A correct proof strategy for a theorem like this usually starts by [destruct]ing some parameter and running a custom tactic to figure out the first proof rule to apply for each case.  Alternatively, there are tricks that can be played with "hiding" the co-inductive hypothesis.

   %\medskip%

   Must we always be cautious with automation in proofs by co-induction?  Induction seems to have dual versions of the same pitfalls inherent in it, and yet we avoid those pitfalls by encapsulating safe Curry-Howard recursion schemes inside named induction principles.  It turns out that we can usually do the same with%\index{co-induction principles}% _co-induction principles_.  Let us take that tack here, so that we can arrive at an [induction x; crush]-style proof for [ones_eq'].

   An induction principle is parameterized over a predicate characterizing what we mean to prove, _as a function of the inductive fact that we already know_.  Dually, a co-induction principle ought to be parameterized over a predicate characterizing what we mean to prove, _as a function of the arguments to the co-inductive predicate that we are trying to prove_.

   To state a useful principle for [stream_eq], it will be useful first to define the stream head function. *)

Definition hd A (s : stream A) : A :=
  match s with
    | Cons x _ => x
  end.

(** Now we enter a section for the co-induction principle, based on %\index{Park's principle}%Park's principle as introduced in a tutorial by Gim%\'%enez%~\cite{IT}%. *)

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  (** This relation generalizes the theorem we want to prove, defining a set of pairs of streams that we must eventually prove contains the particular pair we care about. *)

  Hypothesis Cons_case_hd : forall s1 s2, R s1 s2 -> hd s1 = hd s2.
  Hypothesis Cons_case_tl : forall s1 s2, R s1 s2 -> R (tl s1) (tl s2).

  (** Two hypotheses characterize what makes a good choice of [R]: it enforces equality of stream heads, and it is %``%#<i>#hereditary#</i>#%''% in the sense that an [R] stream pair passes on "[R]-ness" to its tails.  An established technical term for such a relation is%\index{bisimulation}% _bisimulation_. *)

  (** Now it is straightforward to prove the principle, which says that any stream pair in [R] is equal.  The reader may wish to step through the proof script to see what is going on. *)

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> stream_eq s1 s2.
    cofix; destruct s1; destruct s2; intro.
    generalize (Cons_case_hd H); intro Heq; simpl in Heq; rewrite Heq.
    constructor.
    apply stream_eq_coind.
    apply (Cons_case_tl H).
  Qed.
End stream_eq_coind.

(** To see why this proof is guarded, we can print it and verify that the one co-recursive call is an immediate argument to a constructor. *)

Print stream_eq_coind.

(** We omit the output and proceed to proving [ones_eq''] again.  The only bit of ingenuity is in choosing [R], and in this case the most restrictive predicate works. *)

Theorem ones_eq'' : stream_eq ones ones'.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')); crush.
Qed.

(** Note that this proof achieves the proper reduction behavior via [hd] and [tl], rather than [frob] as in the last proof.  All three functions pattern match on their arguments, catalyzing computation steps.

   Compared to the inductive proofs that we are used to, it still seems unsatisfactory that we had to write out a choice of [R] in the last proof.  An alternate is to capture a common pattern of co-recursion in a more specialized co-induction principle.  For the current example, that pattern is: prove [stream_eq s1 s2] where [s1] and [s2] are defined as their own tails. *)

Section stream_eq_loop.
  Variable A : Type.
  Variables s1 s2 : stream A.

  Hypothesis Cons_case_hd : hd s1 = hd s2.
  Hypothesis loop1 : tl s1 = s1.
  Hypothesis loop2 : tl s2 = s2.

  (** The proof of the principle includes a choice of [R], so that we no longer need to make such choices thereafter. *)

  Theorem stream_eq_loop : stream_eq s1 s2.
    apply (stream_eq_coind (fun s1' s2' => s1' = s1 /\ s2' = s2)); crush.
  Qed.
End stream_eq_loop.

Theorem ones_eq''' : stream_eq ones ones'.
  apply stream_eq_loop; crush.
Qed.
(* end thide *)

(** Let us put [stream_eq_coind] through its paces a bit more, considering two different ways to compute infinite streams of all factorial values.  First, we import the [fact] factorial function from the standard library. *)

Require Import Arith.
Print fact.
(** %\vspace{-.15in}%[[
fact =
fix fact (n : nat) : nat :=
  match n with
  | 0 => 1
  | S n0 => S n0 * fact n0
  end
     : nat -> nat
]]
*)

(** The simplest way to compute the factorial stream involves calling [fact] afresh at each position. *)

CoFixpoint fact_slow' (n : nat) := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

(** A more clever, optimized method maintains an accumulator of the previous factorial, so that each new entry can be computed with a single multiplication. *)

CoFixpoint fact_iter' (cur acc : nat) := Cons acc (fact_iter' (S cur) (acc * cur)).
Definition fact_iter := fact_iter' 2 1.

(** We can verify that the streams are equal up to particular finite bounds. *)

Eval simpl in approx fact_iter 5.
(** %\vspace{-.15in}%[[
     = 1 :: 2 :: 6 :: 24 :: 120 :: nil
     : list nat
]]
*)
Eval simpl in approx fact_slow 5.
(** %\vspace{-.15in}%[[
     = 1 :: 2 :: 6 :: 24 :: 120 :: nil
     : list nat
]]

Now, to prove that the two versions are equivalent, it is helpful to prove (and add as a proof hint) a quick lemma about the computational behavior of [fact].  (I intentionally skip explaining its proof at this point.) *)

(* begin thide *)
Lemma fact_def : forall x n,
  fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)).
  simpl; intros; f_equal; ring.
Qed.

Hint Resolve fact_def.

(** With the hint added, it is easy to prove an auxiliary lemma relating [fact_iter'] and [fact_slow'].  The key bit of ingenuity is introduction of an existential quantifier for the shared parameter [n]. *)

Lemma fact_eq' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intro; apply (stream_eq_coind (fun s1 s2 => exists n, s1 = fact_iter' (S n) (fact n)
    /\ s2 = fact_slow' n)); crush; eauto.
Qed.

(** The final theorem is a direct corollary of [fact_eq']. *)

Theorem fact_eq : stream_eq fact_iter fact_slow.
  apply fact_eq'.
Qed.

(** As in the case of [ones_eq'], we may be unsatisfied that we needed to write down a choice of [R] that seems to duplicate information already present in a lemma statement.  We can facilitate a simpler proof by defining a co-induction principle specialized to goals that begin with single universal quantifiers, and the strategy can be extended in a straightforward way to principles for other counts of quantifiers.  (Our [stream_eq_loop] principle is effectively the instantiation of this technique to zero quantifiers.) *)

Section stream_eq_onequant.
  Variables A B : Type.
  (** We have the types [A], the domain of the one quantifier; and [B], the type of data found in the streams. *)

  Variables f g : A -> stream B.
  (** The two streams we compare must be of the forms [f x] and [g x], for some shared [x].  Note that this falls out naturally when [x] is a shared universally quantified variable in a lemma statement. *)

  Hypothesis Cons_case_hd : forall x, hd (f x) = hd (g x).
  Hypothesis Cons_case_tl : forall x, exists y, tl (f x) = f y /\ tl (g x) = g y.
  (** These conditions are inspired by the bisimulation requirements, with a more general version of the [R] choice we made for [fact_eq'] inlined into the hypotheses of [stream_eq_coind]. *)

  Theorem stream_eq_onequant : forall x, stream_eq (f x) (g x).
    intro; apply (stream_eq_coind (fun s1 s2 => exists x, s1 = f x /\ s2 = g x)); crush; eauto.
  Qed.
End stream_eq_onequant.

Lemma fact_eq'' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  apply stream_eq_onequant; crush; eauto.
Qed.

(** We have arrived at one of our customary automated proofs, thanks to the new principle. *)
(* end thide *)

(** * Simple Modeling of Non-Terminating Programs *)

(** We close the chapter with a quick motivating example for more complex uses of co-inductive types.  We will define a co-inductive semantics for a simple imperative programming language and use that semantics to prove the correctness of a trivial optimization that removes spurious additions by 0.  We follow the technique of%\index{co-inductive big-step operational semantics}% _co-inductive big-step operational semantics_ %\cite{BigStep}%.

   We define a suggestive synonym for [nat], as we will consider programs over infinitely many variables, represented as [nat]s. *)

Definition var := nat.

(** We define a type [vars] of maps from variables to values.  To define a function [set] for setting a variable's value in a map, we use the standard library function [beq_nat] for comparing natural numbers. *)

Definition vars := var -> nat.
Definition set (vs : vars) (v : var) (n : nat) : vars :=
  fun v' => if beq_nat v v' then n else vs v'.

(** We define a simple arithmetic expression language with variables, and we give it a semantics via an interpreter. *)

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp.

Fixpoint evalExp (vs : vars) (e : exp) : nat :=
  match e with
    | Const n => n
    | Var v => vs v
    | Plus e1 e2 => evalExp vs e1 + evalExp vs e2
  end.

(** Finally, we define a language of commands.  It includes variable assignment, sequencing, and a <<while>> form that repeats as long as its test expression evaluates to a nonzero value. *)

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| While : exp -> cmd -> cmd.

(** We could define an inductive relation to characterize the results of command evaluation.  However, such a relation would not capture _nonterminating_ executions.  With a co-inductive relation, we can capture both cases.  The parameters of the relation are an initial state, a command, and a final state.  A program that does not terminate in a particular initial state is related to _any_ final state.  For more realistic languages than this one, it is often possible for programs to _crash_, in which case a semantics would generally relate their executions to no final states; so relating safely non-terminating programs to all final states provides a crucial distinction. *)

CoInductive evalCmd : vars -> cmd -> vars -> Prop :=
| EvalAssign : forall vs v e, evalCmd vs (Assign v e) (set vs v (evalExp vs e))
| EvalSeq : forall vs1 vs2 vs3 c1 c2, evalCmd vs1 c1 vs2
  -> evalCmd vs2 c2 vs3
  -> evalCmd vs1 (Seq c1 c2) vs3
| EvalWhileFalse : forall vs e c, evalExp vs e = 0
  -> evalCmd vs (While e c) vs
| EvalWhileTrue : forall vs1 vs2 vs3 e c, evalExp vs1 e <> 0
  -> evalCmd vs1 c vs2
  -> evalCmd vs2 (While e c) vs3
  -> evalCmd vs1 (While e c) vs3.

(** Having learned our lesson in the last section, before proceeding, we build a co-induction principle for [evalCmd]. *)

Section evalCmd_coind.
  Variable R : vars -> cmd -> vars -> Prop.

  Hypothesis AssignCase : forall vs1 vs2 v e, R vs1 (Assign v e) vs2
    -> vs2 = set vs1 v (evalExp vs1 e).

  Hypothesis SeqCase : forall vs1 vs3 c1 c2, R vs1 (Seq c1 c2) vs3
    -> exists vs2, R vs1 c1 vs2 /\ R vs2 c2 vs3.

  Hypothesis WhileCase : forall vs1 vs3 e c, R vs1 (While e c) vs3
    -> (evalExp vs1 e = 0 /\ vs3 = vs1)
    \/ exists vs2, evalExp vs1 e <> 0 /\ R vs1 c vs2 /\ R vs2 (While e c) vs3.

  (** The proof is routine.  We make use of a form of %\index{tactics!destruct}%[destruct] that takes an%\index{intro pattern}% _intro pattern_ in an [as] clause.  These patterns control how deeply we break apart the components of an inductive value, and we refer the reader to the Coq manual for more details. *)

  Theorem evalCmd_coind : forall vs1 c vs2, R vs1 c vs2 -> evalCmd vs1 c vs2.
    cofix; intros; destruct c.
    rewrite (AssignCase H); constructor.
    destruct (SeqCase H) as [? [? ?]]; econstructor; eauto.
    destruct (WhileCase H) as [[? ?] | [? [? [? ?]]]]; subst; econstructor; eauto.
  Qed.
End evalCmd_coind.

(** Now that we have a co-induction principle, we should use it to prove something!  Our example is a trivial program optimizer that finds places to replace [0 + e] with [e]. *)

Fixpoint optExp (e : exp) : exp :=
  match e with
    | Plus (Const 0) e => optExp e
    | Plus e1 e2 => Plus (optExp e1) (optExp e2)
    | _ => e
  end.

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
    | Assign v e => Assign v (optExp e)
    | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
    | While e c => While (optExp e) (optCmd c)
  end.

(** Before proving correctness of [optCmd], we prove a lemma about [optExp].  This is where we have to do the most work, choosing pattern match opportunities automatically. *)

(* begin thide *)
Lemma optExp_correct : forall vs e, evalExp vs (optExp e) = evalExp vs e.
  induction e; crush;
    repeat (match goal with
              | [ |- context[match ?E with Const _ => _ | _ => _ end] ] => destruct E
              | [ |- context[match ?E with O => _ | S _ => _ end] ] => destruct E
            end; crush).
Qed.

Hint Rewrite optExp_correct.

(** The final theorem is easy to establish, using our co-induction principle and a bit of Ltac smarts that we leave unexplained for now.  Curious readers can consult the Coq manual, or wait for the later chapters of this book about proof automation.  At a high level, we show inclusions between behaviors, going in both directions between original and optimized programs. *)

Ltac finisher := match goal with
                   | [ H : evalCmd _ _ _ |- _ ] => ((inversion H; [])
                     || (inversion H; [|])); subst
                 end; crush; eauto 10.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 c vs2
  -> evalCmd vs1 (optCmd c) vs2.
  intros; apply (evalCmd_coind (fun vs1 c' vs2 => exists c, evalCmd vs1 c vs2
    /\ c' = optCmd c)); eauto; crush;
    match goal with
      | [ H : _ = optCmd ?E |- _ ] => destruct E; simpl in *; discriminate
        || injection H; intros; subst
    end; finisher.
Qed.

Lemma optCmd_correct2 : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
  -> evalCmd vs1 c vs2.
  intros; apply (evalCmd_coind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2));
    crush; finisher.
Qed.

Theorem optCmd_correct : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
  <-> evalCmd vs1 c vs2.
  intuition; apply optCmd_correct1 || apply optCmd_correct2; assumption.
Qed.
(* end thide *)

(** In this form, the theorem tells us that the optimizer preserves observable behavior of both terminating and nonterminating programs, but we did not have to do more work than for the case of terminating programs alone.  We merely took the natural inductive definition for terminating executions, made it co-inductive, and applied the appropriate co-induction principle.  Curious readers might experiment with adding command constructs like <<if>>; the same proof script should continue working, after the co-induction principle is extended to the new evaluation rules. *)


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

Require Import List.

Require Import list_utils finite.

Set Implicit Arguments.

Section representation_of_rules.

  (* Representation of rules generated by a type of instances *)

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

  (** A rule is a relation between conclusions and lists of premises denoted

                    H1 .... Hn
                    ----------
                        C

  *)

  Variables (r : X -> list X -> Prop).

  (** A representation for a rule is a map from a type a parameters
      to instances a rules

                  H1(i) .... Hn(i)
                  ----------------
                        C(i)

  *)

  Variables (I : Type) (f : I -> X * list X).

  (* Every parameter gives a instance of the rule *)

  Definition soundly_represents :=
    forall i, match f i with (c,hs) => r c hs end.

  (* for any given conclusion C, there is a finite set of parameters
     (represented by a list) such that any rule instance with conclusion C
     belongs to the image of this finite set of parameters *)

  Definition finitely_represents :=
    forall c, { ll | forall hs, r c hs <-> exists i, f i = (c,hs) /\ In i ll }.

  (* soundly and finitely represented rules are finitary *)

  Fact rule_finite_t : soundly_represents -> finitely_represents -> forall c, finite_t (r c).
  Proof.
    intros Hf1 Hf2 c.
    destruct (Hf2 c) as (ll & Hll).
    exists (map (fun i => snd (f i)) (filter (fun i => if eqX_dec (fst (f i)) c then true else false) ll)).
    intros hs.
    rewrite in_map_iff.
    rewrite Hll.
    split; intros (i & H1 & H2); exists i.
    apply filter_In in H2.
    destruct H2 as (H2 & H3); split; auto.
    rewrite (surjective_pairing (f i)), H1.
    destruct (eqX_dec (fst (f i)) c).
    f_equal; auto.
    discriminate.
    split.
    rewrite H1; auto.
    apply filter_In.
    split; auto.
    rewrite H1; simpl.
    destruct (eqX_dec c c); auto.
  Qed.

  (* finitely represented rules can be reifed, ie it is possible to recover
     the parameter from the instance *)

  Fact rule_reif : finitely_represents -> forall c l, r c l -> { i | f i = (c,l) }.
  Proof.
    intros H c l.
    destruct (H c) as (ll & Hll).
    intros H1.
    rewrite Hll in H1.
    apply list_reif_dec in H1.
    destruct H1 as (i & ? & ?); exists i; auto.
    intro; decide equality.
    apply list_eq_dec.
    intros; apply eqX_dec.
  Qed.

  (* finitely represented rules are decidable *)

  Fact rule_dec : finitely_represents -> forall c l, { r c l } + { ~ r c l }.
  Proof.
    intros H c l.
    destruct (H c) as (ll & Hll).
    destruct in_dec with (a := (c,l)) (l := map f ll) as [ H1 | H1 ].
    intros; decide equality.
    apply list_eq_dec; intros; apply eqX_dec.
    left; apply Hll; apply in_map_iff in H1; auto.
    right; contradict H1; apply Hll in H1; apply in_map_iff; auto.
  Qed.

End representation_of_rules.


Require Import Lists.List.
Require Import Decidable.

Require Import Top.FinSet.FinMod.
Require Import Top.FinSet.FinSet.
Require Import Top.FinSet.ProjSet.

Require Import Top.Terms.Term.
Require Import Top.Terms.Subst.
Require Import Top.Terms.FreeVars.

(* for dec_proc_to_sumbool: probably refactor this! *)
Require Import Top.Terms.VecUtils.

(**

    At the start of Lemma 2.10, Eder investigates which variables are
    bound in the image of some substitution. That is, he looks at the
    set of terms that are the image of some variable and then asks
    which variables don't appear as free variables in any of them.

    If the substitution is finite, it fixes most variables and these
    ones are definitely not bound in the image: the image will contain
    a term for the original variable, which definitely contains itself
    as a free variable! However a variable that isn't fixed isn't
    necessarily bound: it, or some other variable might be mapped to a
    term that contains it.

    In this module, we define a type for the variables that are bound
    in the image of a substitution. We then define a decision
    procedure for checking whether a variable is so bound and check
    it's correctness (this turns out to be quite hard!).

    Finally, we show that the variables bound in the image of a finite
    substitution are a finite set.

*)

Section subst_bound_vars.
  Variable L : lType.

  Variable usigma : Subst L.

  Definition is_bound_in_image (v : Term.V L) : Prop :=
    ~ termset_fv v (subst_im L usigma).

  Definition bound_in_image : Type := sig is_bound_in_image.

  Definition bound_image_var : bound_in_image -> Term.V L := @proj1_sig _ _.

  (**

    To prove that the projection is finite, we'd need a list of bound
    variables. We've almost got that, by looking at the variables that are in
    the domain of sigma: this is a finite list by [sigma_finiteH]. But some of
    those might still end up free (suppose sigma is actually a variable
    permutation).

    Fortunately, we have a finite list of ways in which a variable in the
    domain of sigma can turn out to be free, so we can write a decidable
    function to check that it isn't. Use [check_bound_in_image] with a full
    list of elements for the domain of sigma (which exists because it's a
    [fin_subst]).

   *)

  Fixpoint check_bound_in_image_lst
           (decV : forall v w : Term.V L, {v = w} + {v <> w})
           (v : Term.V L) (vs : list (Term.V L))
    : bool :=
    match vs with
    | nil => true
    | cons w vs' => andb (negb (check_term_fv decV v (usigma w)))
                         (check_bound_in_image_lst decV v vs')
    end.

  Definition check_bound_in_image
             (decV : forall v w : Term.V L, {v = w} + {v <> w})
             (vs : list (Term.V L)) (v : Term.V L)
    : bool :=
    andb (if dec_mod_elt_varTerm decV usigma v then true else false)
         (check_bound_in_image_lst decV v vs).

  (**

    What does [check_bound_in_image] actually check? This first lemma turns
    (not) bound in image into something that looks a bit more like the shape of
    [check_bound_in_image]. The point is that we know any variable that is
    fixed by sigma is free in the image of sigma (because it appears as
    itself). A variable that isn't fixed by sigma might be free, so long as
    neither it or any other variable is mapped to something containing it.

   *)
  Lemma free_in_image_iff_dom_elt_hits_it
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        v
    : termset_fv v (subst_im L usigma) <->
      (usigma v = varTerm L v \/
       (exists w, mod_elt (varTerm L) usigma w /\
                  term_fv v (usigma w))).
  Proof.
    split.
    - destruct 1 as [ t [ imH fvH ] ].
      destruct imH as [ w twH ].
      rewrite twH in fvH; clear twH t.
      destruct (dec_mod_elt_varTerm decV usigma v) as [ eltH | ].
      + right; exists w; split; auto.
        destruct (dec_mod_elt_varTerm decV usigma w) as [ | eqwH ]; auto.
        rewrite eqwH in fvH.
        simpl in fvH; rewrite <- fvH; auto.
      + left; auto.
    - destruct 1 as [ fixedH | [ w [ eltH fvH ] ] ].
      + exists (usigma v).
        split.
        * exists v; auto.
        * rewrite fixedH; simpl; auto.
      + exists (usigma w); split; auto.
        exists w; auto.
  Qed.

  (** The lemma above will be enough to show that [check_bound_in_image] is
      correct if [check_bound_in_image_lst] is. For that, we prove each
      direction separately by induction over the list. *)

  Lemma check_bound_in_image_lst_false_intro
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (v w : Term.V L)
        (freeH : term_fv v (usigma w))
        (vs : list (Term.V L))
    : In w vs -> check_bound_in_image_lst decV v vs = false.
  Proof.
    induction vs as [ | u vs IH ]; try contradiction.
    destruct 1 as [ uwH | inH ].
    - rewrite <- uwH in freeH.
      apply Bool.andb_false_intro1.
      rewrite Bool.negb_false_iff.
      rewrite <- (check_term_fv_correct decV v (usigma u)).
      auto.
    - specialize (IH inH); clear inH.
      simpl; apply Bool.andb_false_intro2; auto.
  Qed.

  Lemma check_bound_in_image_lst_false_elim
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (v : Term.V L)
        (vs : list (Term.V L))
    : check_bound_in_image_lst decV v vs = false ->
      exists w, In w vs /\ term_fv v (usigma w).
  Proof.
    induction vs as [ | u vs IH ].
    - intro H; contradiction (Bool.diff_true_false H).
    - intro bd_falseH; simpl in bd_falseH.
      case (Bool.andb_false_elim _ _ bd_falseH); clear bd_falseH.
      + rewrite Bool.negb_false_iff.
        rewrite <- (check_term_fv_correct decV v (usigma u)).
        eauto with datatypes.
      + intro H; destruct (IH H) as [ w [ inH fvH ] ].
        eauto with datatypes.
  Qed.

  (** We can finally show that [check_bound_in_image] does what we
      want. But we actually go via a "check_free_in_image" helper
      function. The point is that this will eventually let us avoid a
      double negation in dec_bound_in_image.

      After a bit of rewriting, the proof starts by applying
      [free_in_image_iff_dom_elt_hits_it] to split up the proposition
      part. Then there's a certain amount of unpacking on each side of
      the iff until we can finally apply the intro/elim rules we just
      proved. *)

  Definition check_free_in_image
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (vs : list (Term.V L)) (v : Term.V L)
    : bool := negb (check_bound_in_image decV vs v).

  Lemma check_free_in_image_correct
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (dom_elts : list (mod_dom (varTerm L) usigma))
        (fullH : FullProj md_elt dom_elts)
        (v : Term.V L)
    : termset_fv v (subst_im L usigma) <->
      is_true (check_free_in_image decV (map md_elt dom_elts) v).
  Proof.
    unfold check_free_in_image, is_true; rewrite Bool.negb_true_iff.
    rewrite (free_in_image_iff_dom_elt_hits_it decV v); split.
    - destruct 1 as [ fixedH | exH ]; unfold check_bound_in_image.
      + case (dec_mod_elt_varTerm decV usigma v); [ contradiction | auto ].
      + apply Bool.andb_false_intro2.
        destruct exH as [ w [ eltwH fvH ] ].
        assert (In w (map md_elt dom_elts)) as inH;
          [ exact (fullH (exist _ w eltwH)) | ]; clear fullH eltwH.
        apply (check_bound_in_image_lst_false_intro decV v w fvH _ inH).
    - intro check_falseH.
      case (Bool.andb_false_elim _ _ check_falseH); simpl; clear check_falseH.
      + destruct (dec_mod_elt_varTerm decV usigma v); auto.
        intro tfH; contradiction Bool.diff_true_false.
      + intro check_lstH.
        destruct (check_bound_in_image_lst_false_elim _ _ _ check_lstH)
          as [ w [ inH fvH ] ].
        right; exists w; split; auto.
        rewrite (in_map_iff md_elt dom_elts w) in inH.
        destruct inH as [ md [ md_eltH inH ] ].
        rewrite <- md_eltH.
        unfold md_elt; apply proj2_sig.
  Qed.

  (** We proved the free version above to avoid a double negative, but
      can unpack it to get the equivalent statement about bound
      variables. *)

  Lemma check_bound_in_image_correct
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (dom_elts : list (mod_dom (varTerm L) usigma))
        (fullH : FullProj md_elt dom_elts)
        (v : Term.V L)
    : is_bound_in_image v <->
      is_true (check_bound_in_image decV (map md_elt dom_elts) v).
  Proof.
    unfold is_bound_in_image, is_true.
    rewrite <- Bool.negb_false_iff, <- Bool.not_true_iff_false.
    fold (check_free_in_image decV (map md_elt dom_elts) v).
    apply not_iff_compat, check_free_in_image_correct; auto.
  Qed.

  (** With this, we can finally prove that [is_bound_in_image] is
      decidable. We have to pack this into a sumbool as shown so that
      we can use it to define the maps in the finiteness proof
      below. *)
  Definition dec_free_in_image
             (decV : forall v w : Term.V L, {v = w} + {v <> w})
             (dom_elts : list (mod_dom (varTerm L) usigma))
             (fullH : FullProj md_elt dom_elts)
             (v : Term.V L)
    : {termset_fv v (subst_im L usigma)} + {is_bound_in_image v} :=
    (dec_proc_to_sumbool (check_free_in_image_correct decV dom_elts fullH) v).

  Definition dec_bound_in_image
             (decV : forall v w : Term.V L, {v = w} + {v <> w})
             (dom_elts : list (mod_dom (varTerm L) usigma))
             (fullH : FullProj md_elt dom_elts)
             (v : Term.V L)
    : {is_bound_in_image v} + {termset_fv v (subst_im L usigma)} :=
    match dec_free_in_image decV dom_elts fullH v with
    | left H => right H
    | right H => left H
    end.

  (** We have a finite list of variables in the domain of sigma. We
      know that every variable that is bound in the image is one of
      these variables, so we have a surjection from the domain of
      sigma to the option type for variables that are bound in the
      image (mapping those that turn out not to be to None).

      The "downstairs" map (on variables) is the identity on those
      that are bound in the image and maps others to None.

   *)
  Local Definition lo_map
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (elts : list (Term.V L))
        (v : Term.V L)
    : option (Term.V L) :=
    if check_bound_in_image decV elts v then Some v else None.

  (** For the "upstairs" map, we need the full decision check (because
      we need to know the object we make is indeed bound). *)
  Local Definition hi_map
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        (dom_elts : list (mod_dom (varTerm L) usigma))
        (fullH : FullProj md_elt dom_elts)
        (dom_elt : mod_dom (varTerm L) usigma)
    : option bound_in_image :=
    match dec_bound_in_image decV dom_elts fullH (md_elt dom_elt) with
    | left bdH => Some (exist _ (proj1_sig dom_elt) bdH)
    | right _ => None
    end.

  Lemma not_fixed_if_bound_in_image
        (decV : forall v w : Term.V L, {v = w} + {v <> w})
        v
    : is_bound_in_image v -> mod_elt (varTerm L) usigma v.
  Proof.
    intros boundH fixedH.
    destruct (free_in_image_iff_dom_elt_hits_it decV v) as [ _ H ].
    specialize (H (or_introl fixedH)).
    exact (boundH H).
  Qed.
End subst_bound_vars.

Lemma finite_bound_in_image
      {L}
      (decV : forall v w : Term.V L, {v = w} + {v <> w})
      (sigma : fin_subst L)
  : FiniteProj (bound_image_var L (fin_subst_subst L sigma)).
Proof.
  destruct sigma as [ usig [ dom_elts fullH ] ]; simpl.
  apply (finite_surj_option (bound_image_var L usig)
                            (hi_map L usig decV dom_elts fullH)
                            (lo_map L usig decV (map md_elt dom_elts))
                            (exist _ dom_elts fullH)).
  - intro d.
    destruct (check_bound_in_image_correct L usig decV
                                           dom_elts fullH (md_elt d))
      as [ bd2chk chk2bd ].
    unfold hi_map, lo_map.
    set (chk := (check_bound_in_image L usig decV
                                      (map md_elt dom_elts) (md_elt d))).
    fold chk in bd2chk, chk2bd.
    destruct (dec_bound_in_image L usig decV
                                 dom_elts fullH (md_elt d))
      as [ bdH | fvH ];
      simpl.
    + rewrite (bd2chk bdH); reflexivity.
    + case_eq chk; auto; intro H; contradiction (chk2bd H).
  - intro bd.
    destruct bd as [ v bdH ].
    exists (exist _ _ (not_fixed_if_bound_in_image L usig decV v bdH)); simpl.
    unfold lo_map.
    case_eq (check_bound_in_image L usig decV (map md_elt dom_elts) v); auto.
    rewrite <- Bool.not_true_iff_false.
    rewrite <- (check_bound_in_image_correct L usig decV
                                             dom_elts fullH v); tauto.
Qed.


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

(** This is Hurkens paradox [Hurkens] in system U-, adapted by Herman
    Geuvers [Geuvers] to show the inconsistency in the pure calculus of
    constructions of a retract from Prop into a small type.

    References:

    - [Hurkens] A. J. Hurkens, "A simplification of Girard's paradox",
      Proceedings of the 2nd international conference Typed Lambda-Calculi
      and Applications (TLCA'95), 1995.

    - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001
      (see http://www.cs.kun.nl/~herman/note.ps.gz).
*)

Section Paradox.

Variable bool : Prop.
Variable p2b : Prop -> bool.
Variable b2p : bool -> Prop.
Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A.
Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A).
Variable B : Prop.

Definition V := forall A:Prop, ((A -> bool) -> A -> bool) -> A -> bool.
Definition U := V -> bool.
Definition sb (z:V) : V := fun A r a => r (z A r) a.
Definition le (i:U -> bool) (x:U) : bool :=
  x (fun A r a => i (fun v => sb v A r a)).
Definition induct (i:U -> bool) : Prop :=
  forall x:U, b2p (le i x) -> b2p (i x).
Definition WF : U := fun z => p2b (induct (z U le)).
Definition I (x:U) : Prop :=
  (forall i:U -> bool, b2p (le i x) -> b2p (i (fun v => sb v U le x))) -> B.

Lemma Omega : forall i:U -> bool, induct i -> b2p (i WF).
Proof.
intros i y.
apply y.
unfold le, WF, induct in |- *.
apply p2p2.
intros x H0.
apply y.
exact H0.
Qed.

Lemma lemma1 : induct (fun u => p2b (I u)).
Proof.
unfold induct in |- *.
intros x p.
apply (p2p2 (I x)).
intro q.
apply (p2p1 (I (fun v:V => sb v U le x)) (q (fun u => p2b (I u)) p)).
intro i.
apply q with (i := fun y => i (fun v:V => sb v U le y)).
Qed.

Lemma lemma2 : (forall i:U -> bool, induct i -> b2p (i WF)) -> B.
Proof.
intro x.
apply (p2p1 (I WF) (x (fun u => p2b (I u)) lemma1)).
intros i H0.
apply (x (fun y => i (fun v => sb v U le y))).
apply (p2p1 _ H0).
Qed.

Theorem paradox : B.
Proof.
exact (lemma2 Omega).
Qed.

End Paradox.


Add LoadPath "megacz-coq-categories/build".

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Unicode.Utf8.

Require Import Categories_ch1_3.

Definition Map : Type -> Type -> Type
  := fun a b : Type => a -> b.

Definition map_id : ∀ a : Type, Map a a
  := (fun a : Type => (fun x => x)).

Definition map_comp : ∀ a b c : Type, Map a b -> Map b c -> Map a c
  := fun a b c r1 r2 x => r2 (r1 x).

Definition map_eqv : forall a b : Type, Map a b -> Map a b -> Prop
  := fun a b r1 r2 => forall x, r1 x = r2 x.

Theorem sets_category : Category Type Map.
Proof.
  apply (@Build_Category Type Map map_id map_comp map_eqv).
  intros.
  apply Build_Equivalence.
  intro.
  unfold map_eqv.
  intros.
  reflexivity.

  intro.
  unfold map_eqv.
  intros.
  symmetry.
  auto.

  intro.
  unfold map_eqv.
  intros.
  transitivity (y x0).
  auto.
  auto.

  intros.
  unfold Proper.
  unfold respectful.
  unfold map_eqv.
  unfold map_comp.
  intros.
  congruence.

  unfold map_id.
  unfold map_comp.
  unfold map_eqv.
  intros.
  reflexivity.

  unfold map_id.
  unfold map_comp.
  unfold map_eqv.
  intros.
  reflexivity.

  unfold map_comp.
  unfold map_eqv.
  intros.
  reflexivity.
Defined.

Require Import Rel.
Require Import Functors_ch1_4.

Definition sets_fobj : sets_category -> relation_category
  := fun s => s.

Definition sets_fmor :
  forall a b : sets_category,
    (a ~~{sets_category}~~> b) -> ((sets_fobj a) ~~{relation_category}~~> (sets_fobj b))
  := fun (a b : sets_category) (f : a ~> b) x y => f x = y.

Theorem sets_functor : Functor sets_category relation_category sets_fobj.
Proof.
  apply (Build_Functor _ _ _ _ _ _ sets_fobj sets_fmor).
  intros.
  unfold sets_fmor.
  red.
  simpl.
  unfold rel_eqv.
  intros.
  rewrite (H x).
  tauto.

  intros.
  red.
  simpl.
  unfold rel_eqv, sets_fmor, map_id, rel_id, sets_fobj.
  tauto.

  intros.
  unfold sets_fmor.
  red.
  simpl.
  unfold rel_eqv, sets_fmor, map_id, rel_id, sets_fobj.
  intros.
  unfold rel_comp, map_comp.
  split.
  intros.
  destruct H.
  destruct H.
  congruence.
  intros.
  exists (f x).
  tauto.
Defined.


From NaturalNumbers Require Export Base Tutorial Addition Multiplication Power.

(* Level 0 data *)
(* name the `exact` tactic *)
(* tactics exact *)
(* available false *)
(* Level 0 prologue *)
(*
We have learnt a few tactics to manipulate expressions,
but those will not be of much to manipulate the main object
of this world: functions! To manipulate functions, we need
to learn about the tactics `exact`, `intro` and `apply`.

Ultimately, we will use these things to show theorems about
`mynat`, but it is not necessary to use this specific type,
as the statements about functions will hold on any type!

In this world, we will use capital letters (`P`, `Q`, `R`)
to denote types, and lowercase letters `h`, `j`, `k` for
functions between them.

A new kind of goal

So far, we have only seen goals in the form of equations,
but a goal can also be a type, where we wish to find an
instance of a certain type. You may have already seen that the
goal for this level looks like
```plaintext
  P : Type
  Q : Type
  p : P
  h : P -> Q
  ============================
  Q
```
and the point is that we wish to find some element of type `Q`.

The `exact` tactic

If we can construct an element of the goal type from our assumptions,
we can use the `exact` tactic to finish the goal. For example,
if we have the context like the one above, we could obtain
an element of type `Q`, namely `h(p)`. We write
```
exact (h p).
```
to close the goal. Try it out!
*)
Example level0 (P Q : Type) (p : P) (h : P -> Q) : Q.
Proof.
    exact (h p).
Qed.
(* Level epilogue *)
(* Level end *)

Definition III := S II.
Notation "3" := III.

(* Level 1 data *)
(* name the `intro` tactic *)
(* tactics intro *)
(* available false *)
(* Level 1 prologue *)
(*
The goal might also be a function type. In this level,
it is a function `mynat -> mynat`. In order to define
a function, we need to know what it does to every element.

In order to define a function in this way in our proof,
we use the `intro` tactic. Suppose we have `X Y : Type`, and
the goal is of type `X -> Y`. We could type `intro x`, and
we get an `x : X` in our assumptions, and the goal will transform
to giving an element of `Y`.

As a rule of thumb: if the goal is a function type (with `->`),
typing `intro p` will help.

For example in this lemma, try to define a function that sends `n : mynat`
to `3 * n + 2` (don't worry, I have defined `3` for you!). Do this by
typing `intro n.`, to give us an `n : mynat` in the assumptions, and then
typing `exact (3 * n + 2).` to present a constructed element of `mynat`.

Try it out!
*)
Example level1 : mynat -> mynat.
Proof.
    intro n.
    exact (3 * n + 2).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 2 data *)
(* name the `specialize` tactic *)
(* tactics specialize *)
(* available false *)
(* Level 2 prologue *)
(*
We might have a whole lot of functions, like in the diagram below:
```plaintext
        h       i
p : P ----> Q ----> R
            |
            |j
            |
        k   v   l
    S ----> T ----> U
```
and so it might be cumbersome and a bit unreadable to type
```
exact (l(j(h(p)))).
```
in a single expression. To make this easier,
we use the `specialize` tactic. We can type
```
specialize (h p) as q.
```
to construct `q : Q` and add it to our assumptions, so
we can use it in further expressions. For example, we can
then use it to construct
```
specialize (j q : T) as t.
```
where we explicitly say that it is in `T` (which is kind of unnecessary,
but possible if you want!).

Remember to use the `exact` tactic once you have constructed an element
of type `U` below!
*)
Example level2 (P Q R S T U : Type)
    (p : P)
    (h : P -> Q)
    (i : Q -> R)
    (j : Q -> T)
    (k : S -> T)
    (l : T -> U)
    : U.
Proof.
    specialize (h p) as q.
    specialize (j q : T) as t.
    specialize (l(t)) as u.
    exact u.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 3 data *)
(* name the `apply` tactic *)
(* tactics apply *)
(* available false *)
(* Level 3 prologue *)
(*
Let's try this again, but in a different way. We have the same diagram
```plaintext
        h       i
p : P ----> Q ----> R
            |
            |j
            |
        k   v   l
    S ----> T ----> U
```
but now, instead of using `specialize`, which gives us a very long
list of hypothesis anyway, we use the `apply` tactic. Basically, this
allows us to "reason backwards". If the goal is to construct an element
of type `U`, typing
```
apply l.
```
tells us that this would be the same as constructing an element of `T`,
as we would be able to apply `l` to this element to obtain an element
of type `U`. Notice how the goal changes from `U` to `T` by typing this
tactic.

Try to keep `apply`ing functions to turn the goal into `P`, so we can
simply `exact p` to finish the proof.
*)
Example level3 (P Q R S T U : Type)
    (p : P)
    (h : P -> Q)
    (i : Q -> R)
    (j : Q -> T)
    (k : S -> T)
    (l : T -> U)
    : U.
Proof.
    apply l.
    apply j, h.
    exact p.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 4 data *)
(* name `P -> (Q -> P)` *)
(* tactics apply *)
(* available false *)
(* Level 4 prologue *)
(*
In this level, we want to construct a function `P -> (Q -> P)`.

Let's think about how to proceed. Our rule of thumb tells us we
want to construct a function, so we should probably type `intro p`
to get `p : P` in our assumptions, and turn our goal into `Q -> P`.

Can you already tell what to do next? That's right, follow our rule of
thumb again, and typing `intro q` to obtain `q : Q` and transform
our goal into `P`. Now we can simply `exact p` to finish our proof.

The `intros` tactic

Instead of individually introducing `p` and `q`, you could also type
```
intros p q.
```
to do them both in one line!

Try it yourself!
*)
Example level4 (P Q : Type) : P -> (Q -> P).
Proof.
    intros p q.
    exact p.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 5 data *)
(* name `(P -> (Q -> R)) -> ((P -> Q) -> (P -> R))` *)
(* tactics apply *)
(* available false *)
(* Level 5 prologue *)
(*
You can solve this level completely with `intro`, `apply` and `exact`.
However, it may happen that `apply`ing a function of type `P -> Q -> R`
produces two subgoals. If you're proving it this way, remember to use
dashes (these: `-`) to specifiy that you're working in a subgoal!
*)
Example level5 (P Q R : Type) : (P -> (Q -> R)) -> ((P -> Q) -> (P -> R)).
Proof.
    intros j f p.
    apply j.
    - exact p.
    - exact (f p).
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 6 data *)
(* name `(P -> Q) -> ((Q -> F) -> (P -> F))` *)
(* tactics apply *)
(* available false *)
(* Level 6 prologue *)
(*
Notice that we are not really getting any useful theorems...
They don't even show up in the theorem window on the left.
Oh well, it is useful practice, try to solve this one!
*)
Example level6 (P Q F : Type) : (P -> Q) -> ((Q -> F) -> (P -> F)).
Proof.
    intros f g h.
    apply g, f.
    exact h.
Qed.
(* Level epilogue *)
(* Level end *)

Require Import Init.Datatypes.

(* todo: unimath empty type / actual empty type? *)
Definition empty := Empty_set.

(* Level 7 data *)
(* name `(P -> Q) -> ((Q -> empty) -> (P -> empty))` *)
(* tactics apply *)
(* available false *)
(* Level 7 prologue *)
(*
In this level, we have replaced `F` with `empty`, the empty type.
Your goal might end up being to construct an element of the empty type!
Of course this is only possible because your assumptions might hold
some function to the empty type as well.
This may seem contradictory, but it all checks out!

Try it out, it should be similar to the previous level.
*)
Example level7 (P Q : Type) : (P -> Q) -> ((Q -> empty) -> (P -> empty)).
Proof.
    intros f g h.
    apply g, f.
    exact h.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 8 data *)
(* name a big maze (boss level!)*)
(* tactics apply *)
(* available false *)
(* Level 8 prologue *)
(*
Just to finish it all off, I give you a big maze to solve.
You can of course do it forwards and backwards, or both at the
same time. If you want, you can even draw a diagram to visualize
what is going on.
*)
Example level8 (A B C D E F G H I J K L : Type)
    (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.
    intro a.
    now apply f15, f11, f9, f8, f5, f2, f1.
Qed.
(* Level epilogue *)
(*
Off to Proposition World! The levels there may seem
a bit familiar to you if you have done all the levels in this world...
*)
(* Level end *)


Require Import Strings.String.
Local Open Scope string_scope.
Scheme Equality for string.
Require Import Arith.
Require Import Ascii.

(*Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.*)

Delimit Scope string_scope with string.
Local Open Scope string_scope.

(* Environment *)

Definition Env := string -> nat.
Definition env1 : Env :=
  fun x =>
    if (string_eq_dec x "n")
    then 10
    else 0.
Check env1.

Compute (env1 "coq").
Definition update (env : Env)
           (x : string) (v : nat) : Env :=
  fun y =>
    if (string_eq_dec y x)
    then v
    else (env y).

Definition Env2 := string -> string.
Definition env2 : Env2 :=
  fun x =>
    if (string_eq_dec x "n")
    then ""
    else "".
Check env2.

Definition update2 (env : Env2)
           (x : string) (v : string) : Env2 :=
  fun y =>
    if (string_eq_dec y x)
    then v
    else (env y).

Inductive value :=
| undef : value
| nat_val : nat -> value
| string_val : string -> value.

Scheme Equality for value.

Open Scope char_scope.

Definition charToNat (c : ascii) : nat :=
  match c with
    | "0" => 0
    | "1" => 1
    | "2" => 2
    | "3" => 3
    | "4" => 4
    | "5" => 5
    | "6" => 6
    | "7" => 7
    | "8" => 8
    | "9" => 9
    | _ => 0
  end.

Open Scope string_scope.

Fixpoint read (s : string) (num : nat) : nat :=
  match s with
    | "" => num
    | String c s' =>
      match charToNat c with
        | n => read s' (10*num+n)
      end
  end.

Definition readNat (s : string) : nat :=
  read s 0.

Definition natToChar (n : nat) : ascii :=
  match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
    | 8 => "8"
    | _ => "9"
  end.

Fixpoint write (check n : nat) (s : string) : string :=
  let s' := String (natToChar (Nat.modulo n 10)) s in
  match check with
    | 0 => s'
    | S check' =>
      match (Nat.div n 10) with
        | 0 => s'
        | n' => write check' n' s'
      end
  end.

Definition writeNat (n : nat) : string :=
  write n n "".

Notation "atoi( X )" := (readNat X) (at level 94).
Notation "itoa( X )" := (writeNat X) (at level 94).
Compute atoi("32").
Compute itoa(121).

Notation "S [ V /' X ]" := (update S X V) (at level 0).

Inductive AExp :=
| avar : string -> AExp
| anum : nat -> AExp
| aplus : AExp -> AExp -> AExp
| amin : AExp -> AExp -> AExp
| adiv : AExp -> AExp -> AExp
| amod : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp
| apow : AExp -> AExp.

Notation "A +' B" := (aplus A B) (at level 48).
Notation "A -' B" := (amin A B) (at level 48).
Notation "A /' B" := (adiv A B) (at level 46).
Notation "A %' B" := (amod A B) (at level 46).
Notation "pow( A )" := (apow A) (at level 60).
Notation "A *' B" := (amul A B) (at level 46).
Coercion anum : nat >-> AExp.
Coercion avar : string >-> AExp.
Check (3 +' 3 *' 4).
Check (6 +' 2 *' "n").
Check (21 -' "n").
Check (21 /' 3).
Check (21 %' 3).
Check (pow(3)).
Compute(3 +' 3).
Compute (pow(3)).

Fixpoint divmod x y q u :=
  match x with
    | 0 => (q,u)
    | S x' => match u with
                | 0 => divmod x' y (S q) y
                | S u' => divmod x' y q u'
              end
  end.

Definition div x y :=
  match y with
    | 0 => y
    | S y' => fst (divmod x y' 0 y')
  end.

Definition modulo x y :=
  match y with
    | 0 => y
    | S y' => y' - snd (divmod x y' 0 y')
  end.

Infix "/" := div : nat_scope.
Infix "mod" := modulo (at level 40, no associativity) : nat_scope.

Fixpoint aeval_fun (a : AExp) (env : Env) : nat :=
  match a with
  | avar k => env k
  | anum v => v
  | aplus a1 a2 => (aeval_fun a1 env) + (aeval_fun a2 env)
  | amul a1 a2 => (aeval_fun a1 env) * (aeval_fun a2 env)
  | amin a1 a2 => (aeval_fun a1 env) - (aeval_fun a2 env)
  | adiv a1 a2 => (aeval_fun a1 env) / (aeval_fun a2 env)
  | amod a1 a2 => (aeval_fun a1 env) mod (aeval_fun a2 env)
  | apow a1 => (aeval_fun a1 env) * (aeval_fun a1 env)
  end.

Compute aeval_fun (2 *' 3 *' 5) env1.
Compute aeval_fun (2 +' 3 *' "n") env1.
Compute aeval_fun(pow(3)).

Reserved Notation "A =[ S ]=> N" (at level 60).

Inductive aeval : AExp -> Env -> nat -> Prop :=
| const : forall n sigma, anum n =[ sigma ]=> n
| var : forall v sigma, avar v =[ sigma ]=> (sigma v)
| add : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = i1 + i2 ->
    a1 +' a2 =[sigma]=> n
| sub : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = i1 - i2 ->
    a1 -' a2 =[sigma]=> n
| times : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = i1 * i2 ->
    a1 *' a2 =[sigma]=> n
| divided : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = i1 / i2 ->
    a1 /' a2 =[sigma]=> n
| power : forall a1 i1  sigma n,
    a1 =[ sigma ]=> i1 ->
    n = i1 * i1 ->
    pow(a1) =[sigma]=> n
where "a =[ sigma ]=> n" := (aeval a sigma n).

Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| blessthan : AExp -> AExp -> BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp.

Fixpoint beval_fun (b : BExp) (env : Env) : bool :=
  match b with
  | btrue => true
  | bfalse => false
  | blessthan a1 a2 => Nat.leb (aeval_fun a1 env) (aeval_fun a2 env)
  | bnot b' => negb (beval_fun b' env)
  | band b1 b2 => match (beval_fun b1 env), (beval_fun b2 env) with
                  | true, true => false
                  | true, false => true
                  | false, true => true
                  | false, false => false
                  end
  end.

Notation "A <=' B" := (blessthan A B) (at level 53).
Reserved Notation "B ={ S }=> B'" (at level 70).

Inductive SExp :=
| astring : string -> SExp
| toUpper : SExp -> SExp
| toLower : SExp -> SExp.
Coercion astring : string >-> SExp.
Notation "low( A )" := (toLower A) (at level 61).
Notation "upper( A )" := (toUpper A) (at level 61).
Check (low("A")).
Check (upper("a")).
Compute (low("A")).
Compute (upper("a")).

Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval : BExp -> Env -> bool -> Prop :=
| e_true : forall sigma, btrue ={ sigma }=> true
| e_false : forall sigma, bfalse ={ sigma }=> false
| e_lessthan : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = Nat.leb i1 i2 ->
    a1 <=' a2 ={ sigma }=> b
| e_nottrue : forall b sigma,
    b ={ sigma }=> true ->
    (bnot b) ={ sigma }=> false
| e_notfalse : forall b sigma,
    b ={ sigma }=> false ->
    (bnot b) ={ sigma }=> true
| e_andtrue : forall b1 b2 sigma t,
    b1 ={ sigma }=> true ->
    b2 ={ sigma }=> t ->
    band b1 b2 ={ sigma }=> t
| e_andfalse : forall b1 b2 sigma,
    b1 ={ sigma }=> false ->
    band b1 b2 ={ sigma }=> false
where "B ={ S }=> B'" := (beval B S B').

Inductive Stmt :=
| assignment : string -> AExp -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt
(*| atoi_asg : string -> string -> Stmt
| itoa_asg : AExp -> string -> Stmt*)
| ifthenelse : BExp -> Stmt -> Stmt -> Stmt
| ifsimple : BExp -> Stmt -> Stmt.

Notation "X ::= A" := (assignment X A) (at level 50).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 90).
Notation " 'pentru' ( S1 )( B )( S2 ){ S3 }" := (S1 ;; while B (S2 ;; S3) ) (at level 92).
(*Notation "X ::= 'atoi'( Y )" := (atoi_asg X Y) (at level 93).
Notation "X ::= 'itoa'( Y )" := (itoa_asg X Y) (at level 93).*)
(*
Reserved Notation "S -{ Sigma }-> Sigma'" (at level 60).
Check update.
Inductive eval : Stmt -> Env -> Env -> Prop :=
| e_assignment: forall a i x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x i) ->
    (x ::= a) -{ sigma }-> sigma'
| e_seq : forall s1 s2 sigma sigma1 sigma2,
    s1 -{ sigma }-> sigma1 ->
    s2 -{ sigma1 }-> sigma2 ->
    (s1 ;; s2) -{ sigma }-> sigma2
| e_whilefalse : forall b s sigma,
    b ={ sigma }=> false ->
    while b s -{ sigma }-> sigma
| e_whiletrue : forall b s sigma sigma',
    b ={ sigma }=> true ->
    (s ;; while b s) -{ sigma }-> sigma' ->
    while b s -{ sigma }-> sigma'
| e_ifsimpletrue : forall b s sigma sigma',
    b ={ sigma }=> true ->
    s -{ sigma }-> sigma' ->
    ifsimple b s -{ sigma }-> sigma'
| e_ifsimplefalse : forall b s sigma,
    b ={ sigma }=> false ->
    ifsimple b s -{ sigma }-> sigma
| e_ifthenelsetrue : forall b c1 c2 sigma sigma',
    b ={ sigma }=> true ->
    c1 -{ sigma }-> sigma' ->
    ifthenelse b c1 c2 -{ sigma }-> sigma'
| e_ifthenelsefalse : forall b c1 c2 sigma sigma',
    b ={ sigma }=> false ->
    c2 -{ sigma }-> sigma' ->
    ifthenelse b c1 c2 -{ sigma }-> sigma'

where "s -{ sigma }-> sigma'" := (eval s sigma sigma').
*)

Fixpoint eval (s : Stmt) (env : Env) (gas : nat) : Env :=
  match gas with
  | 0 => env
  | S gas' =>   match s with
                | assignment Var aexp => update env Var (aeval_fun aexp env)
                | sequence S1 S2 => eval S2 (eval S1 env gas') gas'
                | while cond s' => if (beval_fun cond env)
                                   then eval (s' ;; (while cond s')) env gas'
                                   else env
                | ifthenelse cond s1 s2 => if (beval_fun cond env)
                                           then (eval s1 env) gas'
                                           else (eval s2 env) gas'
                | ifsimple cond s' => if (beval_fun cond env)
                                      then (eval s' env) gas'
                                      else env

                end
  end.

Notation "X := A" := (assignment X A) (at level 50).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 90).
Reserved Notation "S -{ Sigma }-> Sigma'" (at level 60).

Compute (assignment  "x" (2 +' 7)).
Compute
  "n" := 10 ;;
  "m" := 7;;
ifthenelse (2 <=' 5)
           ("max" := 9)
           ("max" := 5).
Compute
ifsimple (2 <=' 5)
           ("max" := 9).
Compute
while (2 <=' 5)
           ("max" := 9).
Compute
  "n" := 10 ;;
  "m" := 7;;
pentru("n" := 10)( 3 <='4 )("n" := 3+'1){"max" := 9}.