Require Import List.
Require Import String.
Require Import ZArith.

Open Scope list_scope.
Open Scope string_scope.
Open Scope Z_scope.

Require Import Imp.ImpSyntax.
Require Import Imp.ImpCommon.

(*
 * In this file, you will finish writing the interpreter for Imp.
 * You should use the semantics in ImpEval.v as a guide.
 *)

Definition interp_op1
  (op : op1) (v : val) : option val :=
  match op, v with
  | Oneg, Vint i =>
      Some (Vint (Z.opp i))
  | Onot, Vbool b =>
      Some (Vbool (negb b))
  | _, _ =>
      None
  end.

(*
 * Problem 1 [20 points, ~30 LOC]: Complete the rest of interp_op2.
 * The semantics for this are in eval_binop in ImpEval.v.
 *
 * Once you have written this, uncomment the proof of eval_op2_interp_op2 in
 * ImpInterpProof.v.
 *)
Definition interp_op2
  (op : op2) (v1 v2 : val) : option val :=
  match op, v1, v2 with
  | Oadd, Vint i1, Vint i2 =>
      Some (Vint (Z.add i1 i2))
  | Odiv, Vint i1, Vint i2 =>
      if Z.eq_dec i2 0 then
        None
      else
        Some (Vint (Z.div i1 i2))
  (* YOUR CODE HERE *)
  | _, _, _ =>
      None
  end.

Fixpoint interp_e (s : store) (h : heap)
  (e : expr) : option val :=
  match e with
  | Eval v => Some v
  | Evar x => lkup s x
  | Eop1 op e1 =>
      match interp_e s h e1 with
      | Some v1 => interp_op1 op v1
      | _ => None
      end
  | Eop2 op e1 e2 =>
      match interp_e s h e1, interp_e s h e2 with
      | Some v1, Some v2 => interp_op2 op v1 v2
      | _, _ => None
      end
  | Elen e1 =>
      match interp_e s h e1 with
      | Some (Vaddr a) =>
          match read h a with
          | Some (Vint l) => Some (Vint l)
          | _ => None
          end
      | Some (Vstr cs) =>
          Some (Vint (Z.of_nat (String.length cs)))
      | _ => None
      end
  | Eidx e1 e2 =>
      match interp_e s h e1, interp_e s h e2 with
      | Some (Vaddr a), Some (Vint i) =>
          match read h a with
          | Some (Vint l) =>
              if Z_le_dec 0 i then
                if Z_lt_dec i l then
                  read h (Z.succ (a + i))
                else
                  None
              else
                None
          | _ => None
          end
      | Some (Vstr cs), Some (Vint i) =>
          if Z_le_dec 0 i then
            match String.get (Z.to_nat i) cs with
            | Some c =>
                Some (Vstr (String c EmptyString))
            | None => None
            end
          else
            None
      | _, _ => None
      end
  end.

Fixpoint interps_e (s : store) (h : heap)
  (es : list expr) : option (list val) :=
  match es with
  | nil => Some nil
  | e :: t =>
      match interp_e s h e, interps_e s h t with
      | Some v, Some vs => Some (v :: vs)
      | _, _ => None
      end
  end.

(*
 * Problem 2 [25 points, ~70 LOC]: Complete the rest of interp_s.
 * The semantics for this are in eval_s in ImpEval.v.
 *
 * Hint: If you are lost, try walking through and understanding how one of the
 * cases that is already filled in (say, Salloc) relates to the corresponding
 * constructors of eval_s (eval_alloc). Also, note that it is OK to have
 * a single case that corresponds to multiple different constructors of eval_s,
 * much like the Scall case that is already filled in.
 *)
Fixpoint interp_s (fuel : nat) (env : env) (s : store) (h : heap)
  (p : stmt) : option (store * heap) :=
  match fuel with O => None | S n =>
    match p with
    | Salloc x e1 e2 =>
        match interp_e s h e1, interp_e s h e2 with
        | Some (Vint i), Some v =>
            if Z_le_dec 0 i then
              Some (update s x (Vaddr (zlen h)), alloc h i v)
            else
              None
        | _, _ => None
        end
    | Swrite x e1 e2 =>
        match lkup s x
            , interp_e s h e1
            , interp_e s h e2 with
        | Some (Vaddr a), Some (Vint i), Some v =>
            match read h a with
            | Some (Vint l) =>
                if Z_le_dec 0 i then
                  if Z_lt_dec i l then
                    match write h (Z.succ (a + i)) v with
                    | Some h' => Some (s, h')
                    | None => None
                    end
                  else
                    None
                else
                  None
            | _ => None
            end
        | _, _, _ => None
        end
    | Scall x f es =>
        match interps_e s h es with
        | Some vs =>
            match locate env f with
            | Some (Func _ params body ret) =>
                match updates store_0 params vs with
                | Some sf =>
                    match interp_s n env sf h body with
                    | Some (s', h') =>
                        match interp_e s' h' ret with
                        | Some v' =>
                            Some (update s x v', h')
                        | None => None
                        end
                    | None =>
                        None
                    end
                | None =>
                    None
                end
            | None =>
                if extcall_args_ok f vs h then
                  let (v', h') := extcall f vs h in
                  Some (update s x v', h')
                else
                  None
            end
        | None => None
        end
    (* YOUR CODE HERE *)
    | _ => None
    end
  end.

Definition interp_p (fuel : nat) (p : prog) : option (heap * val) :=
  match p with
  | Prog funcs body ret =>
      match interp_s fuel funcs store_0 heap_0 body with
      | Some (s', h') =>
          match interp_e s' h' ret with
          | Some v' => Some (h', v')
          | None => None
          end
      | None => None
      end
  end.


(*
   CPS
   2010_10_29
   *)

(* 階乗の再帰版 *)
Fixpoint fact (n : nat) : nat :=
  match n with
    | 0 => 1
    | (S n') => n * fact n'
  end.
Eval cbv in fact 6.                         (* 720 *)

(* CPS 版で書くとこうなる。*)
Fixpoint fact_cps (n : nat) (cont : nat -> nat) : nat :=
  match n with
    | 0 => cont 1
    | (S n') => fact_cps n' (fun (a : nat) => cont (n * a))
  end.
Eval cbv in fact_cps 6 (fun a => a).        (* 720 *)

Lemma fact_Sn :
  forall n,
    fact (S n) = (S n) * fact n.
Proof.
  reflexivity.
Qed.

Lemma fact_cps_Sn :
  forall n f,
    fact_cps (S n) f =
    fact_cps n (fun (r:nat) => (f (S n * r))).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

(* fact_cps_Sn の実験 *)
Eval cbv in fact_cps 6 (fun (r:nat) => r).  (* 720 *)
Eval cbv in fact_cps 5 (fun (r:nat) => (6 * r)). (* 720 *)

Lemma eq_fact_fact_cps_aux :
  forall (n:nat),
    (forall f, f (fact n) = fact_cps n f) /\
    (forall g, g (fact (S n)) = fact_cps (S n) g).
Proof.
  intros.
  induction n.
  (* 再帰の底 *)
  auto.

  destruct IHn.
  split.
  (* /\の左 *)
  apply H0.

  (* /\の右 *)
  intro g.
  rewrite fact_cps_Sn.
  rewrite <- H0.
  rewrite fact_Sn.
  reflexivity.
Qed.

Theorem eq_fact_fact_cps :
  forall n f, f (fact n) = fact_cps n f.
Proof.
  intros.
  destruct (eq_fact_fact_cps_aux n).
  apply H.
Qed.

(* END *)


(** %\chapter{Equality and Rewriting Principles}% *)

From mathcomp.ssreflect
Require Import ssreflect ssrfun eqtype ssrnat ssrbool.

Module Rewriting.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Propositional equality in Coq *)

Locate "_ = _".

(**
[[
"x = y" := eq x y    : type_scope
]]
*)

Print eq.

(**
[[
Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : eq x x
]]

The type of its only constructor [eq_refl] is a bit misleading, as it
looks like it is applied to two arguments: [x] and ... [x]. To
disambiguate it, we shall put some parentheses, so, it fact, it should
read as

[[
Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : (eq x) x
]]

That is, the constructor [eq_refl] delivers an element of type [(eq
x)], whose _parameter_ is some [x] (and [eq] is directly applied to
it), and its _index_ (which comes second) is constrained to be [x] as
well. That is, case-analysing on an instance of [eq x y] in the
process of the proof construction will inevitably lead the side
condition implying that [x] and [y] actually correspond to the _same
object_. Coq will take advantage of this fact immediately, by
performing the _unification_ and substituting all occurrences of [y]
in the subsequent goal with [x].  Let us see how it works in practice.

** Case analysis on an equality witness

To demonstrate the actual proofs on the case analysis by equality, we
will have to perform an awkward twist: define _our own_ equality
predicate.

*)

Set Implicit Arguments.
Inductive my_eq (A : Type) (x : A) : A -> Prop :=  my_eq_refl : my_eq x x.
Notation "x === y" := (my_eq x y) (at level 70).

(**

As we can see, this definition literally repeats the Coq's standard
definition of propositional equality. The reason for the code
duplication is that SSReflect provides a specific treatment of Coq's
standard equality predicate, so the case-analysis on its instances is
completely superseded by the powerful [rewrite] tactics, which we will
see in %Section~\ref{sec:rewriting}% of this chapter. Alas, this
special treatment also leads to a non-standard behaviour of
case-analysis on equality. This is why, for didactical purposes, we
will have to stick with or own home-brewed definition until the end of
this section.

*)

Lemma my_eq_sym A (x y: A) : x === y -> y === x.

case.

(**

[[
  A : Type
  x : A
  y : A
  ============================
   x === x
]]
*)

done.
Qed.

(**

Our next exercise will be to show that the predicate we have just
defined implies Leibniz equality. The proof is accomplished in one
line by first moving the assumption [P x]
to the top and then case-analysing on the equality, which leads to the
automatic replacements of [y] by [x].

*)

Lemma my_eq_Leibniz A (x y: A) (P: A -> Prop) : x === y -> P x -> P y.
Proof. by case. Qed.

(** ** Implementing discrimination

Another important application of the equality predicate family and
similar ones are _proofs by discrimination_, in which the
contradiction is reached (i.e., the falsehood is derived) out of the
fact that two clearly non-equal elements are assumed to be equal. The
next lemma demonstrates the essens of the proof by discrimination
using the [my_eq] predicate.

*)

Lemma disaster : 2 === 1 -> False.
Proof.
move=> H.

(**

[[
  H : 2 === 1
  ============================
   False
]]

*)

pose D x := if x is 2 then False else True.

(**

[[
  H : 2 === 1
  D := fun x : nat =>
       match x with
       | 0 => True
       | 1 => True
       | 2 => False
       | S (S (S _)) => True
       end : nat -> Prop
  ============================
   False
]]
*)

have D1: D 1.
by [].

(**

[[
  H : 2 === 1
  D := ...
  D1 : D 1
  ============================
   False
]]
*)

case: H D1.

(**

[[
  D := ...
  ============================
   D 2 -> False
]]
*)

move=>/=.

(**

The tactical [/=], coming after [=>] runs all possible simplifications
on the result obtained by the tactics, preceding [=>], finishing the
proof.

*)

done.
Qed.

(**

** Reasoning with Coq's standard equality

Now we know what drives the reasoning by equality and discrimination,
so let us forget about the home-brewed predicate [my_eq] and use the
standard equality instead. Happily, the discrimination pattern we used
to implement "by hand" now is handled by Coq/SSReflect automatically,
so the trivially false equalities deliver the proofs right away by
simply typing [done].

*)

Lemma disaster3: 2 = 1 -> False.
Proof. done. Qed.

(**

* Proofs by rewriting

The vast majority of the steps when constructing real-life proofs in
Coq are _rewriting_ steps. The general flow of the interactive proof
is typically targeted on formulating and proving small auxiliary
hypotheses about equalities in the forward-style reasoning and then
exploiting the derived equalities by means of rewriting in the goal
and, occasionally, other assumptions in the context. All rewriting
machinery is handled by SSReflect's enhanced [rewrite]%\ssrt{rewrite}%
tactics, and in this section we focus on its particular uses.

** Unfolding definitions and in-place rewritings

One of the common uses of the [rewrite] tactic is to fold/unfold
transparent definitions. In general, Coq is capable to perform the
unfoldings itself, whenever it's required. Nevertheless, manual
unfolding of a definition might help to understand the details of the
implementation, as demonstrated by the following example.

*)

Definition double A (f: A -> A) (x: A) := f (f x).

Fixpoint nat_iter (n : nat) {A} (f : A -> A) (x : A) : A :=
  if n is S n' then f (nat_iter n' f x) else x.

Lemma double2 A (x: A) f t:
  t = double f x -> double f t = nat_iter 4 f x.
Proof.

move=>Et; rewrite Et.

(**

[[
  A : Type
  x : A
  f : A -> A
  t : A
  Et : t = double f x
  ============================
   double f (double f x) = nat_iter 4 f x
]]

Even though the remaining goal is simple enough to be completed by
[done], let us unfold both definition to make sure that the two terms
are indeed equal structurally. Such unfoldings can be _chained_, just
as any other rewritings.

*)

rewrite /double /nat_iter.

(**
[[
  x : A
  f : A -> A
  ============================
   f (f (f (f x))) = f (f (f (f x)))
]]

An alternative way to prove the same statement would be to use the
[->] tactical, which is usually combined with
[move] or [case], but instead of moving the assumption to the top, it
makes sure that the assumption is an equality and rewrites by it.

 *)

Restart.
by move=>->.
Qed.

(**

Notice that the tactical has a companion one [<-], which performs the
rewriting by an equality assumption from right to left, in contrast to
[->], which rewrites left to right.

The reverse operation to folding is done by using [rewrite -/...]
instead of [rewrite /...].

** Proofs by congruence and rewritings by lemmas

*)

Definition f x y :=  x + y.

Goal forall x y, x + y + (y + x) = f y x + f y x.
Proof.
move=> x y.

rewrite /f.

(**

[[
  x : nat
  y : nat
  ============================
   x + y + (y + x) = y + x + (y + x)
]]
*)

congr (_ + _).

(**

[[
  x : nat
  y : nat
  ============================
   x + y = y + x
]]
*)

Check addnC.

(**
[[
addnC
     : commutative addn
]]
*)

Print ssrfun.commutative.

(**
[[
ssrfun.commutative =
  fun (S T : Type) (op : S -> S -> T) => forall x y : S, op x y = op y x
       : forall S T : Type, (S -> S -> T) -> Prop
]]

So, after specializing the definition appropriately, the type of
[addnC] should be read as:

[[
addnC
     : forall n m: nat, n + m = m + n
]]

Now, we can take advantage of this equality and rewrite by it a part
of the goal. Notice that Coq will figure out how the
universally-quantified variables should be instantiated (i.e., with
[y] and [x], respectively):

*)

by rewrite [y + _]addnC.
Qed.

Goal forall x y z, (x + (y + z)) = (z + y + x).
Proof.
by move=>x y z; rewrite [y + _]addnC; rewrite [z + _ + _]addnC.
Qed.

(** ** Naming in subgoals and optional rewritings

When working with multiple cases, it is possible to "chain" the
execution of several tactics. Then, in the case of a script [tac1;
tac2], if the goal is replaced by several after applying [tac1], then
[tac2] will be applied to _all_ subgoals, generated by [tac1]. For
example, let us consider a proof of the following lemma from the
standrad [ssrnat] %\ssrm{ssrnat}% module:

*)

Lemma addnCA: forall m n p, m + (n + p) = n + (m + p).
Proof.
move=>m n.

(**

[[
  m : nat
  n : nat
  ============================
   forall p : nat, m + (n + p) = n + (m + p)
]]

The proof will proceed by induction on [m]. We have already seen the
use of the [case] tactics, which just performs the case
analysis. Another SSReflect tactic [elim]  generalizes
[case] by applying the default induction principle ([nat_ind] in this
case) with the respect to the remaining goal (that is, the predicate
[[forall p : nat, m + (n + p) = n + (m + p)]]) is to be proven by
induction.  The following sequence of tactics proceeds by induction on
[m] with the default induction principle. It also names some of the
generated assumptions.

*)

elim: m=>[ | m Hm ] p.

(**

In particular, the following steps are performed:

- [m] is pushed as a top assumption of the goal;
- [elim] is run, which leads to generation of the two goals;

  - The first goal is of the shape
[[
forall p : nat, 0 + (n + p) = n + (0 + p)
]]

  - The second goal has the shape
[[
forall n0 : nat,
 (forall p : nat, n0 + (n + p) = n + (n0 + p)) ->
 forall p : nat, n0.+1 + (n + p) = n + (n0.+1 + p)
]]

- The subsequent structured naming [=> [ |m Hm ] p] names zero
  assumptions in the first goal and the two top assumptions, [m] and
  [Hm], in the second goal. It then next names the assumption [p] in
  _both_ goals and moves it to the top.

The first goal can now be proved by multiple rewritings via the lemma
[add0n], stating that [0] is the left unit with respect to the
addition:

*)

by rewrite !add0n.

(**

The second goal can be proved by a series of rewritings using the fact
about the [(_ + 1)] function:

*)

by rewrite !addSnnS -addnS.

(**

Notice that the conclusion of the [addnS] lemma is rewritten
right-to-left.

The whole proof could be, however, accomplished in one line using the
_optional_ rewritings.
*)

Restart.

by move=>m n; elim: m=>[ | m Hm ] p; rewrite ?add0n ?addSnnS -?addnS.
Qed.

(**

Notice that the optional rewritings (e.g., [?addSnnS]) are
performed as many times as they can be.

** Selective occurrence rewritings

Sometimes, instead of providing an r-pattern to specialize the
rewriting, it is more convenient to specify, which particular
syntactic occurrences in the goal term should be rewritten. This is
demonstrated by the following alternative proof of commutativity of
addition from the lemma [addnCA], which we have proved before:

*)

Lemma addnC: forall m n, m + n = n + m.
Proof.
move=> m n.
rewrite -{1}[n]addn0.
by rewrite addnCA addn0.
Qed.

(**

The first rewriting with [addn0] "adds" [0] to the first occurrence of
[addn0], so the left-hand side of the equality becomes [m + (n +
0)]. The next rewriting employs the lemma [addnCA], so we get [n + (m
+ 0) = n + m] as the goal, and the last one "removes" zero, so the
result trivially follows.

*)

(** * Indexed datatype families as rewriting rules

In this chapter we have already seen how defining indexed datatype
families makes it possible for Coq to provide a convenient rewriting
machinery, which is implicitly invoked by case analysis on such
families' refined types, thanks to sophisticated Coq's unification
procedure.

Although so far this approach has been demonstrated by only one
indexed type family example---propositional equality, defined by means
of the [eq] family, in this section, concluding the chapter, we will
show how to define other client-specific rewriting rules. Let us start
from a motivating example in the form of an "obvious" lemma.

*)

Lemma huh n m: (m <= n) /\ (m > n) -> False.

(**

From now on, we will be consistently including yet another SSReflect
modules, [ssrbool] and [eqtype], %\ssrm{ssrbool}\ssrm{eqtype}% into
our development. The need for them is due to the smooth combination of
reasoning with [Prop]ositions and [bool]eans, which is a subject of
the next chapter. Even though in SSReflect's library, relations on
natural numbers, such as [<=] and [>], are defined as _boolean_
functions, so far we recommend to the reader to think of them as of
predicates defined in [Prop] and, therefore, valid arguments to the
[/\] connective.

Although the statement is somewhat obvious, in the setting of Coq's
inductive definition of natural numbers it should be no big surprise
that it is proved by induction. We present the proof here, leaving the
details aside, so the reader could figure them out on his own, as a
simple exercise.%\ssrt{elim}\ssrt{suff:}\ssrtl{//}%

*)

Proof.
suff X: m <= n -> ~(m > n) by case=>/X.
by elim: m n => [ | m IHm ] [ | n] //; exact: IHm n.
Qed.

Definition maxn m n := if m < n then n else m.

Lemma max_is_max m n: n <= maxn m n /\ m <= maxn m n.

(**

The stated lemma [max_is_max] can be, indeed, proved by induction on
[m] and [n], which is a rather tedious exercise, so we will not be
following this path.
*)

Abort.

(* ** Encoding custom rewriting rules *)

Inductive leq_xor_gtn m n : bool -> bool -> Set :=
  | LeqNotGtn of m <= n : leq_xor_gtn m n true false
  | GtnNotLeq of n < m  : leq_xor_gtn m n false true.

(**

However, this is not yet enough to enjoy the custom rewriting and case
analysis on these two variant. At this moment, the datatype family
[leq_xor_gtn], whose constructors' indices encode a truth table's
"rows", specifies two substitutions in the case when [m <= n] and [n <
m], respectively and diagrammatically looks as follows:

<<
         |   C1  |   C2
-------------------------
m <= n   | true  | false
-------------------------
n < m    | false | true
>>

The boolean values in the cells specify what the values of C1 and C2
will be substituted _with_ in each of the two cases. However, the
table does not capture, what to substitute them _for_.  Therefore, our
next task is to provide suitable variants for C1 and C2, so the table
would describe a real situation and capture exactly the "case
analysis" intuition. This values of the columns are captured by the
following lemma, which, informally speaking, states that the table
with this particular values of C1 and C2 "makes sense".
*)

Lemma leqP m n : leq_xor_gtn m n (m <= n) (n < m).
Proof.
rewrite ltnNge.
by case X: (m <= n); constructor=>//; rewrite ltnNge X.
Qed.

(*
Moreover, the lemma [leqP], which we have just proved, delivers the
necessary instance of the "truth" table, which we can now case-analyse
against.

*)

(** ** Using custom rewriting rules  *)

Lemma huh' n m: (m <= n) /\ (m > n) -> False.
Proof.

move/andP.

(**

[[
  n : nat
  m : nat
  ============================
   m <= n < m -> False
]]

The top assumption [m <= n < m] of the goal is just a syntactic sugar
for [(m <= n) && (n < m)].
*)

case:leqP.

(**

[[
  n : nat
  m : nat
  ============================
   m <= n -> true && false -> False

subgoal 2 (ID 638) is:
 n < m -> false && true -> False
]]

Now, considering a boolean value [true && false] in a goal simply as a
proposition [(true && false) = true], the proof is trivial by
simplification of the boolean conjunction.

*)

done.
done.
Qed.

(**

The proof of [huh'] is now indeed significantly shorter than the proof
of its predecessor, [huh]. However, it might look like the definition
of the rewriting rule [leq_xor_gtn] and its accompanying lemma [leqP]
is quite narrowly-scoped, and it is not clear how useful it might be
for other proofs.
*)

Lemma max_is_max m n: n <= maxn m n /\ m <= maxn m n.
Proof.
(**

The proof begins by unfolding the definition of [maxn].

*)
rewrite /maxn.

(**
[[
  m : nat
  n : nat
  ============================
   n <= (if m < n then n else m) /\ m <= (if m < n then n else m)
]]

We are now in the position to unleash our rewriting rule, which,
together with simplifications by means of the [//] tactical
%\ssrtl{//}% does most of the job.

*)

case: leqP=>//.

(**

[[
  m : nat
  n : nat
  ============================
   m < n -> n <= n /\ m <= n
]]

The res of the proof employs rewriting by some trivial lemmas from [ssrnat],
%\ssrm{ssrnat}% but conceptually is very easy.

*)

move=>H; split.

Search _ (?X <= ?X).

by apply: leqnn.

Search _ (?x < ?y) (?x <= ?y).

by rewrite ltn_neqAle in H; case/andP: H.
Qed.

(**

The key advantage we got out of using the custom rewriting rule,
defined as an indexed datatype family is lifting the need to prove _by
induction_ a statement, which one would intuitively prove by means of
_case analysis_. In fact, all inductive reasoning was conveniently
"sealed" by the proof of [leqP] and the lemmas it made use of, so just
the tailored "truth table"-like interface for case analysis was given
to the client.
*)

(*******************************************************************)
(**                     * Exercices *                              *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Discriminating [===]]
---------------------------------------------------------------------
Let us change the statement of a lemma [disaster] for a little bit:
*)

Lemma disaster2 : 1 === 2 -> False.

(**
Now, try to prove it using the same scheme. What goes wrong and how to
fix it?
*)
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Fun with rewritings]
---------------------------------------------------------------------
Prove the following lemma by using the [rewrite] tactics.

*)

Lemma rewrite_is_fun T (f : T -> T -> T) (a b c : T):
  commutative f -> associative f ->
  f (f b a) c = f a (f c b).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Properties of maxn]
---------------------------------------------------------------------
Prove the following lemmas about [maxn].
*)

Lemma max_l m n: n <= m -> maxn m n = m.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma succ_max_distr_r n m : (maxn n m).+1 = maxn (n.+1) (m.+1).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma plus_max_distr_l m n p: maxn (p + n) (p + m) = p + maxn n m.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

Hint: it might be useful to employ the lemmas [ltnNge], [leqNgt],
[ltnS] and similar to them from SSReflect's [ssrnat] module. Use the
[Search] command to find propositions that might help you to deal with
the goal.

Hint: Forward-style reasoning via [suff] and [have] might be more
intuitive.

Hint: A hypothesis of the shape [H: n < m] is a syntactic sugar for
[H: n < m = true], since [n < m] in fact has type [bool], as will be
explained in the next lecture.

*)

(**
---------------------------------------------------------------------
Exercise [More custom rewriting rules]
---------------------------------------------------------------------

Let us consider an instance of a more sophisticated custom rewriting
rule, which now encodes a three-variant truth table for the ordering
relations on natural numbers.

*)

Inductive nat_rels m n : bool -> bool -> bool -> Set :=
  | CompareNatLt of m < n : nat_rels m n true false false
  | CompareNatGt of m > n : nat_rels m n false true false
  | CompareNatEq of m = n : nat_rels m n false false true.

(**

The following rewriting lemma establishes a truth table for
[nat_rels]. Step through the proofs (splitting the combined tactics
whenever it's necessary) to see what's going on.

*)

Lemma natrelP m n : nat_rels m n (m < n) (n < m) (m == n).
Proof.
rewrite ltn_neqAle eqn_leq; case: ltnP; first by constructor.
by rewrite leq_eqVlt orbC; case: leqP; constructor; first exact/eqnP.
Qed.

(**
Let us define the minimum function [minn] on natural numbers as
follows:
*)

Definition minn m n := if m < n then m else n.

(**
Prove the following lemma about [minm] and [maxn]:
*)

Lemma addn_min_max m n : minn m n + maxn m n = m + n.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

End Rewriting.


Require Import Arith.
Require Import Bool.
Require Import List.

Require Import Utils.nat.

Inductive type : Set := Nat | Bool.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus  : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq    : forall (t:type), tbinop t t Bool
| TLt    : tbinop Nat Nat Bool
.

Inductive texp : type -> Set :=
| TNConst : nat  -> texp Nat
| TBConst : bool -> texp Bool
| TBinop  : forall (t1 t2 t:type), tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t
.

Arguments TBinop {t1} {t2} {t} _ _ _.

Definition typeDenote (t:type) : Set :=
    match t with
    | Nat   => nat
    | Bool  => bool
    end.

Definition tbinopDenote (t1 t2 t:type) (b:tbinop t1 t2 t)
    : typeDenote t1 -> typeDenote t2 -> typeDenote t :=
        match b with
        | TPlus    => plus
        | TTimes   => mult
        | TEq Nat  => beq_nat
        | TEq Bool => eqb
        | TLt      => blt_nat
        end.

Arguments tbinopDenote {t1} {t2} {t} _ _ _.

Fixpoint texpDenote (t:type) (e:texp t) : typeDenote t :=
    match e with
    | TNConst n               => n
    | TBConst b               => b
    | @TBinop t1 t2 _ b e1 e2 =>
            tbinopDenote b (texpDenote t1 e1) (texpDenote t2 e2)
    end.

Arguments texpDenote {t} _.

Definition tstack := list type.

Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall (s:tstack) (n:nat) , tinstr s (Nat :: s)
| TiBConst : forall (s:tstack) (b:bool), tinstr s (Bool :: s)
| TiBinop  : forall (t1 t2 t:type) (s:tstack),
    tbinop t1 t2 t -> tinstr (t1 :: t2 :: s) (t :: s)
.

Arguments TiBinop {t1} {t2} {t} _ _.

Inductive tprog : tstack -> tstack -> Set :=
| TNil  : forall (s:tstack), tprog s s
| TCons : forall (s1 s2 s3:tstack), tinstr s1 s2 -> tprog s2 s3 -> tprog s1 s3
.

Arguments TCons {s1} {s2} {s3} _ _.

Fixpoint vstack (ts:tstack) : Set :=
    match ts with
    | nil       => unit
    | t :: ts'  => prod (typeDenote t) (vstack ts')
    end.

Definition tinstrDenote (s1 s2:tstack) (i:tinstr s1 s2)
    : vstack s1 -> vstack s2 :=
    match i with
    | TiNConst _ n        => fun s => (n,s)
    | TiBConst _ b        => fun s => (b,s)
    | @TiBinop _ _ _ _ b  => fun s =>
        let '(v1, (v2, s')) := s in
            ((tbinopDenote b) v1 v2, s')
    end.

Arguments tinstrDenote {s1} {s2} _ _.

Fixpoint tprogDenote (s1 s2:tstack) (p:tprog s1 s2)
    : vstack s1 -> vstack s2 :=
    match p with
    | TNil _               => fun s => s
    | @TCons s1 s2 s3 i p' => fun s => tprogDenote s2 s3 p' (tinstrDenote i s)
    end.

Arguments tprogDenote {s1} {s2} _ _.

Fixpoint tconcat (t1 t2 t3:tstack) (p:tprog t1 t2)
    : tprog t2 t3 -> tprog t1 t3 :=
    match p with
    | TNil _               => fun q => q
    | @TCons s1 s2 s3 i p' => fun q => TCons i (tconcat s2 s3 _ p' q)
    end.

Arguments tconcat {t1} {t2} {t3} _ _.

Fixpoint tcompile (t:type) (e:texp t) (ts:tstack) : tprog ts (t :: ts) :=
    match e with
    | TNConst n             => TCons (TiNConst _ n) (TNil _)
    | TBConst b             => TCons (TiBConst _ b) (TNil _)
    | @TBinop _ _ _ b e1 e2 => tconcat (tcompile _ e2 _)
        (tconcat (tcompile _ e1 _) (TCons (TiBinop _ b) (TNil _)))
    end.

Arguments tcompile {t} _ _.

Lemma tconcat_correct:
    forall (t1 t2 t3:tstack) (p:tprog t1 t2) (q:tprog t2 t3) (s:vstack t1),
    tprogDenote (tconcat p q) s = tprogDenote q (tprogDenote p s).
Proof.
    intros t1 t2 t3 p q. induction p as [t|s1 s2 s3 i r IH]; intros s; simpl.
    - reflexivity.
    - rewrite IH. reflexivity.
Qed.

Lemma tcompile_correct': forall (t:type) (e:texp t)(ts:tstack)(s:vstack ts),
    tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
    intros t e. induction e as [n|b|t1 t2 t3 b e1 H1 e2 H2]; intros ts s; simpl.
    - reflexivity.
    - reflexivity.
    - rewrite tconcat_correct. rewrite H2.
      rewrite tconcat_correct. rewrite H1.
      reflexivity.
Qed.

Theorem tcompile_correct: forall (t:type) (e:texp t),
    tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Proof.
    intros t e. apply tcompile_correct'.
Qed.


Require Import List.

(** A type for triangular arrays *)

Inductive triangular (A B : Type) :=
| base : B -> triangular A B
| line : B -> triangular A (A * B) -> triangular A B.

Definition triangle (A: Type) := triangular A A.

Arguments base {A B} _.
Arguments line {A B} _ _.

Example t1 : triangle  nat :=
base 6.

Example t2 : triangle nat :=
  line 5
 (base (1, 1)).

Example t3 :triangle nat  :=
 line 6
(line (5, 3)
(line (5, (7, 8))
(base (1, (2, (3, 4)))))).

Fixpoint height {A B : Type}(t : triangular A B) : nat :=
  match t with base  _ => 1
             | line  _ m' => 1 + height m'
  end.

Example test1 :  height t3 = 4.
Proof.  reflexivity. Qed.

(** getting the vertical edge  of a triangle *)

Fixpoint left_edge_aux {A B : Type}(m : triangular A B): B * list A :=
match m with base b => (b,nil)
           | line b t' => match left_edge_aux t' with (x,y,l) => (b,(x::l)) end
end.

Definition left_edge {A:Type} (m: triangle A) :=
  match left_edge_aux m with (a,l)=> a::l end.

Example test2 : left_edge t3 = 6::5::5::1::nil.
Proof. reflexivity. Qed.

(* getting the lowest row *)

Fixpoint the_base_aux {A B : Type}(m : triangular A B)(f : B -> list A) :  list A :=
match m with base b => f b
           | line b t' => the_base_aux t' (fun p : A * B => fst p :: f (snd p))
end.

Definition the_base {A:Type} (m: triangle  A) :=
 the_base_aux m (fun a:A => a::nil).

Example test3 : the_base t3 = 1 :: 2 :: 3 :: 4 :: nil.
Proof. reflexivity. Qed.

(** getting the diagonal *)

Fixpoint diagonal {A B : Type}(m : triangular A B) :  list B :=
match m with base b =>  b :: nil
           | line b t' => b :: map snd (diagonal  t')
end.

Example test4 : diagonal  t3 = 6 :: 3 :: 8 :: 4 :: nil.
Proof. reflexivity. Qed.

(** flattening a triangle *)

Fixpoint flatten_aux {A}{B}(f: B -> list A) (m : triangular A B) : list A :=
 match m with base  b => f b
            | line   b m' => f b ++ flatten_aux (fun x=> fst x :: (f (snd x))) m'
 end.

Definition flatten {A:Type} (m : triangle A) : list A :=
flatten_aux (fun a => a::nil) m.

Example test5 : flatten t3 =
                6 :: 5 :: 3 :: 5 :: 7 :: 8 :: 1 :: 2 :: 3 :: 4 :: nil.
Proof. reflexivity. Qed.

(** building a triangle with the same data everywhere *)

Fixpoint uniform_aux {A B : Type}(a:A)(b:B)(n:nat) : triangular A B :=
  match n with 0 => base  b
             | S p => line  b (uniform_aux a (a,b)  p)
 end.

Definition uniform {A:Type}(a:A)(n:nat) : triangle A :=
uniform_aux a a n.

Example test6 : uniform 41 3 =
 line 41
(line (41, 41)
(line (41, (41, 41))
(base (41, (41, (41, 41)))))).
Proof. reflexivity. Qed.

(** what does this function compute ? *)

Fixpoint mystery_aux {A B : Type}(f:A->A)(a:A)(b:B)(n:nat) : triangular A B :=
  match n with 0 => base  b
             | S p => line  b (mystery_aux f (f a) (f a, b)   p)
 end.

Definition mystery {A:Type} (f : A -> A)(a:A) (n:nat) : triangle A :=
 mystery_aux f a a n.


Require Coq.extraction.Extraction.
Extraction Language OCaml.

Inductive term : Type :=
| tru
| fls
| If (t1 t2 t3: term)
| O
| succ (t1: term)
| pred (t1: term)
| iszero (t1: term).

Fixpoint isnumericval (t: term): bool :=
  match t with
  | O => true
  | succ t1 => isnumericval t1
  | _ => false
  end.

Definition isval (t: term) : bool :=
  match t with
  | tru => true
  | fls => true
  | _ => isnumericval t
  end.

Inductive optiont : Type :=
| Some (t: term)
| None.

Fixpoint eval1 (t: term) : optiont :=
  match t with
  | If t1 t2 t3 =>
    if (isval t1) then
      match t1 with
      | tru => Some t2
      | fls => Some t3
      | _ => None
      end else
      match (eval1 t1) with
      | Some t1' => Some (If t1' t2 t3)
      | _ => None
      end
  | succ t1 =>
    if isnumericval t1 then
      None else
      match (eval1 t1) with
      | Some t1' => Some (succ t1')
      | _ => None
      end
  | pred t1 =>
    if (isnumericval t1) then
      match t1 with
      | O => Some O
      | succ nv1 => Some nv1
      | _ => None
      end else
      match (eval1 t1) with
      | Some t1' => Some (pred t1')
      | _ => None
      end
  | iszero t1 =>
    if (isnumericval t1) then
      match t1 with
      | O => Some tru
      | succ _ => Some fls
      | _ => None
      end else
      match (eval1 t1) with
      | Some t1' => Some (iszero t1')
      | _ => None
      end
  | _ => None
  end.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Ltac solve_by_invert :=
  solve_by_inverts 1.

Theorem eval1value : forall t1,
    isval t1 = true -> eval1 t1 = None.
Proof.
  intros. induction t1; try solve_by_inverts 2; try reflexivity.
  inversion H. simpl. rewrite H1; auto.
Qed.

Extraction "ocaml/src/eval.ml" eval1.

Inductive NatValue: term -> Prop :=
| nv_O : NatValue O
| nv_S : forall nv1, NatValue nv1 -> NatValue (succ nv1).

Inductive Pvalue: term -> Prop :=
| v_tru : Pvalue tru
| v_fls : Pvalue fls
| v_nat : forall t1, NatValue t1 -> Pvalue t1.

Reserved Notation " t '-->' t' " (at level 40).
Inductive step: term -> term -> Prop :=
| E_IfTrue : forall t2 t3,
    If tru t2 t3 --> t2
| E_IfFalse : forall t2 t3,
    If fls t2 t3 --> t3
| E_If : forall t1 t1' t2 t3,
    t1 --> t1' ->
    If t1 t2 t3 --> If t1' t2 t3
| E_Succ : forall t1 t1',
    t1 --> t1' -> succ t1 --> succ t1'
| E_PredZero :
    pred O --> O
| E_PredSucc : forall nv1,
    NatValue nv1 -> pred (succ nv1) --> nv1
| E_Pred : forall t1 t1',
    t1 --> t1' -> pred t1 --> pred t1'
| E_IsZeroZero :
    iszero O --> tru
| E_IsZeroSucc : forall nv1,
    NatValue nv1 -> iszero (succ nv1) --> fls
| E_IsZero : forall t1 t1',
    t1 --> t1' -> iszero t1 --> iszero t1'

  where " t '-->' t' " := (step t t').

Lemma nat_value : forall t,
    NatValue t <-> isnumericval t = true.
Proof.
  split; intros.
  -
    induction H; auto.
  -
    induction t; try solve_by_invert.
    apply nv_O. inversion H. apply IHt in H1. apply nv_S; auto.
Qed.

Lemma isval_Pvalue : forall t,
    isval t = true <-> Pvalue t.
Proof.
  split; intros.
  -
    induction t; try solve_by_invert.
    apply v_tru. apply v_fls.
    apply v_nat; apply nv_O.
    inversion H. apply nat_value in H1. apply v_nat. apply nv_S; auto.
  -
    induction H; auto.
    unfold isval. inversion H; auto.
    simpl. apply nat_value; auto.
Qed.

Theorem step_eval1_correct : forall t1 t1',
    eval1 t1 = Some t1' <-> t1 --> t1'.
Proof.
  split.
  -
    intros. generalize dependent t1'.
    induction t1; intros; try solve_by_invert.
    +
      inversion H.
      induction (isval t1_1).
      destruct t1_1; try solve_by_invert.
      inversion H1. apply E_IfTrue.
      inversion H1. apply E_IfFalse.
      induction (eval1 t1_1) eqn:IHt1; try solve_by_invert.
      inversion H1. inversion H1. apply E_If. apply IHt1_1; auto.
    +
      inversion H.
      destruct (isnumericval t1) eqn:IHnum. inversion H1.
      destruct (eval1 t1) eqn:IH. inversion H1. apply E_Succ. apply IHt1; auto.
      inversion H1.
    +
      inversion H. destruct (isnumericval t1) eqn:IHnum; try solve_by_invert.
      destruct t1; try solve_by_invert. inversion H1. apply E_PredZero.
      inversion H1. apply E_PredSucc. inversion IHnum. apply nat_value; subst; auto.
      destruct (eval1 t1); try solve_by_invert.
      inversion H1. apply E_Pred. apply IHt1; auto.
    +
      inversion H.
      destruct (isnumericval t1) eqn:IHnum.
      destruct t1; try solve_by_invert.
      inversion H1. apply E_IsZeroZero.
      inversion H1. apply E_IsZeroSucc. inversion IHnum. apply nat_value; auto.
      destruct (eval1 t1); try solve_by_invert.
      inversion H1. apply E_IsZero. apply IHt1; auto.
  -
    intros. induction H; try reflexivity.
    +
      simpl. destruct (isval t1) eqn:IHv.
      destruct t1; try solve_by_invert. inversion H. inversion IHstep.
      inversion IHv. rewrite H5 in H4. inversion H4.
      rewrite IHstep; auto.
    +
      simpl. destruct (isnumericval t1) eqn:IHnum.
      pose proof (eval1value t1).
      rewrite H0 in IHstep.
      inversion IHstep.
      unfold isval. destruct t1; try solve_by_invert; auto.

      destruct (eval1 t1); try solve_by_invert.
      inversion IHstep; auto.
    +
      simpl. apply nat_value in H. rewrite H; auto.
    +
      simpl. destruct (isnumericval t1) eqn:IHnum.
      destruct t1; try solve_by_invert.
      pose proof (eval1value (succ t1)).
      rewrite H0 in IHstep. inversion IHstep.
      simpl. inversion IHnum; auto.
      destruct (eval1 t1); try solve_by_invert.
      inversion IHstep; auto.
    +
      simpl.
      destruct (isnumericval nv1) eqn:IHnum; try solve_by_invert; auto.
      apply nat_value in H. rewrite H in IHnum; inversion IHnum.
    +
      simpl.
      destruct (isnumericval t1) eqn:IHnum.
      pose proof (eval1value t1). rewrite H0 in IHstep. inversion IHstep.
      unfold isval. destruct t1; try solve_by_invert; auto.
      destruct (eval1 t1); try solve_by_invert. inversion IHstep; auto.
Qed.

Definition relation (X : Type) := X -> X -> Prop.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

(*停止する保証がないのでbigstepは無理そう*)
(*
Fixpoint bstep (t: term) : optiont :=
  match t with
  | tru => Some tru
  | fls => Some fls
  | O => Some t
  | If t1 t2 t3 =>
    match (eval1 t1) with
    | Some t1' =>
      if (isval t1') then
        match t1' with
        | tru => bstep t2
        | fls => bstep t3
        | _ => None
        end else bstep (If t1' t2 t3)
    | None => None
    end
  | succ t1 =>
    match (eval1 t1) with
    | Some t1' =>
      if (isval t1') then
        match t1' with
        | O => Some (succ O)
        | succ _ => Some (t1')
        | _ => None
        end else bstep (succ t1')
    | None => None
    end
  | pred t1 =>
    match (eval1 t1) with
    | Some t1' =>
      if (isval t1') then
        match t1' with
        | O => Some O
        | succ nv1 => Some nv1
        | _ => None
        end else bstep (pred t1')
    | _ => None
    end
  | iszero t1 =>
    match (eval1 t1) with
    | Some t1' =>
      if (isval t1') then
        match t1' with
        | O => Some tru
        | succ _ => Some fls
        | _ => None
        end else bstep (iszero t1')
    | _ => None
    end
  end.
*)