From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality.
Require Import Sequences Lemmas.

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

(** * 1. The source language: IMP *)

(** ** 1.1 Arithmetic expressions *)

Definition ident := string.

(** The abstract syntax: an arithmetic expression is either... *)

Inductive aexp : Type :=
  | CONST (n: Z)                       (**r a constant, or *)
  | VAR (x: ident)                    (**r a variable, or *)
  | PLUS (a1: aexp) (a2: aexp)         (**r a sum of two expressions, or *)
  | MINUS (a1: aexp) (a2: aexp).       (**r a difference of two expressions *)

(** The denotational semantics: an evaluation function that computes
  the integer value denoted by an expression.  It is parameterized by
  a store [s] that associates values to variables. *)

Definition store : Type := ident -> Z.

Fixpoint aeval (s: store) (a: aexp) : Z :=
  match a with
  | CONST n => n
  | VAR x => s x
  | PLUS a1 a2 => aeval s a1 + aeval s a2
  | MINUS a1 a2 => aeval s a1 - aeval s a2
  end.

(** Such evaluation functions / denotational semantics have many uses.
    First, we can use [aeval] to evaluate a given expression in a given store. *)

Compute (aeval (fun x => 2) (PLUS (VAR "x") (MINUS (VAR "x") (CONST 1)))).

(** Result is: [ = 3 : Z ]. *)

(** We can also do partial evaluation with respect to an unknown store *)

Eval cbn in (fun s => aeval s (PLUS (VAR "x") (MINUS (CONST 10) (CONST 1)))).

(** Result is: [ = fun s : store => s "x" + 9 ]. *)

(** We can prove properties of a given expression. *)

Lemma aeval_xplus1:
  forall s x, aeval s (PLUS (VAR x) (CONST 1)) > aeval s (VAR x).
Proof.
  intros. cbn. lia.
Qed.

(** Finally, we can prove "meta-properties" that hold for all expressions.
  For example: the value of an expression depends only on the values of its
  free variables.

  Free variables are defined by this recursive predicate:
*)

Fixpoint free_in_aexp (x: ident) (a: aexp) : Prop :=
  match a with
  | CONST n => False
  | VAR y => y = x
  | PLUS a1 a2 | MINUS a1 a2 => free_in_aexp x a1 \/ free_in_aexp x a2
  end.

Theorem aeval_free:
  forall s1 s2 a,
  (forall x, free_in_aexp x a -> s1 x = s2 x) ->
  aeval s1 a = aeval s2 a.
Proof.
  induction a; cbn; intros SAMEFREE.
- (* Case a = CONST n *)
  auto.
- (* Case a = VAR x *)
  apply SAMEFREE. auto.
- (* Case a = PLUS a1 a2 *)
  rewrite IHa1, IHa2. auto. auto. auto.
- (* Case a = MINUS a1 a2 *)
  rewrite IHa1, IHa2; auto.
Qed.

(** *** Exercise (1 star, recommended). *)
(** Add support for multiplication in arithmetic expressions.
  Modify the [aexp] type and the [aeval] function accordingly. *)

(** *** Exercise (2 stars, recommended). *)
(** Add support for division and for detecting arithmetic overflow.
  With this extension, the evaluation of an expression can produce an
  error: integer division by zero or result that exceeds the range
  [[min_int, max_int]].  You can either change the type of the
  function [aeval] to
<<
  aeval: store -> aexp -> option Z
>>
  with [None] meaning "error" and [Some n] meaning "success with
  result n".  Alternatively, you can define the semantics as a
  relation instead of a function:
<<
  Inductive aeval_rel: store -> aexp -> Z -> Prop := ...
>>
  Some definitions you can use:
*)

Definition min_int := - (2 ^ 63).
Definition max_int := 2 ^ 63 - 1.
Definition check_for_overflow (n: Z): option Z :=
  if n <? min_int then None else if n >? max_int then None else Some n.

(** ** 1.3 Boolean expressions *)

(** The IMP language has conditional statements (if/then/else) and
  loops.  They are controlled by expressions that evaluate to Boolean
  values.  Here is the abstract syntax of Boolean expressions. *)

Inductive bexp : Type :=
  | TRUE                              (**r always true *)
  | FALSE                             (**r always false *)
  | EQUAL (a1: aexp) (a2: aexp)       (**r whether [a1 = a2] *)
  | LESSEQUAL (a1: aexp) (a2: aexp)   (**r whether [a1 <= a2] *)
  | NOT (b1: bexp)                    (**r Boolean negation *)
  | AND (b1: bexp) (b2: bexp).        (**r Boolean conjunction *)

(** Just like arithmetic expressions evaluate to integers,
  Boolean expressions evaluate to Boolean values [true] or [false]. *)

Fixpoint beval (s: store) (b: bexp) : bool :=
  match b with
  | TRUE => true
  | FALSE => false
  | EQUAL a1 a2 => aeval s a1 =? aeval s a2
  | LESSEQUAL a1 a2 => aeval s a1 <=? aeval s a2
  | NOT b1 => negb (beval s b1)
  | AND b1 b2 => beval s b1 && beval s b2
  end.

(** There are many useful derived forms. *)

Definition NOTEQUAL (a1 a2: aexp) : bexp := NOT (EQUAL a1 a2).

Definition GREATEREQUAL (a1 a2: aexp) : bexp := LESSEQUAL a2 a1.

Definition GREATER (a1 a2: aexp) : bexp := NOT (LESSEQUAL a1 a2).

Definition LESS (a1 a2: aexp) : bexp := GREATER a2 a1.

Definition OR (b1 b2: bexp) : bexp := NOT (AND (NOT b1) (NOT b2)).

(** *** Exercise (1 star, recommended) *)
(** Show the expected semantics for the [OR] derived form: *)

Lemma beval_OR:
  forall s b1 b2, beval s (OR b1 b2) = beval s b1 || beval s b2.
Proof.
  (* Hint: do "SearchAbout negb" to see the available lemmas about Boolean negation. *)
  (* Hint: or just do a case analysis on [beval s b1] and [beval s b2], there are
     only 4 cases to consider. *)
  intros; cbn.
  remember (beval s b1) as b1'.
  remember (beval s b2) as b2'.
  (* TODO: any clever bool automations? *)
  destruct b1'; destruct b2'; reflexivity.
Qed.

(** ** 1.4 Commands *)

(** To complete the definition of the IMP language, here is the
  abstract syntax of commands, also known as statements. *)

Inductive com: Type :=
  | SKIP                                     (**r do nothing *)
  | ASSIGN (x: ident) (a: aexp)              (**r assignment: [v := a] *)
  | SEQ (c1: com) (c2: com)                  (**r sequence: [c1; c2] *)
  | IFTHENELSE (b: bexp) (c1: com) (c2: com) (**r conditional: [if b then c1 else c2] *)
  | WHILE (b: bexp) (c1: com).               (**r loop: [while b do c1 done] *)

(** We can write [c1 ;; c2] instead of [SEQ c1 c2], it is easier on the eyes. *)

Infix ";;" := SEQ (at level 80, right associativity).

(** Here is an IMP program that performs Euclidean division by
  repeated subtraction.  At the end of the program, "q" contains
  the quotient of "a" by "b", and "r" contains the remainder.
  In pseudocode:
<<
       r := a; q := 0;
       while b <= r do r := r - b; q := q + 1 done
>>
  In abstract syntax:
*)

Definition Euclidean_division :=
  ASSIGN "r" (VAR "a") ;;
  ASSIGN "q" (CONST 0) ;;
  WHILE (LESSEQUAL (VAR "b") (VAR "r"))
    (ASSIGN "r" (MINUS (VAR "r") (VAR "b")) ;;
     ASSIGN "q" (PLUS (VAR "q") (CONST 1))).

(** A useful operation over stores:
    [update x v s] is the store that maps [x] to [v] and is equal to [s] for
    all variables other than [x]. *)

Definition update (x: ident) (v: Z) (s: store) : store :=
  fun y => if string_dec x y then v else s y.

(** A naive approach to giving semantics to commands is to write an
  evaluation function [cexec s c] that runs the command [c] in initial
  store [s] and returns the final store when [c] terminates. *)

Fail Fixpoint cexec (s: store) (c: com) : store :=
  match c with
  | SKIP => s
  | ASSIGN x a => update x (aeval s a) s
  | SEQ c1 c2 => let s' := cexec s c1 in cexec s' c2
  | IFTHENELSE b c1 c2 => if beval s b then cexec s c1 else cexec s c2
  | WHILE b c1 =>
      if beval s b
      then (let s' := cexec s c1 in cexec s' (WHILE b c1))
      else s
  end.

(** The definition above is rejected by Coq, and rightly so, because
  all Coq functions must terminate, yet the [WHILE] case may not
  terminate.  Consider for example the infinite loop [WHILE TRUE
  SKIP].

  Worse, IMP is Turing-complete, since it has unbounded iteration
  ([WHILE]) plus arbitrary-precision integers.  Hence, there is no
  computable function [cexec s c] that would return [Some s'] if [c]
  terminates with store [s'], and [None] if [c] does not terminate.

  However, instead of computable functions, we can use a relation
  [cexec s c s'] that holds iff command [c], started in state [s],
  terminates with state [s'].  This relation can easily be defined as
  a Coq inductive predicate:
*)

Inductive cexec: store -> com -> store -> Prop :=
  | cexec_skip: forall s,
      cexec s SKIP s
  | cexec_assign: forall s x a,
      cexec s (ASSIGN x a) (update x (aeval s a) s)
  | cexec_seq: forall c1 c2 s s' s'',
      cexec s c1 s' -> cexec s' c2 s'' ->
      cexec s (SEQ c1 c2) s''
  | cexec_ifthenelse: forall b c1 c2 s s',
      cexec s (if beval s b then c1 else c2) s' ->
      cexec s (IFTHENELSE b c1 c2) s'
  | cexec_while_done: forall b c s,
      beval s b = false ->
      cexec s (WHILE b c) s
  | cexec_while_loop: forall b c s s' s'',
      beval s b = true -> cexec s c s' -> cexec s' (WHILE b c) s'' ->
      cexec s (WHILE b c) s''.

(** This style of semantics is known as natural semantics or big-step
  operational semantics.  The predicate [cexec s c s'] holds iff there
  exists a finite derivation of this conclusion, using the axioms and
  inference rules above.  The structure of the derivation represents
  the computations performed by [c] in a tree-like manner.  The
  finiteness of the derivation guarantees that only terminating
  executions satisfy [cexec].  Indeed, [WHILE TRUE SKIP] does not
  satisfy [cexec]: *)

Lemma cexec_infinite_loop:
  forall s, ~ exists s', cexec s (WHILE TRUE SKIP) s'.
Proof.
  assert (A: forall s c s', cexec s c s' -> c = WHILE TRUE SKIP -> False).
  { induction 1; intros EQ; inversion EQ.
  - subst b c. cbn in H. discriminate.
  - subst b c. apply IHcexec2. auto.
  }
  intros s (s' & EXEC). apply A with (s := s) (c := WHILE TRUE SKIP) (s' := s'); auto.
Qed.

(** Our naive idea of an execution function for commands was not
  completely off.  We can define an approximation of such a function
  by bounding a priori the recursion depth, using a [fuel] parameter
  of type [nat].  When the fuel drops to 0, [None] is returned,
  meaning that the final store could not be computed. *)

Fixpoint cexec_bounded (fuel: nat) (s: store) (c: com) : option store :=
  match fuel with
  | O => None
  | S fuel' =>
      match c with
      | SKIP => Some s
      | ASSIGN x a => Some (update x (aeval s a) s)
      | SEQ c1 c2 =>
          match cexec_bounded fuel' s c1 with
          | None  => None
          | Some s' => cexec_bounded fuel' s' c2
          end
      | IFTHENELSE b c1 c2 =>
          if beval s b then cexec_bounded fuel' s c1 else cexec_bounded fuel' s c2
      | WHILE b c1 =>
          if beval s b then
            match cexec_bounded fuel' s c1 with
            | None  => None
            | Some s' => cexec_bounded fuel' s' (WHILE b c1)
            end
          else Some s
      end
  end.

(** This bounded execution function is great for testing programs.
    For example, let's compute the quotient and the remainder of 14 by
    3 using the Euclidean division program above. *)

Eval compute in
  (let s := update "a" 14 (update "b" 3 (fun _ => 0)) in
   match cexec_bounded 100 s Euclidean_division with
   | None => None
   | Some s' => Some (s' "q", s' "r")
   end).

(** *** Exercise (3 stars, optional) *)
(** Relate the [cexec] relation with the [cexec_bounded] function by
  proving the following two lemmas. *)

Lemma cexec_bounded_sound:
  forall fuel s c s', cexec_bounded fuel s c = Some s' -> cexec s c s'.
Proof.
  induction fuel as [ | fuel].
  - intros. simpl in H. inversion H.
  - destruct c; simpl; intros;
      try (inversion H; subst; constructor; clear H1).
    + destruct (cexec_bounded fuel s c1) eqn:H'; try inversion H.
      pose proof (IHfuel _ _ _ H').
      pose proof (IHfuel _ _ _ H).
      eapply cexec_seq; eassumption.
    + destruct (beval s b);
      apply IHfuel; assumption.
    + destruct (beval s b) eqn:Hsb.
      destruct (cexec_bounded fuel s c) eqn:H';
        try inversion H.
      pose proof (IHfuel _ _ _ H').
      pose proof (IHfuel _ _ _ H).
      econstructor; eassumption.
      inversion H; subst; constructor; assumption.
Qed.

Lemma cexec_bounded_complete:
  forall s c s', cexec s c s' ->
  exists fuel1, forall fuel, (fuel >= fuel1)%nat -> cexec_bounded fuel s c = Some s'.
Proof.
  induction 1.
  - (* SKIP *)
    exists 1%nat; intros.
    destruct fuel; try inversion H.
    constructor. reflexivity.
  - (* ASSIGN *)
    exists 1%nat; intros.
    destruct fuel; try inversion H.
    constructor. reflexivity.
  - (* SEQ *)
    destruct IHcexec1 as [fuel1 IHc1exec];
      assert (Hc1exec := IHc1exec fuel1 (ge_refl fuel1));
    destruct IHcexec2 as [fuel2 IHc2exec];
      assert (Hc2exec := IHc2exec fuel2 (ge_refl fuel2)).
      (* actually should be precisely  max(fuel1, fuel2)  *)
    exists (1 + fuel1 + fuel2)%nat; intros fuel Hfuel.
    destruct (ge_diff Hfuel) as [k Hk]; clear Hfuel; subst fuel.
    simpl.
    remember (fuel1 + fuel2 + k)%nat as fuel_big.
    assert (Hc1execBig: cexec_bounded fuel_big s c1 = Some s') by
      (apply IHc1exec; lia).
    assert (Hc2execBig: cexec_bounded fuel_big s' c2 = Some s'') by
      (apply IHc2exec; lia).
    destruct (cexec_bounded fuel_big s c1) eqn:Hc1;
      try inversion Hc1execBig.
    destruct (cexec_bounded fuel_big s' c2) eqn:Hc2;
      try inversion Hc2execBig.
    subst; reflexivity.
  - (* IFTHENELSE *)
    destruct IHcexec as [fuel IHcexec].
    exists (S fuel).
    intros fuel' Hfuel'; destruct (ge_diff Hfuel') as [k Hk]; clear Hfuel'; subst fuel'.
    simpl.
    destruct (beval s b) eqn:Hb;
      apply IHcexec; lia.
  - (* WHILEDONE *) exists 1%nat.
    intros fuel' Hfuel'; destruct (ge_diff Hfuel') as [k Hk]; clear Hfuel'; subst fuel'.
    simpl.
    rewrite H; reflexivity.
  - (* WHILELOOP *)
    destruct IHcexec1 as [fuel1 IHc1exec];
      assert (Hc1exec := IHc1exec fuel1 (ge_refl fuel1));
    destruct IHcexec2 as [fuel2 IHc2exec];
      assert (Hc2exec := IHc2exec fuel2 (ge_refl fuel2)).
    exists (1 + fuel1 + fuel2)%nat.
    intros fuel' Hfuel'; destruct (ge_diff Hfuel') as [k Hk]; clear Hfuel'; subst fuel'.
    simpl.
    rewrite H.
    remember (fuel1 + fuel2 + k)%nat as fuel_big.
    remember c as c1; remember (WHILE b c1) as c2.
    assert (Hc1execBig: cexec_bounded fuel_big s c1 = Some s') by
      (apply IHc1exec; lia).
    assert (Hc2execBig: cexec_bounded fuel_big s' c2 = Some s'') by
      (apply IHc2exec; lia).
    destruct (cexec_bounded fuel_big s c1) eqn:Hc1;
      try inversion Hc1execBig.
    destruct (cexec_bounded fuel_big s' c2) eqn:Hc2;
      try inversion Hc2execBig.
    subst; reflexivity.
Qed.

(** * 6. Small-step semantics for IMP *)

(** * 6.1 Reduction semantics *)

(** In small-step style, the semantics is presented as a one-step
  reduction relation [ red (c, s) (c', s') ], meaning that the command
  [c], executed in initial state [s], performs one elementary step of
  computation.  [s'] is the updated state after this step.  [c'] is
  the residual command, capturing all the computations that remain to
  be done.  *)

Inductive red: com * store -> com * store -> Prop :=
  | red_assign: forall x a s,
      red (ASSIGN x a, s) (SKIP, update x (aeval s a) s)
  | red_seq_done: forall c s,
      red (SEQ SKIP c, s) (c, s)
  | red_seq_step: forall c1 c s1 c2 s2,
      red (c1, s1) (c2, s2) ->
      red (SEQ c1 c, s1) (SEQ c2 c, s2)
  | red_ifthenelse: forall b c1 c2 s,
      red (IFTHENELSE b c1 c2, s) ((if beval s b then c1 else c2), s)
  | red_while_done: forall b c s,
      beval s b = false ->
      red (WHILE b c, s) (SKIP, s)
  | red_while_loop: forall b c s,
      beval s b = true ->
      red (WHILE b c, s) (SEQ c (WHILE b c), s).

(** *** Exercise (2 stars, recommended) *)
(** Show that Imp programs cannot go wrong.  Hint: first prove the following
  "progress" result for non-[SKIP] commands. *)

Lemma red_progress:
  forall c s, c = SKIP \/ exists c', exists s', red (c, s) (c', s').
Proof.
  induction c; intros;
    (* SKIP *)
    (try (left; reflexivity) || right);
    (* ASSIGN *)
    (* IFTHENELSE *)
    try (eexists; eexists; constructor; fail).
  - (* SEQ *)
    destruct c1;
      (* SEQ_DONE *)
      try (
        eexists; eexists; constructor;
        fail);
      (* SEQ_STEP *)
      try (
        specialize (IHc1 s); destruct IHc1 as [ IHc1 | IHc1 ]; try inversion IHc1;
        destruct IHc1 as [c1Next [sNext Hc1]];
        eexists; exists sNext; econstructor; eassumption;
        exists (c1Next ;; c2); exists sNext;
        apply red_seq_step; assumption;
        fail).
  - (* WHILE *)
    destruct (beval s b) eqn:Hb;
      eexists; eexists;
      [ apply red_while_loop | apply red_while_done ];
      assumption.
Qed.

Definition goes_wrong (c: com) (s: store) : Prop :=
  exists c', exists s',
  star red (c, s) (c', s') /\ irred red (c', s') /\ c' <> SKIP.

Lemma not_goes_wrong:
  forall c s, ~(goes_wrong c s).
Proof.
  intros c s (c' & s' & STAR & IRRED & NOTSKIP).
  pose proof (red_progress c' s').
  inversion H; intuition; clear H1 NOTSKIP.
  destruct H0 as [c'C [s'C Hred]].
  specialize (IRRED (c'C, s'C)).
  intuition.
Qed.

(** Sequences of reductions can go under a sequence context, generalizing
  rule [red_seq_step]. *)

Lemma red_seq_steps:
  forall c2 s c s' c',
  star red (c, s) (c', s') -> star red ((c;;c2), s) ((c';;c2), s').
Proof.
  intros. dependent induction H.
- apply star_refl.
- destruct b as [c1 st1].
  apply star_step with (c1;;c2, st1). apply red_seq_step. auto. auto.
Qed.

(** We now recall the equivalence result between
- termination according to the big-step semantics
- existence of a finite sequence of reductions to [SKIP]
  according to the small-step semantics.

We start with the implication big-step ==> small-step, which is
a straightforward induction on the big-step evaluation derivation. *)

Theorem cexec_to_reds:
  forall s c s', cexec s c s' -> star red (c, s) (SKIP, s').
Proof.
  induction 1.
- (* SKIP *)
  apply star_refl.
- (* ASSIGN *)
  apply star_one. apply red_assign.
- (* SEQ *)
  eapply star_trans. apply red_seq_steps. apply IHcexec1.
  eapply star_step.  apply red_seq_done.  apply IHcexec2.
- (* IFTHENELSE *)
  eapply star_step. apply red_ifthenelse. auto.
- (* WHILE stop *)
  apply star_one. apply red_while_done. auto.
- (* WHILE loop *)
  eapply star_step. apply red_while_loop. auto.
  eapply star_trans. apply red_seq_steps. apply IHcexec1.
  eapply star_step. apply red_seq_done. apply IHcexec2.
Qed.

(** The reverse implication, from small-step to big-step, is more subtle.
The key lemma is the following, showing that one step of reduction
followed by a big-step evaluation to a final state can be collapsed
into a single big-step evaluation to that final state. *)

Lemma red_append_cexec:
  forall c1 s1 c2 s2, red (c1, s1) (c2, s2) ->
  forall s', cexec s2 c2 s' -> cexec s1 c1 s'.
Proof.
  intros until s2; intros STEP. dependent induction STEP; intros.
- (* red_assign *)
  inversion H; subst. apply cexec_assign.
- (* red_seq_done *)
  apply cexec_seq with s2. apply cexec_skip. auto.
- (* red seq step *)
  inversion H; subst. apply cexec_seq with s'0.
  eapply IHSTEP; eauto.
  auto.
- (* red_ifthenelse *)
  apply cexec_ifthenelse. auto.
- (* red_while_done *)
  inversion H0; subst. apply cexec_while_done. auto.
- (* red while loop *)
  inversion H0; subst. apply cexec_while_loop with s'0; auto.
Qed.

(** As a consequence, a term that reduces to [SKIP] evaluates in big-step
  with the same final state. *)

Theorem reds_to_cexec:
  forall s c s',
  star red (c, s) (SKIP, s') -> cexec s c s'.
Proof.
  intros. dependent induction H.
- apply cexec_skip.
- destruct b as [c1 s1]. apply red_append_cexec with c1 s1; auto.
Qed.

(** ** 6.2 Transition semantics with continuations *)

(** We now introduce an alternate form of small-step semantics
  where the command to be executed is explicitly decomposed into:
- a sub-command under focus, where computation takes place;
- a continuation (or context) describing the position of this sub-command
  in the whole command, or, equivalently, describing the parts of the
  whole command that remain to be reduced once the sub-command is done.

As a consequence, the small-step semantics is presented as a
transition relation between triples (subcommand-under-focus,
continuation, state).  Previously, we had transitions between pairs
(whole-command, state).

The syntax of continuations is as follows:
*)

Inductive cont : Type :=
  | Kstop
  | Kseq (c: com) (k: cont)
  | Kwhile (b: bexp) (c: com) (k: cont).

(** Intuitive meaning of these constructors:
- [Kstop] means that, after the sub-command under focus terminates,
  nothing remains to be done, and execution can stop.  In other words,
  the sub-command under focus is the whole command.
- [Kseq c k] means that, after the sub-command terminates, we still need
  to execute command [c] in sequence, then continue as described by [k].
- [Kwhile b c k] means that, after the sub-command terminates, we still need
  to execute a loop [WHILE b DO c END], then continue as described by [k].
*)

(** Another way to forge intuitions about continuations is to ponder the following
  [apply_cont k c] function, which takes a sub-command [c] under focus
  and a continuation [k], and rebuilds the whole command.  It simply
  puts [c] in lefmost position in a nest of sequences as described by [k].
*)

Fixpoint apply_cont (k: cont) (c: com) : com :=
  match k with
  | Kstop => c
  | Kseq c1 k1 => apply_cont k1 (SEQ c c1)
  | Kwhile b1 c1 k1 => apply_cont k1 (SEQ c (WHILE b1 c1))
  end.

(** Transitions between (subcommand-under-focus, continuation, state)
  triples perform conceptually different kinds of actions:
- Computation: evaluate an arithmetic expression or boolean expression
  and modify the triple according to the result of the evaluation.
- Focusing: replace the sub-command by a sub-sub-command that is to be
  evaluated next, possibly enriching the continuation as a consequence.
- Resumption: when the sub-command is [SKIP] and therefore fully executed,
  look at the head of the continuation to see what to do next.

Here are the transition rules, classified by the kinds of actions they implement.
*)

Inductive step: com * cont * store -> com * cont * store -> Prop :=

  | step_assign: forall x a k s,              (**r computation for assignments *)
      step (ASSIGN x a, k, s) (SKIP, k, update x (aeval s a) s)

  | step_seq: forall c1 c2 s k,               (**r focusing for sequence *)
      step (SEQ c1 c2, k, s) (c1, Kseq c2 k, s)

  | step_ifthenelse: forall b c1 c2 k s,      (**r computation for conditionals *)
      step (IFTHENELSE b c1 c2, k, s) ((if beval s b then c1 else c2), k, s)

  | step_while_done: forall b c k s,          (**r computation for loops *)
      beval s b = false ->
      step (WHILE b c, k, s) (SKIP, k, s)

  | step_while_true: forall b c k s,          (**r computation and focusSKIing for loops *)
      beval s b = true ->
      step (WHILE b c, k, s) (c, Kwhile b c k, s)

  | step_skip_seq: forall c k s,              (**r resumption *)
      step (SKIP, Kseq c k, s) (c, k, s)

  | step_skip_while: forall b c k s,          (**r resumption *)
      step (SKIP, Kwhile b c k, s) (WHILE b c, k, s).

(** *** Extensions to other control structures *)

(** A remarkable feature of continuation semantics is that they extend very easily
  to other control structures besides "if-then-else" and "while" loops.
  Consider for instance the "break" construct of C, C++ and Java, which
  immediately terminates the nearest enclosing "while" loop.  Assume we
  extend the type of commands with a [BREAK] constructor.  Then, all we need
  to give "break" a semantics is to add two resumption rules:
<<
  | step_break_seq: forall c k s,
      step (BREAK, Kseq c k, s) (BREAK, k, s)
  | step_break_while: forall b c k s,
      step (BREAK, Kwhile b c k, s) (SKIP, k, s)
>>
  The first rule says that a [BREAK] statement "floats up" pending sequences,
  skipping over the computations they contain.  Eventually, a [Kwhile]
  continuation is encountered, meaning that the [BREAK] found its enclosing
  loop.  Then, the second rule discards the [Kwhile] continuation and
  turns the [BREAK] into a [SKIP], effectively terminating the loop.
  That's all there is to it!
**)

(** *** Exercise (2 stars, recommended) *)
(** Besides "break", C, C++ and Java also have a "continue" statement
  that terminates the current iteration of the enclosing loop,
  then resumes the loop at its next iteration (instead of stopping
  the loop like "break" does). Give the transition rules
  for the "continue" statement. *)
(**
<<
  | step_continue_seq: forall c k s,
      step (CONTINUE, Kseq c k, s) (CONTINUE, k, s)
  | step_continue_while_done: forall b c k s,
      beval s b = false ->
      step (CONTINUE, Kwhile b c k, s) (SKIP, k, s)
  | step_continue_while_true: forall b c k s,
      beval s b = true ->
      step (CONTINUE, Kwhile b c k, s) (c, Kwhile b c k, s)
*)

(** *** Exercise (3 stars, optional) *)
(** In Java, loops as well as "break" and "continue" statements carry
  an optional label.  "break" without a label exits out of the immediately
  enclosing loop, but "break lbl" exits out of the first enclosing loop
  that carries the label "lbl".  Similarly for "continue".
  Give the transition rules for "break lbl" and "continue lbl". *)

(** *** Relating the continuation semantics and the big-step semantics *)

(** *** Exercise (2 stars, optional) *)
(** Show that a big-step execution give rise to a sequence of steps to [SKIP].
  You can adapt the proof of theorem [cexec_to_reds] with minor changes. *)

Theorem cexec_to_steps:
  forall s c s', cexec s c s' -> forall k, star step (c, k, s) (SKIP, k, s').
Proof.
  induction 1; intros k.
  - (* SKIP *)
    constructor.
  - (* ASGN *)
    repeat econstructor.
  - (* SEQ *)
    econstructor. apply step_seq.
    eapply star_trans. apply IHcexec1.
    econstructor. apply step_skip_seq.
    apply IHcexec2.
  - (* IFTHENELSE *)
    econstructor. apply step_ifthenelse.
    apply IHcexec.
  - (* WHILE FALSE *)
    econstructor. apply step_while_done; try assumption.
    econstructor.
  - (* WHILE TRUE *)
    econstructor. apply step_while_true; try assumption.
    eapply star_trans. apply IHcexec1.
    econstructor. apply step_skip_while.
    apply IHcexec2.
Qed.

(** *** Exercise (3 stars, optional) *)
(** Show the converse result: a sequence of steps to [(SKIP, Kstop)] corresponds
  to a big-step execution.  You need a lemma similar to [red_append_cexec],
  but also a notion of big-step execution of a continuation. *)

Ltac easy_head :=
    eapply cexec_seq;
      try (eassumption; fail);
      try (econstructor; eassumption; fail).

Ltac inv_Hcexec := repeat match goal with
                    | H: cexec _ (_;; _) _ |- _ => inv H
                    | H: cexec _ SKIP _ |- _ => inv H
                    end.

Lemma cexec_head_skip_noop: forall s c s',
  cexec s c s' <-> cexec s (SKIP;; c) s'.
Proof.
  split; intros.
  - easy_head.
  - inv_Hcexec. assumption.
Qed.

Lemma cexec_tail_skip_noop: forall s c s',
  cexec s c s' <-> cexec s (c;; SKIP) s'.
Proof.
  split; intros.
  - easy_head.
  - inv_Hcexec. assumption.
Qed.

Ltac strip_cexec_skip := match goal with
                    | |- cexec _ (SKIP;; _) _ => rewrite <- cexec_head_skip_noop
                    | |- cexec _ (_;; SKIP) _ => rewrite <- cexec_tail_skip_noop
                    end.

Lemma apply_cont_seq: forall k c1 c2 s s',
  cexec s (SEQ c1 (apply_cont k c2)) s' <-> cexec s (apply_cont k (SEQ c1 c2)) s'.
Proof with easy_head.
  induction k; split; intros; simpl in *;
    try auto;
    try (
      inv_Hcexec;
      rewrite <- IHk in *;
      inv_Hcexec; easy_head);
    try (
      rewrite <- IHk in *;
      inv_Hcexec; easy_head;
      rewrite <- IHk in *; easy_head).
Qed.

Lemma apply_cont_done: forall k c s s',
  cexec s (SEQ c (apply_cont k SKIP)) s' <-> cexec s (apply_cont k c) s'.
Proof with repeat easy_head.
  induction k; split; intros; simpl in *.
  (* Kstop *)
  - inv_Hcexec...
    assumption.
  - strip_cexec_skip.
    assumption.
  (* Kseq *)
  - inv_Hcexec...
    rewrite <- IHk in *.
    inv_Hcexec...
  - rewrite <- IHk in *.
    inv_Hcexec...
    rewrite <- IHk in *.
    inv_Hcexec...
  (* Kwhile *)
  - inv_Hcexec...
    rewrite <- IHk in *.
    inv_Hcexec...
  - rewrite <- IHk in *.
    inv_Hcexec...
    rewrite <- IHk in *.
    inv_Hcexec...
Qed.

Inductive Wrapper {P: Prop} := mkWrap: P -> @Wrapper P.
Lemma deWrap: forall P, @Wrapper P -> P.
intros. inv H. assumption. Qed.

Ltac destruct_Hexec :=
  repeat match goal with
  | H: cexec _ (apply_cont _ (_;; _)) _ |- _=>
      rewrite <- apply_cont_seq in H; inv H
  | H: cexec _ (apply_cont _ SKIP) _ |- _=>
      pose proof (mkWrap H); clear H
  | H: cexec _ (apply_cont _ _) _ |- _ =>
      rewrite <- apply_cont_done in H; inv H
  end;
  repeat match goal with
  | H: @Wrapper _ |- _ =>
      apply deWrap in H
  end.

Ltac destruct_solve_goal :=
  repeat match goal with
  | |- cexec _ (apply_cont _ (_;; _)) _ =>
      rewrite <- apply_cont_seq; easy_head
  | |- cexec _ (apply_cont _ _) _ =>
      rewrite <- apply_cont_done; easy_head
  end.

Lemma step_append_cexec:
  forall c1 k1 s1 c2 k2 s2, step (c1, k1, s1) (c2, k2, s2) ->
  forall s', cexec s2 (apply_cont k2 c2) s' ->
  cexec s1 (apply_cont k1 c1) s'.
Proof with repeat easy_head.
  intros until s2; intros Hstep.
  dependent induction Hstep;
    intros; simpl in *;
    destruct_Hexec;
    destruct_solve_goal.
Qed.

Theorem steps_to_cexec:
  forall c s s' k, star step (c, k, s) (SKIP, Kstop, s') -> cexec s (apply_cont k c) s'.
Proof.
  intros. dependent induction H.
  - apply cexec_skip.
  - destruct b as [[c1 k1] s1]. apply step_append_cexec with c1 k1 s1; auto.
Qed.

Section UNUSED.
Inductive stepexec: store -> cont -> store -> Prop :=
  | stepexec_stop: forall s,
      stepexec s Kstop s

  | stepexec_seq_skip: forall s s' k,
      stepexec s k s' ->
      stepexec s (Kseq SKIP k) s'
  | stepexec_seq_assign: forall s x a s' k,
      stepexec (update x (aeval s a) s) k s' ->
      stepexec s (Kseq (ASSIGN x a) k) s'
  | stepexec_seq_seq: forall s c1 c2 s' k,
      stepexec s (Kseq c1 (Kseq c2 k)) s' ->
      stepexec s (Kseq (SEQ c1 c2) k) s'
  | stepexec_seq_ifthenelse: forall s b c1 c2 s' k,
      stepexec s (Kseq (if (beval s b) then c1 else c2) k) s' ->
      stepexec s (Kseq (IFTHENELSE b c1 c2) k) s'
  | stepexec_seq_while: forall s b c s' k,
      stepexec s (Kwhile b c k) s' ->
      stepexec s (Kseq (WHILE b c) k) s'

  | stepexec_while_done: forall s b c s' k,
      beval s b = false ->
      stepexec s k s' ->
      stepexec s (Kwhile b c k) s'
  | stepexec_while_loop: forall s b c s' k,
      beval s b = true ->
      stepexec s (Kseq c (Kwhile b c k)) s' ->
      stepexec s (Kwhile b c k) s'.

Lemma stepexec_to_cexec: forall s s' k,
  stepexec s k s' -> cexec s (apply_cont k SKIP) s'.
Proof.
  intros *. intros Hstepexec. dependent induction Hstepexec.
  - (* Kstop *)
    simpl in *. apply cexec_skip.
  - (* Kseq SKIP k *)
    simpl in *. rewrite <- apply_cont_seq.
    eapply cexec_seq. econstructor.
    assumption.
  - (* Kseq ASSIGN k *)
    simpl in *. rewrite <- apply_cont_seq.
    eapply cexec_seq. econstructor.
    rewrite <- apply_cont_done.
    eapply cexec_seq. econstructor. assumption.
  - (* Kseq SEQ k *)
    simpl in *.
    rewrite <- apply_cont_seq in IHHstepexec.
    inv IHHstepexec. inv H2. inv H3.
    rewrite <- apply_cont_seq.
    eapply cexec_seq. econstructor.
    rewrite <- apply_cont_seq.
    eapply cexec_seq. eassumption. assumption.
  - (* Kseq IFTHENELSE k *)
    simpl in *.
    rewrite <- apply_cont_seq in IHHstepexec.
    inv IHHstepexec. inv H2.
    rewrite <- apply_cont_seq.
      eapply cexec_seq. econstructor.
    rewrite <- apply_cont_done.
    rewrite <- apply_cont_done in H4.
    inv H4.
      eapply cexec_seq. econstructor.
      eassumption.
      assumption.
  - (* Kseq WHILE k *)
    simpl in *. assumption.
  - (* KWhile false c k *)
    simpl in *.
    rewrite <- apply_cont_seq.
    eapply cexec_seq. econstructor.
    rewrite <- apply_cont_done.
    eapply cexec_seq. econstructor; assumption.
    assumption.
  - (* KWhile true c k *)
    (*remember (Kwhile b c k) as kw.*)
    simpl in *.
    rewrite <- apply_cont_seq in IHHstepexec.
    inv IHHstepexec. inv H3. inv H4.
    rewrite <- apply_cont_done in H5.
    inv H5.
    rewrite <- apply_cont_seq.
    eapply cexec_seq. econstructor.
    rewrite <- apply_cont_done.
    eapply cexec_seq. eapply cexec_while_loop.
    eassumption. eassumption. eassumption. eassumption.
Qed.
End UNUSED.


Theorem ex21: forall a b : Prop,
               (a /\ b) <-> (b /\ a).
Proof.
  split. intro. elim H. intros.
  split. assumption. assumption.
  intro. elim H. intros. split.
  assumption. assumption.
Qed.

Theorem ex22: forall a b : Prop,
               (a \/ b) <-> (b \/ a).
Proof.
  split. intro. elim H. intro. right. assumption.
  intro. left. assumption. intro. elim H. intro.
  right. assumption. intro. left. assumption.
Qed.

Theorem ex23: forall a b : Prop,
               (a <-> b) <-> (b <-> a).
Proof.
  split. intro. elim H. intros. split.
  assumption. assumption.
  intro. elim H. intros. split.
  assumption. assumption.
Qed.


Require Export Tree_Inf  RelationClasses.

Set Implicit Arguments.

Section LTree_bisimilar_def.
Variable A:Type.

(* An extensional equality on (LTree A) *)

CoInductive LTree_bisimilar :  LTree A -> LTree A -> Prop :=
  LTree_bisimilar_leaf : LTree_bisimilar LLeaf LLeaf
| LTree_bisimilar_bin : forall (a:A) (t1 t'1 t2 t'2 : LTree A),
                LTree_bisimilar t1 t'1 ->
                LTree_bisimilar t2 t'2 ->
                LTree_bisimilar (LBin a t1 t2) (LBin a t'1 t'2).

Instance LTree_bisimilar_refl : Reflexive  LTree_bisimilar.
Proof.
 cofix H; intro a; case a ; constructor; auto.
Qed.

Instance LTree_bisimilar_sym : Symmetric LTree_bisimilar.
Proof.
 cofix H.
 intros x y; case x; case y.
  - left.
  -  inversion_clear 1.
  -  inversion_clear 1.
  -  inversion_clear 1;  now right.
Qed.

Instance  LTree_bisimilar_trans : Transitive  LTree_bisimilar.
Proof.
 cofix H; intros x y z ; case x; case y.
 - inversion 2; constructor.
 - inversion 1.
 - inversion 1.
 -  inversion_clear 1.
     case z; inversion_clear 1;  right; now eapply H; eauto.
Qed.

Global Instance  bisimilar_equiv : Equivalence LTree_bisimilar.
Proof.
 split;[apply LTree_bisimilar_refl |
        apply LTree_bisimilar_sym  |
        apply LTree_bisimilar_trans].
Qed.

 Theorem LTree_bisimilar_label :
   forall (p:path) (t t': LTree A),
          LTree_bisimilar t t' ->
          LTree_label t p = LTree_label t' p.
 Proof.
  simple induction p.
  intros t t'; case t, t'.
  - reflexivity.
  -  inversion_clear 1.
  -  inversion_clear 1.
  -  inversion_clear 1; simpl; auto.
  -  intros a l;case a; intros H t t'; case t, t'.
    + reflexivity.
    +  inversion_clear 1.
    +  inversion_clear 1.
    +  inversion_clear 1; cbn; repeat  rewrite LTree_label_rw0; auto.
    +  repeat  rewrite LTree_label_rw1; auto.
    +  inversion_clear 1.
    +  inversion_clear 1.
    +  inversion_clear 1; repeat  rewrite LTree_label_rw1; auto.
 Qed.

 Theorem label_LTree_bisimilar :  forall t t': LTree A,
                          (forall p:path, LTree_label t p = LTree_label t' p)->
                          LTree_bisimilar t t'.
 Proof.
  cofix.
  intros t t'; case t; case t'.
  - left.
  - intros a l l0 H; discriminate (H nil).
  - intros a l l0 H; discriminate (H nil).
  - intros a l l0 a0 t1 t2 H.
   assert (e : a = a0) by
        (generalize (H nil); injection 1; congruence).
   subst a0;  constructor;  apply label_LTree_bisimilar; intro p.
   +  generalize (H (cons d0 p));repeat rewrite LTree_label_rw0; auto.
   +  generalize (H (cons d1 p)); repeat rewrite LTree_label_rw1; auto.
 Qed.

End LTree_bisimilar_def.


Require Arith.

Inductive F: Set :=
   | one : F (* 1 *)
   | n : F -> F (* 1 + f *)
   | d : F -> F (* 1 / (1 + (1 / f)) *)
.

Fixpoint  fraction (f : F) : nat * nat :=
  match f with
  | one => (1,1)
  | n f' => let (a, b) := fraction f' in (a + b, b)
  | d f' => let (a, b) := fraction f' in (a, a + b)
 end.

(** Test:
Compute  fraction (d (d (n (d (d one))))).

= (4, 11) : nat*nat

*)

(****************************************************************************

 bonus proof (for readers of chapter 8) :
   Let us admit that a/b is irreducible if
   there exists u, v in Z such that au+bv=1.
   Then fraction f is irreducible for every f

*****************************************************************************)

Require Import ZArith.

Open Scope Z_scope.
Inductive bezout (a b:nat): Prop :=
 mk_bezout :  forall u v : Z,
              (lt 0 a) ->
              (lt 0 b) ->
              (Z_of_nat a) * u +  (Z_of_nat b) * v = 1  ->
               bezout a b.

Lemma b_one : bezout 1 1.
Proof.
  split with 1 0 ; auto.
Qed.

Lemma b_n : forall a b : nat, bezout a b -> bezout (a + b)%nat b.
Proof.
 intros a b H; case H.
 intros u v H0 HA e.
 split with u (v-u).
 -  auto with arith.
 -  auto.
 -  rewrite inj_plus; now  ring_simplify.
Qed.

Lemma b_d : forall a b : nat, bezout a b -> bezout a (a + b)%nat.
Proof.
 intros a b H; case H.
 intros u v H0 HA e.
 split with  (u-v) v.
 -  auto.
 - auto with zarith.
 - rewrite inj_plus;  ring_simplify;
   now  rewrite (Zmult_comm v (Z_of_nat b)).
Qed.

Hint Resolve b_one b_d b_n.

Inductive simplified : nat*nat -> Prop :=
  mk_simpl : forall a b : nat, bezout a b -> simplified (a, b).

Lemma fractionsimplified  : forall f : F,
                              simplified (fraction f).
Proof.
 simple induction f ; simpl.
 -  split ; auto.
 -  intro f0; case (fraction f0).
    inversion_clear  1;split; auto.
 -  intro f0; case (fraction f0).
     inversion_clear  1; split; auto.
Qed.


Check (fun x : nat => x).
Check (fun x : True => x).
Check I.
Check (fun _ : False => I).
Check (fun x : False => x).
Inductive unit : Set := | tt.
Check unit.
Check tt.
Theorem unit_singleton : forall x : unit, x = tt.
Proof. induction x. auto. Qed.
Check unit_ind.
Inductive test : Set := t1 | t2.
Check test_ind.
Inductive Empty_set : Set := .
Theorem the_sky_is_falling : forall x : Empty_set, 2+2=5.
Proof. intros. inversion x. Qed.
Theorem false_ : forall P Q : Prop, P -> ~P -> Q.
Proof. intros. destruct H0. apply H. Qed.
Inductive nat_list : Set :=
| NNil : nat_list
| NCons : nat -> nat_list -> nat_list.

Fixpoint nlength (ls:nat_list) : nat :=
  match ls with
  | NNil => O
  | NCons _ ls' => S (nlength ls')
  end.

Fixpoint napp (ls1 ls2 : nat_list) : nat_list :=
  match ls1 with
  | NNil => ls2
  | NCons n ls1' => NCons n (napp ls1' ls2)
  end.

Theorem nlength_app : forall ls1 ls2:nat_list, nlength (napp ls1 ls2) = plus (nlength ls1) (nlength ls2).
Proof. induction ls1; auto. intros.
  simpl. f_equal. auto. Qed.

Check nat_list_ind.

Inductive nat_btree:Set:=
|NLeaf : nat_btree
|NNode:nat_btree->nat->nat_btree->nat_btree.

Fixpoint nsize (tr:nat_btree):nat:=
  match tr with
  | NLeaf => S O
  | NNode tr1 _ tr2 => plus (nsize tr1) (nsize tr2)
  end.

Fixpoint nsplice (tr1 tr2:nat_btree):nat_btree:=
  match tr1 with
  | NLeaf => NNode tr2 O NLeaf
  | NNode tr1' n tr2' => NNode (nsplice tr1' tr2) n tr2'
  end.

Theorem plus_assoc : forall a b c, a+b+c=a+(b+c).
Proof. induction a; auto. intros. repeat rewrite plus_Sn_m. auto. Qed.

Theorem nsize_nsplice : forall tr1 tr2:nat_btree, nsize (nsplice tr1 tr2) = plus (nsize tr2) (nsize tr1).
Proof. induction tr1; auto. intros. simpl. erewrite IHtr1_1. rewrite plus_assoc. reflexivity. Qed.
Check nat_btree_ind.
Print nsize_nsplice.

Inductive list (T:Set) : Set :=
| Nil:list T
| Cons:T->list T->list T.

Implicit Arguments Nil [T].

Fixpoint length (T:Set) (ls:list T) :nat:=
  match ls with
  | Nil => O
  | Cons _ _ ls' => S (length T ls')
  end.

Inductive even_list : Set :=
|ENil : even_list
| ECons : nat->odd_list->even_list
with odd_list : Set :=
     |OCons : nat->even_list->odd_list.

Fixpoint elength (el:even_list):nat :=
  match el with
  | ENil => O
  | ECons _ ol => S (olength ol)
  end
with olength (ol:odd_list) : nat :=
       match ol with
       | OCons _ el => S (elength el)
       end.

Fixpoint eapp (el1 el2 : even_list) : even_list:=
  match el1 with
  | ENil => el2
  | ECons n ol => ECons n (oapp ol el2)
  end
with oapp ( ol :odd_list) (el : even_list) : odd_list:=
       match ol with
       | OCons n el' => OCons n (eapp el' el)
       end.

Theorem elength_eapp : forall el1 el2:even_list,
    elength (eapp el1 el2) = plus (elength el1) (elength el2).


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

Lemma and_true_left :
  forall b, and_bool true b = b.
Proof.
  induction b; auto.
Qed.

Lemma and_false_left :
  forall b, and_bool false b = false.
Proof.
  auto.
Qed.

Lemma and_com :
  forall b b', and_bool b b' = and_bool b' b.
Proof.
  induction b; induction b'; auto.
Qed.

Lemma and_assocc :
  forall b1 b2 b3, and_bool b1 (and_bool b2 b3) = and_bool (and_bool b1 b2) b3.
Proof.
  induction b1; induction b2; induction b3; auto.
Qed.

Lemma zero_identity_add_right :
  forall n, n + 0 = n.
Proof.
  induction n; simpl; try (rewrite IHn);reflexivity.
Qed.

Lemma add_inc :
  forall m n, S (m + n) = m + S n.
Proof.
  induction m; intro n; simpl; try (rewrite IHm); reflexivity.
Qed.

Lemma add_commut :
  forall n m, n + m = m + n.
Proof.
  induction n; intro m; simpl;
  repeat ((rewrite IHn) || (apply add_inc));
  try (rewrite zero_identity_add_right); reflexivity.
Qed.

Lemma add_associative :
  forall n m p, n + (m + p) = (n + m) + p.
Proof.
  induction n; intros m p; simpl; try (rewrite IHn); reflexivity.
Qed.

Lemma one_identity_times_right :
  forall n, n * 1 = n.
Proof.
  induction n; simpl; try rewrite IHn; reflexivity.
Qed.

Lemma one_identity_times_left :
  forall n, 1 * n = n.
Proof.
  induction n; simpl;
  try rewrite IHn;
  try rewrite zero_identity_add_right;
  reflexivity.
Qed.

Lemma add_mult_1 :
  forall n m p, (n + m) * p = n * p + m * p.
Proof.
  induction n; intros m p; simpl;
  try rewrite IHn;
  try apply add_associative;
  auto.
Qed.

Lemma times_associative :
  forall n m p, (n * m) * p = n * (m * p).
Proof.
  induction n; intros m p; simpl;
  try rewrite <- IHn;
  try apply add_mult_1;
  reflexivity.
Qed.

Lemma add_1 :
  forall n m p, n + (m + p) = m + (n + p).
Proof.
  induction n; simpl; intros m p;
  try rewrite IHn;
  try apply add_inc;
  auto.
Qed.

Lemma times_1 :
  forall n m, n + n * m = n * S m.
Proof.
  induction n; simpl; intro m;
  try rewrite <- IHn;
  try rewrite <- add_1; auto.
Qed.

Lemma times_commut :
  forall n m, n * m = m * n.
Proof.
  induction n; intros m; simpl;
  try rewrite IHn;
  try apply times_1;
  auto.
Qed.

Fixpoint not_bool (b : bool) : bool :=
  match b with
    | true => false
    | false => true
  end.

Lemma not_not_b :
  forall b, not_bool (not_bool b) = b.
Proof.
  intro b ;destruct b;auto.
Qed.

Fixpoint even_bool (n : nat) : bool :=
  match n with
    | 0 => true
    | S n => not_bool (even_bool n)
  end.

Lemma even_add_n :
  forall n, even_bool (n + n) = true.
Proof.
  induction n;
  simpl;
  try rewrite add_commut;
  simpl;
  try rewrite IHn;
  auto.
Qed.

Fixpoint odd_bool (n : nat) : bool :=
  match n with
    | 0 => false
    | S n => not_bool (odd_bool n)
  end.

Lemma odd_add_n_n :
  forall n, odd_bool (n + n) = false.
Proof.
  induction n; simpl; auto;
  try rewrite add_commut; simpl;
  try rewrite IHn; auto.
Qed.

Lemma odd_add_n :
  forall n, odd_bool (n + S n) = true.
Proof.
  induction n;
  simpl;
  try rewrite add_commut;
  simpl;
  try rewrite odd_add_n_n;
  auto.
Qed.

Lemma even_SS :
  forall n, even_bool n = even_bool (S (S n)).
Proof.
  induction n; simpl;
  try rewrite not_not_b; auto.
Qed.

Lemma odd_SS :
  forall n, odd_bool n = odd_bool (S (S n)).
Proof.
  induction n; simpl;
  try rewrite not_not_b; auto.
Qed.

Lemma even_bool_S:
  forall n, even_bool n = not_bool (even_bool (S n)).
Proof.
  induction n; simpl;
  try rewrite not_not_b; auto.
Qed.

Require Import List.

Lemma repeat_length {A : Type} :
  forall (n : nat)(x : A), length (repeat x n) = n.
Proof.
  induction n; intros x; simpl;
  try rewrite IHn;
  reflexivity.
Qed.

Lemma app_nil_right {A : Type} :
  forall (xs : list A), xs ++ nil = xs.
Proof.
  induction xs; simpl;
  try rewrite IHxs;
  reflexivity.
Qed.

Lemma app_assoc {A : Type} :
  forall (xs ys zs : list A), xs ++ (ys ++ zs) = (xs ++ ys) ++ zs.
Proof.
  induction xs; intros ys zs; simpl;
  try rewrite IHxs;
  reflexivity.
Qed.

Lemma map_app {A B : Type}{f : A -> B}
  : forall xs ys, map f (xs ++ ys) = map f xs ++ map f ys.
Proof.
  induction xs; intros; simpl;
  try rewrite IHxs;
  reflexivity.
Qed.

Lemma reverse_app {A : Type}
  : forall (xs ys : list A), rev (xs ++ ys) = rev ys ++ rev xs.
Proof.
  induction xs; intros; simpl;
  try rewrite app_nil_right;
  try rewrite IHxs;
  try rewrite app_assoc;
  reflexivity.
Qed.

Lemma reverse_inv {A : Type}
  : forall (xs : list A), rev (rev xs) = xs.
Proof.
  induction xs; simpl;
  try rewrite reverse_app;
  simpl;
  try rewrite IHxs;
  auto.
Qed.

Inductive even : nat -> Prop :=
| ev_zero : even 0
| ev_ss   : forall n, even n -> even (S (S n)).

Definition double (n : nat) := 2 * n.

Lemma double_2 :
  forall n, double n = n + n.
Proof.
  unfold double;
  induction n;
  simpl;
  try rewrite zero_identity_add_right;
  auto.
Qed.

Lemma double_even :
  forall n, even (double n).
Proof.
  unfold double; induction n; simpl;
  try rewrite IHn;
  try apply ev_zero;
  try rewrite zero_identity_add_right;
  try rewrite add_commut;
  simpl;
  try rewrite <- double_2;
  unfold double;
  try apply ev_ss;
  auto.
Qed.

Lemma le_refl :
  forall n, n <= n.
Proof.
  apply le_n.
Qed.

Lemma le_cong_S :
  forall n m, n <= m -> S n <= S m.
Proof.
  intros;
  induction H;
  try apply le_refl;
  try apply le_S;
  auto.
Qed.

Lemma le_S_cong :
  forall n m, S n <= S m -> n <= m.
Proof.
  intros;
  induction m;
  inversion H;
  try apply le_refl;
  try inversion H1;
  auto.
Qed.

Lemma le_trans :
  forall n m p, n <= m -> m <= p -> n <= p.
Proof.
  induction n; intros; try rewrite H; auto.
Qed.

Lemma le_zero_antisym_left :
  forall n, 0 <= n -> n <= 0 -> 0 = n.
Proof.
  induction n; intros; auto.
  inversion H0.
Qed.

Lemma le_antisym :
  forall n m, n <= m -> m <= n -> n = m.
Proof.
  induction n; intros;
  try apply le_zero_antisym_left;
  inversion H;
  subst; auto; subst;
  apply f_equal;
  apply IHn;
  apply le_S_cong;
  auto.
Qed.

Import ListNotations.

Inductive Sorted : list nat -> Prop :=
  | sorted_nil : Sorted []
  | sorted_cons1 a : Sorted [a]
  | sorted_consn a b l : Sorted (b :: l) -> a <= b -> Sorted (a :: b :: l) .

Example test_sorted1 : Sorted [].
  Proof.
    apply sorted_nil.
  Qed.

Example test_sorted2 : Sorted [10].
  Proof.
    apply sorted_cons1.
  Qed.

Example test_sorted3 : Sorted [1 ; 3 ; 5 ].
Proof.
  repeat ((apply sorted_consn)||(apply sorted_cons1)||(apply le_n)||(apply le_S)).
Qed.

Reserved Notation "x '<<=' y" (at level 40, no associativity).

Inductive le_alt : nat -> nat -> Prop :=
| le_alt_zero : forall n, 0 <<= n
| le_alt_succ : forall n m, n <<= m -> S n <<= S m
where "x '<<=' y" := (le_alt x y).

Lemma le_alt_refl :
  forall n, n <<= n.
Proof.
  induction n;
  try apply le_alt_zero;
  try apply le_alt_succ;
  try apply IHn.
Qed.

Lemma le_alt_trans
  : forall n m p, n <<= m -> m <<= p -> n <<= p.
Proof.
  induction n; intros; try apply le_alt_zero;
  inversion H0;
  subst;
  inversion H;
  subst;
  apply le_alt_succ;
  apply (IHn n0 m0);
  inversion H;
  auto.
Qed.

Lemma le_alt_antisym :
  forall n m, n <<= m -> m <<= n -> n = m.
Proof.
  induction n; intros.
  inversion H0; auto.
  inversion H;
  subst;
  apply f_equal;
  apply (IHn m0);
  inversion H0;
  auto.
Qed.

Lemma le_zero :
  forall n, 0 <= n.
Proof.
  induction n ; constructor ; try assumption.
Qed.

Lemma le_alt_equiv_le :
  forall n m, n <<= m <-> n <= m.
Proof.
  induction n ; intros ; split ; intros; try apply le_zero; try constructor;
  destruct m;
  inversion H;
  subst;
  try apply le_alt_refl;
  try apply le_cong_S;
  try apply IHn in H2;
  try apply le_S_cong in H;
  try apply IHn in H;
  try constructor;
  auto.
Qed.


(** * pair: encoding pairs of ordinals as ordinals *)
(** more precisely, [ord n * ord m] into [ord (n*m)] *)

Require Import Psatz PeanoNat Compare_dec Euclid.
Require Import ordinal.

Set Asymmetric Patterns.
Set Implicit Arguments.
Local Open Scope ltb_scope.

(** equivalence between our Boolean strict order on [nat],
   and the standard one from the standard library  *)
Lemma ltb_lt x y: ltb x y = true <-> lt x y.
Proof.
  revert y. induction x; destruct y; simpl.
   split. discriminate. inversion 1.
   split. lia. trivial.
   split. discriminate. inversion 1.
   rewrite IHx. lia.
Qed.

(** auxiliary lemma *)
Lemma mk_lt n m x y: x<n -> y<m -> y*n+x < n*m.
Proof. setoid_rewrite ltb_lt. nia. Qed.

(** since [x] is bounded by [n], we encode the pair [(x,y)] as [y*n+x] *)
Definition mk n m (x: ord n) (y: ord m): ord (n*m).
destruct x as [x Hx]; destruct y as [y Hy].
apply Ord with (y*n+x).
now apply mk_lt.
Defined.

Lemma ord_nm_lt_O_n {n m} (x: ord (n*m)): lt 0 n.
Proof. destruct n. elim (ord_0_empty x). lia. Qed.

(** first projection, by modulo *)
Definition pi1 {n m} (p: ord (n*m)): ord n :=
  let '(divex _ x Hx _) := eucl_dev n (ord_nm_lt_O_n p) p in (Ord x (proj2 (ltb_lt _ _) Hx)).

(** second projection, by division *)
Definition pi2 {n m} (p: ord (n*m)): ord m.
destruct (eucl_dev n (ord_nm_lt_O_n p) p) as [y x Hx Hy].
apply Ord with y.
unfold gt in *.
destruct p as [p Hp]. simpl in Hy. rewrite Hy in Hp. clear p Hy.
destruct (le_lt_dec m y) as [Hy|Hy]. 2: now apply ltb_lt. exfalso.
apply ltb_lt in Hp. abstract nia.
Defined.

Lemma euclid_unique n: lt 0 n ->
  forall x y x' y', lt x n -> lt x' n -> y*n+x = y'*n+x' -> y=y' /\ x=x'.
Proof.
  intros Hn x y x' y' Hx Hx' H. rewrite Nat.mul_comm, (Nat.mul_comm y') in H. split.
   erewrite Nat.div_unique. 3: eassumption. 2: assumption.
   rewrite H. eapply Nat.div_unique. 2: symmetry; eassumption. assumption.
   erewrite Nat.mod_unique. 3: eassumption. 2: assumption.
   rewrite H. eapply Nat.mod_unique. 2: symmetry; eassumption. assumption.
Qed.

(** projections behave as expected *)
Lemma pi1mk n m: forall x y, pi1 (@mk n m x y) = x.
Proof.
  intros [x Hx] [y Hy]. unfold pi1, mk. case eucl_dev.
  intros y' x' Hx' H. apply eq_ord. apply euclid_unique in H as [_ ?]; auto.
  nia. now apply ltb_lt.
Qed.

Lemma pi2mk n m: forall x y, pi2 (@mk n m x y) = y.
Proof.
  intros [x Hx] [y Hy]. unfold pi2, mk. case eucl_dev.
  intros y' x' Hx' H. apply eq_ord. simpl. apply euclid_unique in H as [? _]; auto.
  nia. now apply ltb_lt.
Qed.

(** surjective pairing *)
Lemma mkpi12 n m: forall p, @mk n m (pi1 p) (pi2 p) = p.
Proof.
  intros [p Hp]. unfold pi1, pi2, mk. case eucl_dev. simpl. intros y x Hx Hy.
  apply eq_ord. simpl. now rewrite Hy.
Qed.


Require Import Lia.
Require Import List.

(** * Basic lemmas and functions *)

(** ** Empty lists and membership*)
Definition isNil {A : Type} (l : list A) : Prop :=
  match l with
  | nil => True
  | _ => False
  end.

Proposition isNil_no_member
            {A : Type}
            (l : list A)
            (Hl : isNil l)
            (x : A)
  : ~(In x l).
Proof.
  induction l ; cbn in *.
  - exact (fun z => z).
  - contradiction.
Qed.

(** ** Lemma about addition *)
Proposition plus_ge
            {n1 n2 m1 m2 : nat}
            (p : n1 >= n2)
            (q : m1 >= m2)
  : n1 + m1 >= n2 + m2.
Proof.
  lia.
Qed.

Proposition mult_ge
            {k n m : nat}
            (p : n >= m)
  : k * n >= k * m.
Proof.
  nia.
Qed.

(** ** Basics functions *)

Arguments id {_} _/.

Definition comp
           {X Y Z : Type}
           (g : Y -> Z)
           (f : X -> Y)
           (x : X)
  : Z
  := g(f x).

Notation "g 'o' f" := (comp g f) (at level 40, left associativity).
Arguments comp {_ _ _} _ _ _/.


Module Play.

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

  Fixpoint plus (a b : nat) :=
    match a, b with
      | O, n => n
      | (S m) , n => plus m (S n)
    end.

  Theorem plus_O_n : forall n : nat, plus O n = n.
  Proof.
    intros n.
    reflexivity.
  Qed.
  Theorem plus_n_O : forall n : nat, plus n O = n.
  Proof.
    intros n.
    simpl.
  Abort.
  Theorem plus_1_l : forall n : nat, plus (S O) n = S n.
  Proof.
    intros n.
    simpl.
    reflexivity.
  Qed.
  Theorem plus_id_example : forall n m :nat,
                              n = m ->
                              plus n n = plus m m.
  Proof.
    intros m n.
    intros H.
    rewrite -> H.
    reflexivity.
  Qed.
  Theorem plus_id_exercise :
    forall n m o : nat,
      n = m -> m = o -> plus n m = plus m o.
  Proof.
    intros n m o.
    intros H1.
    intros H2.
    rewrite -> H1.
    rewrite <- H2.
    reflexivity.
  Qed.

  Fixpoint mult (n m : nat) : nat :=
    match n, m with
      | O, _ => O
      | (S n'), m => plus m (mult n' m)
    end.
  Theorem mult_O_plus :
    forall n m : nat,
      (mult (plus O n) m) = mult n m.
  Proof.
    intros n m.
    rewrite <- plus_O_n.
    simpl.
    reflexivity.
  Qed.

  Theorem mult_S_1 :
    forall n m : nat,
      m = S n ->
      mult m (plus (S O) n) = mult m m.
  Proof.
    intros n m.
    intros H1.
    simpl.
    rewrite <- H1.
    reflexivity.
  Qed.

  Inductive bool : Type :=
  | true : bool
  | false : bool.

  Fixpoint beq_nat (a b : nat) : bool :=
    match a, b with
      | O, O => true
      | O, S n => false
      | S n , O => false
      | S n , S m => beq_nat n m
    end.

  Theorem plus_1_neq_0_firsttry :
    forall n : nat,
      beq_nat (plus n (S O)) O = false.
  Proof.
    intros n.
    destruct n as [| n' ].
    reflexivity.

    simpl.

  Abort.

  Theorem plus_exch:
    forall n m,
      plus n (S m) = plus (S n) m.

  Proof.
    intros n m.
    simpl.
    reflexivity.
  Qed.

  Theorem plus_1_neq_0_firsttry :
    forall n : nat,
      beq_nat (plus n (S O)) O = false.

  Proof.
    intros n.
    rewrite -> plus_exch.
    destruct n as [O | n'].
    reflexivity.
  Abort.

  Theorem identif_fn_applied_twice :
    forall (f : bool -> bool),
      (forall (x : bool), f x = x) ->
      forall (b : bool), f (f b) = b.
  Proof.
    intros f.
    intros x.
    intros b.
    rewrite -> x.
    rewrite -> x.
    reflexivity.
  Qed.

  Theorem pl0:
    forall (x : nat),
      plus (S O) x = S x.
  Proof.
    reflexivity.
  Qed.
 (*   Theorem pl00:
      forall (m n :nat),
       S m = S n -> m = n.
    Proof.
      intros m n.
      intros H.
      induction m as [| m'].
      reflexivity.*)
      Theorem pl1:
    forall (n: nat),
    forall (a b : nat),
      plus n (plus a b) = plus (plus n a) b.
    intros n.
    induction n as [| n'].
    reflexivity.
    simpl.
    rewrite <- IHn'.


Require Import ZArith.
Require Import Znumtheory.
Require Import Unicode.Utf8.
Open Scope Z_scope.

Fixpoint sumdigits n (f : nat -> Z) :=
  match n with
  | O => f O
  | S n => f (S n) + sumdigits n f
  end.

Fixpoint number n (f : nat -> Z) :=
  match n with
  | O => f O
  | S n => f (S n) + 10 * number n f
  end.

Theorem div3 : ∀ n d,
  (number n d) mod 3 = (sumdigits n d) mod 3.
Proof.
  intros n d; induction n.
    auto.

    change ((d (S n) + 10 * number n d) mod 3 = (d (S n) + sumdigits n d) mod 3).
    rewrite Zplus_mod, Zmult_mod, IHn.
    remember (sumdigits n d) as SU.
    replace (10 mod 3) with 1 by trivial.
    rewrite Zmult_1_l, Zmod_mod.
    rewrite <- Zplus_mod.
    reflexivity.
Qed.

Theorem div9 : ∀ n d,
  (number n d) mod 9 = (sumdigits n d) mod 9.
Proof.
  intros n d; induction n.
    auto.

    change ((d (S n) + 10 * number n d) mod 9 = (d (S n) + sumdigits n d) mod 9).
    rewrite Zplus_mod, Zmult_mod, IHn.
    remember (sumdigits n d) as SU.
    replace (10 mod 9) with 1 by trivial.
    rewrite Zmult_1_l, Zmod_mod.
    rewrite <- Zplus_mod.
    reflexivity.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 0 *)

Require Import Frap.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(* This lightweight pset is meant to force you to get started installing Coq
 * and finding bugs in our homework-submission system!  *ahem*  We meant
 * "learning to use our homework-submission system." ;-) *)

(* The Coq standard library contains a definition of a type of lists, a common
 * concept in functional programming.  More mainstream languages might call such
 * a thing an "immutable, singly linked list."
 *
 * Here's the type definition, which is effectively included automatically,
 * by default, in any Coq file.
 * <<
     Inductive list A :=
       nil
     | cons (hd : A) (tl : list A).
   >>
 *
 * [A] is a type parameter.  (Note that, following Coq's code-documentation
 * conventions, we put square brackets around bits of code within comments,
 * and we use double-angle brackets to set off larger code excerpts.)
 * This list type is a lot like the syntax-tree types we saw in class;
 * the only new wrinkle is the polymorphic type parameter [A], which is
 * related to *generics* in OO languages.
 *
 * We can also define some useful operations on lists.
 * A basic one is length.
 * <<
    Fixpoint length {A} (xs : list A) : nat :=
      match xs with
        | nil => 0
        | cons _ xs' => 1 + length xs'
      end.
   >>
 * Note the use of the natural-number type [nat].
 * The curly braces in type argument [{A}] tell Coq to infer this type argument
 * when [length] is called, which by the way is the default behavior for all
 * type arguments in Haskell and OCaml.
 * Another function is concatenation of lists, defined using an infix operator
 * [::] for [cons].
 * <<
    Fixpoint app {A} (l : list A) (m : list A) : list A :=
      match l with
       | nil => m
       | a :: l1 => a :: app l1 m
      end.
   >>
 * Finally, we'll also work with list reversal, using [++] as an infix operator
 * for [app].
 * <<
    Fixpoint rev {A} (l : list A) : list A :=
      match l with
        | nil => nil
        | x :: l' => rev l' ++ (x :: nil)
      end.
   >>
 *)

(* Here's an example proof with lists, using a list shorthand notation. *)
Theorem an_important_theorem : length [1; 2; 3] = 3.
Proof.
  simplify.
  equality.
Qed.

(* OK, enough warmup.  Your job is to define a module implementing the following
 * signature.  We ask you to implement a file Pset0.v, such that it can
 * be checked against this signature by successfully processing a third
 * file with a command like so:
 * <<
    Require Pset0Sig Pset0.

    Module M : Pset0Sig.S := Pset0.
   >>
 * You'll need to build your module first.  Here's the UNIX-style approach
 * that we'll use for grading: Put this file Pset0Sig.v, your solution
 * Pset0.v, and an additional file Pset0Check.v in some directory.
 * The last file should include the two lines of code quoted above.
 * Then create a _CoqProject file in the same directory, containing:
 * <<
-R ../../frap Frap
Pset0Sig.v
Pset0.v
Pset0Check.v
   >>
 * Replace the `../../frap' with the path to the unpacked book source.
 * Then create a Makefile with this content:
 * <<
coq: Makefile.coq
	$(MAKE) -f Makefile.coq

Makefile.coq: Makefile _CoqProject
	coq_makefile -f _CoqProject -o Makefile.coq
   >>
 * If your Coq installation is set up properly, simply running `make' should
 * now be enough to build everything and check that it works.
 * Note also that you will need to run `make coq' in the directory of the book
 * library code, *before* starting to work on your solution, which needs
 * to import compiled library code from the book.
*)

(* Finally, here's the actual signature to implement. *)
Module Type S.
  Axiom another_important_theorem : length [1; 2; 3] = 1 + length [4; 5].

  Axiom length_concat : forall A (xs ys : list A), length (xs ++ ys) = length xs + length ys.
  (* Hint: want induction for this one! *)

  Axiom length_rev : forall A (xs : list A), length xs = length (rev xs).
  (* Hint: appeal to [length_concat] somewhere! *)
End S.

(* Example template for the Pset0.v file you will create:
 * <<
Require Import Frap.

Theorem another_important_theorem : length [1; 2; 3] = 1 + length [4; 5].
Proof.
  ...
Qed.

Theorem length_concat : forall A (xs ys : list A), length (xs ++ ys) = length xs + length ys.
Proof.
  ...
Qed.

Theorem length_rev : forall A (xs : list A), length xs = length (rev xs).
Proof.
  ...
Qed.
   >> *)


(** * Lists: Working with Structured Data *)

Require Export Induction.

Module NatList.

(* ###################################################### *)
(** * Pairs of Numbers *)

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

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

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

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

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p.  destruct p as [n m].  simpl.  reflexivity.  Qed.

(** **** Exercise: 1 star (snd_fst_is_swap) *)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p. destruct p as [n m]. simpl. reflexivity. Qed.

(** **** Exercise: 1 star, optional (fst_swap_is_snd) *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
intros p. destruct p as [n m]. simpl. reflexivity. Qed.

(** * Lists of Numbers *)

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

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

(** *** Repeat *)

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

(** *** Length *)

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

(** *** Append *)

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

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

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

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

(** **** Exercise: 2 stars (list_funs) *)
(** Complete the definitions of [nonzeros], [oddmembers] and
    [countoddmembers] below. Have a look at the tests to understand
    what these functions should do. *)

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

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

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

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

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

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

(** **** Exercise: 3 stars, advanced (alternate) *)
(** Complete the definition of [alternate], which "zips up" two lists
    into one, alternating between elements taken from the first list
    and elements from the second.  See the tests below for more
    specific examples.

    Note: one natural and elegant way of writing [alternate] will fail
    to satisfy Coq's requirement that all [Fixpoint] definitions be
    "obviously terminating."  If you find yourself in this rut, look
    for a slightly more verbose solution that considers elements of
    both lists at the same time.  (One possible solution requires
    defining a new kind of pairs, but this is not the only way.)  *)

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1 with
    | nil => l2
    | h :: s => match l2 with
                  | nil => l1
                  | x :: xs => h :: x :: alternate s xs
                end
  end.

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

(** ** Bags via Lists *)

Definition bag := natlist.

(** **** Exercise: 3 stars (bag_functions) *)
(** Complete the following definitions for the functions
    [count], [sum], [add], and [member] for bags. *)

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
    | nil => 0
    | x :: xs => match (beq_nat x v) with
                  | true  => S (count v xs)
                  | false => count v xs
                 end
  end.

(** All these proofs can be done just by [reflexivity]. *)

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

(** Multiset [sum] is similar to set [union]: [sum a b] contains
    all the elements of [a] and of [b].  (Mathematicians usually
    define [union] on multisets a little bit differently, which
    is why we don't use that name for this operation.)
    For [sum] we're giving you a header that does not give explicit
    names to the arguments.  Moreover, it uses the keyword
    [Definition] instead of [Fixpoint], so even if you had names for
    the arguments, you wouldn't be able to process them recursively.
    The point of stating the question this way is to encourage you to
    think about whether [sum] can be implemented in another way --
    perhaps by using functions that have already been defined.  *)

Definition sum : bag -> bag -> bag := app.
Example test_sum1:              count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag :=
  match s with
    | nil => [v]
    | x :: xs => v :: s
  end.

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

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

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

(** **** Exercise: 3 stars, optional (bag_more_functions) *)
(** Here are some more bag functions for you to practice with. *)

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
    | nil => nil
    | x :: xs => match beq_nat v x with
                   | true  => xs
                   | false => x :: remove_one v xs
                 end
end.

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

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
    | nil => nil
    | x :: xs => match beq_nat v x with
                   | true  => remove_all v xs
                   | false => x :: remove_all v xs
                 end
end.

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

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
    | nil => true
    | x :: xs => match member x s2 with
                   | true  => subset xs (remove_one x s2)
                   | false => false
                 end
  end.

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

(** **** Exercise: 3 stars (bag_theorem) *)
(** Write down an interesting theorem about bags involving the
    functions [count] and [add], and prove it.  Note that, since this
    problem is somewhat open-ended, it's possible that you may come up
    with a theorem which is true, but whose proof requires techniques
    you haven't learned yet.  Feel free to ask for help if you get
    stuck! *)
(* TODO *)
(* Fact a_great_theorem : forall a b : nat, forall s : bag, *)
(*   beq_nat a b = true -> count b (add a s) = 1 + count b s. *)
(* Proof. Abort. *)
(** [] *)

(** * Reasoning About Lists *)

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

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n l'".
    reflexivity.  Qed.

(** ** Micro-Sermon *)

(** ** Induction on Lists *)

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

(** *** Informal version *)

(** *** Another example *)

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

(** *** Reversing a list *)

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

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil    => nil
  | h :: t => snoc (rev t) h
  end.

(** *** Proofs about reverse *)

Theorem length_snoc : forall n : nat, forall l : natlist,
  length (snoc l n) = S (length l).
Proof.
  intros n l. induction l as [| n' l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons n' l'".
    simpl. rewrite -> IHl'. reflexivity.  Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> length_snoc.
    rewrite -> IHl'. reflexivity.  Qed.

(** ** List Exercises, Part 1 *)

(** **** Exercise: 3 stars (list_exercises) *)
(** More practice with lists. *)

Theorem app_nil_end : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l. induction l as [| x xs].
  Case "l = []". reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHxs. reflexivity. Qed.

Theorem rev_snoc : forall (v : nat) (l : natlist),
  rev (snoc l v) = v :: rev l.
Proof.
  intros v l. induction l as [| x xs].
  Case "l = []".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHxs. reflexivity. Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l as [| x xs].
  Case "l = []". reflexivity.
  Case "l = cons".
    simpl. rewrite -> rev_snoc. rewrite -> IHxs. reflexivity. Qed.

(* ref: https://github.com/etosch/software_foundations/blob/master/lesson3_Lists.v *)

(** There is a short solution to the next exercise.  If you find
    yourself getting tangled up, step back and try to look for a
    simpler way. *)

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  replace ((l1 ++ l2) ++ l3) with (l1 ++ l2 ++ l3).
  rewrite -> app_assoc.
  rewrite -> app_assoc. reflexivity.
  Case "replace".
    rewrite -> app_assoc. reflexivity. Qed.

Theorem snoc_append : forall (l : natlist) (n : nat),
  snoc l n = l ++ [n].
Proof.
  intros l n. induction l as [| x xs].
  Case "l = []".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> IHxs. reflexivity. Qed.

Theorem distr_rev : forall l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros l1 l2. induction l1 as [| x xs].
  Case "l1 = []".
    simpl. rewrite -> app_nil_end. reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> IHxs.
    rewrite -> snoc_append. rewrite -> snoc_append.
    rewrite -> app_assoc. reflexivity. Qed.

(** An exercise about your implementation of [nonzeros]: *)

Lemma nonzeros_nil : forall l : natlist,
  nonzeros [] = [].
Proof.
  reflexivity. Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2. induction l1 as [| x xs].
  Case "l1 = []".
    reflexivity.
  Case "l1 = cons".
    destruct x as [| x'].
    SCase "x = 0".
      simpl. rewrite -> IHxs. reflexivity.
    SCase "x > 0".
      simpl. rewrite -> IHxs. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars (beq_natlist) *)
(** Fill in the definition of [beq_natlist], which compares
    lists of numbers for equality.  Prove that [beq_natlist l l]
    yields [true] for every list [l]. *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1 with
    | nil => match l2 with
               | nil => true
               | _   => false
             end
    | h :: t => match l2 with
               | nil => false
               | h2 :: t2 => match beq_nat h h2 with
                               | false => false
                               | true  => beq_natlist t t2
                             end
                end
  end.

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

Lemma beq_n_n : forall n : nat,
  beq_nat n n = true.
Proof.
  intros. induction n as [| n'].
  Case "n = 0".
    reflexivity.
  Case "n > 0".
    simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem beq_natlist_refl : forall l : natlist,
  true = beq_natlist l l.
Proof.
  intro l. induction l as [| x xs].
  Case "l = []".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> beq_n_n.
    rewrite <- IHxs. reflexivity.
Qed.

(** ** List Exercises, Part 2 *)

(** **** Exercise: 2 stars (list_design) *)
(** Design exercise:
     - Write down a non-trivial theorem involving [cons]
       ([::]), [snoc], and [app] ([++]).
     - Prove it. *)

(* TODO *)
(** [] *)

(** **** Exercise: 3 stars, advanced (bag_proofs) *)
(** Here are a couple of little theorems to prove about your
    definitions about bags earlier in the file. *)

Theorem count_member_nonzero : forall (s : bag),
  ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  reflexivity.
Qed.

(** The following lemma about [ble_nat] might help you in the next proof. *)

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

Theorem remove_decreases_count: forall (s : bag),
  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s. induction s as [| h t].
  Case "s = []".
    reflexivity.
  Case "s = cons".
    destruct h as [| h']. simpl.
    SCase "h = 0".
      rewrite -> ble_n_Sn. reflexivity.
    SCase "h > 0".
    simpl. rewrite -> IHt. reflexivity.
Qed.

(** **** Exercise: 3 stars, optional (bag_count_sum) *)
(** Write down an interesting theorem about bags involving the
    functions [count] and [sum], and prove it.*)

(* TODO *)
(** [] *)

(** **** Exercise: 4 stars, advanced (rev_injective) *)
(** Prove that the [rev] function is injective, that is,

    forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.

There is a hard way and an easy way to solve this exercise.
*)

Theorem rev_injective: forall (l1 l2 : natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

(** * Options *)

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

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

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

(** **** Exercise: 2 stars (hd_opt) *)
(** Using the same idea, fix the [hd] function from earlier so we don't
   have to pass a default element for the [nil] case.  *)

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

Example test_hd_opt1 : hd_opt [] = None.
Proof. reflexivity. Qed.

Example test_hd_opt2 : hd_opt [1] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_opt3 : hd_opt [5;6] = Some 5.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, optional (option_elim_hd) *)
(** This exercise relates your new [hd_opt] to the old [hd]. *)

Theorem option_elim_hd : forall (l : natlist) (default : nat),
  hd default l = option_elim default (hd_opt l).
Proof.
  intros l d. destruct l as [| h t].
  reflexivity.
  reflexivity.
Qed.

(** * Dictionaries *)

Module Dictionary.

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

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

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

(** **** Exercise: 1 star (dictionary_invariant1) *)
(** Complete the following proof. *)

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

(** **** Exercise: 1 star (dictionary_invariant2) *)
(** Complete the following proof. *)

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

End Dictionary.

End NatList.


Require Import Arith.
Require Import Preorder.

Definition NatPreorder : Preorder nat := preorder
    le
    le_refl
    le_trans
    .


Set Implicit Arguments.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.

Section Defs.
  Variable A:Type.

  (** [MapsTo] is the last index of [x]. *)

  Inductive MapsTo (x:A) : nat -> list A -> Prop :=
  | maps_to_eq:
    forall l,
    MapsTo x (length l) (x::l)
  | maps_to_cons:
    forall l y n,
    x <> y ->
    MapsTo x n l ->
    MapsTo x n (y :: l).

  (** [IndexOf] assigns an element to an index with respect to a given list. *)

  Inductive IndexOf (x:A) : nat -> list A -> Prop :=
  | index_of_eq:
    forall l,
    IndexOf x (length l) (x :: l)
  | index_of_cons:
    forall y n l,
    IndexOf x n l ->
    IndexOf x n (y :: l).

  (** Checks if a number is an index of the given list,
      which is defined whenever there is an element [x] with an
      index of [n]. *)

  Inductive Index (n:nat) (l:list A) : Prop :=
  | index_def:
    forall x,
    IndexOf x n l ->
    Index n l.

  Lemma index_of_to_in:
    forall x n l,
    IndexOf x n l ->
    In x l.
  Proof.
    intros.
    induction l. {
      inversion H.
    }
    inversion H; subst.
    - auto using in_eq.
    - auto using in_cons.
  Qed.

  Lemma index_of_fun_1:
    forall l x n n',
    NoDup l ->
    IndexOf x n l ->
    IndexOf x n' l ->
    n' = n.
  Proof.
    intros.
    induction l. {
      inversion H0.
    }
    inversion H; subst; clear H.
    inversion H0; subst; clear H0.
    - inversion H1; subst; clear H1.
      + trivial.
      + contradiction H4; eauto using index_of_to_in.
    - inversion H1; subst; clear H1.
      + contradiction H4; eauto using index_of_to_in.
      + eauto.
  Qed.

  Lemma index_of_lt:
    forall x n l,
    IndexOf x n l ->
    n < length l.
  Proof.
    intros.
    induction l. {
      inversion H.
    }
    inversion H; subst.
    - auto.
    - simpl.
      assert (n < length l) by eauto.
      eauto.
  Qed.

  Lemma index_cons:
    forall n l x,
    Index n l ->
    Index n (x::l).
  Proof.
    intros.
    inversion H; subst; clear H.
    eauto using index_def, index_of_cons.
  Qed.

  Lemma lt_to_index:
    forall n l,
    n < length l ->
    Index n l.
  Proof.
    induction l; intros; simpl in *. {
      inversion H.
    }
    inversion H; subst; clear H.
    - eauto using index_def, index_of_eq.
    - auto using index_cons with *.
  Qed.

  Lemma index_lt:
    forall n l,
    Index n l ->
    n < length l.
  Proof.
    intros.
    inversion H.
    eauto using index_of_lt.
  Qed.

  Lemma index_iff_length:
    forall n l,
    Index n l <-> n < length l.
  Proof.
    split; auto using index_lt, lt_to_index.
  Qed.

  Lemma in_to_index_of:
    forall l x,
    In x l ->
    exists n, n < length l /\ IndexOf x n l.
  Proof.
    induction l; intros. {
      inversion H.
    }
    destruct H.
    - subst.
      exists (length l).
      simpl.
      eauto using index_of_eq.
    - apply IHl in H.
      destruct H as (n, (?,?)).
      exists n.
      simpl.
      eauto using index_of_cons.
  Qed.

  Lemma index_of_bij:
    forall l x x' n,
    NoDup l ->
    IndexOf x n l ->
    IndexOf x' n l ->
    x' = x.
  Proof.
    intros.
    induction l. {
      inversion H0.
    }
    inversion H; clear H; subst.
    inversion H0; subst; clear H0.
    - inversion H1; subst; clear H1.
      + trivial.
      + assert (length l < length l). {
          eauto using index_of_lt.
        }
        omega.
    - inversion H1; subst; clear H1.
      + assert (length l < length l). {
          eauto using index_of_lt.
        }
        omega.
      + eauto.
  Qed.

  Lemma index_of_neq:
    forall l x y n n',
    NoDup l ->
    IndexOf x n l ->
    IndexOf y n' l ->
    n <> n' ->
    x <> y.
  Proof.
    intros.
    induction l. {
      inversion H0.
    }
    inversion H; clear H; subst.
    inversion H0; subst; clear H0.
    - inversion H1; subst; clear H1.
      + omega.
      + unfold not; intros; subst.
        contradiction H5.
        eauto using index_of_to_in.
    - inversion H1; subst; clear H1.
      + unfold not; intros; subst.
        contradiction H5.
        eauto using index_of_to_in.
      + eauto.
  Qed.

  Inductive Lt (l:list A) (x:A) (y:A) : Prop :=
  | lt_def:
    forall xn yn,
    IndexOf x xn l ->
    IndexOf y yn l ->
    xn < yn ->
    Lt l x y.

  Definition Gt (l:list A) (x:A) (y:A) : Prop := Lt l y x.

  Lemma lt_trans (l:list A) (N:NoDup l):
    forall x y z,
    Lt l x y ->
    Lt l y z ->
    Lt l x z.
  Proof.
    intros.
    inversion H; clear H.
    inversion H0; clear H0.
    rename yn0 into zn.
    assert (xn0 = yn) by
    eauto using index_of_fun_1; subst.
    apply lt_def with (xn:=xn) (yn:=zn); auto.
    omega.
  Qed.

  Lemma gt_trans (l:list A) (N:NoDup l):
    forall x y z,
    Gt l x y ->
    Gt l y z ->
    Gt l x z.
  Proof.
    unfold Gt; intros.
    eauto using lt_trans.
  Qed.

  Lemma lt_irrefl (l:list A) (N:NoDup l):
    forall x,
    ~ Lt l x x.
  Proof.
    intros.
    intuition.
    inversion H.
    assert (xn=yn) by eauto using index_of_fun_1.
    intuition.
  Qed.

  Lemma gt_irrefl (l:list A) (N:NoDup l):
    forall x,
    ~ Gt l x x.
  Proof.
    unfold Gt; intros.
    eauto using lt_irrefl.
  Qed.

  Lemma lt_neq (l:list A) (N:NoDup l):
    forall x y,
    Lt l x y ->
    x <> y.
  Proof.
    intros.
    inversion H; clear H.
    assert (xn <> yn) by omega.
    eauto using index_of_neq.
  Qed.

  Lemma gt_neq (l:list A) (N:NoDup l):
    forall x y,
    Gt l x y ->
    x <> y.
  Proof.
    unfold Gt; intros.
    apply lt_neq in H; auto.
  Qed.

  Lemma lt_absurd_nil:
    forall x y,
    ~ Lt nil x y.
  Proof.
    intuition.
    destruct H.
    inversion H.
  Qed.

  Lemma lt_cons:
    forall z l x y,
    Lt l x y ->
    Lt (z :: l) x y.
  Proof.
    intros.
    inversion H.
    eauto using lt_def, index_of_cons.
  Qed.

End Defs.

Section MapsTo.
  Variable A:Type.

  Lemma maps_to_inv_eq:
    forall (x:A) n vs,
    MapsTo x n (x :: vs) ->
    n = length vs.
  Proof.
    intros.
    inversion H; subst; auto.
    contradiction H3; trivial.
  Qed.

  Lemma maps_to_neq:
    forall (x:A) y vs n,
    x <> y ->
    MapsTo y n (x :: vs) ->
    MapsTo y n vs.
  Proof.
    intros.
    inversion H0.
    - subst; contradiction H; trivial.
    - assumption.
  Qed.

  Lemma maps_to_fun_2:
    forall vs (x:A) n n',
    MapsTo x n vs ->
    MapsTo x n' vs ->
    n' = n.
  Proof.
    induction vs; intros. {
      inversion H.
    }
    inversion H; subst; clear H;
    inversion H0; subst; clear H0; auto.
    - contradiction H3; trivial.
    - contradiction H4; trivial.
    - eauto.
  Qed.

  Lemma maps_to_to_index_of:
    forall (x:A) nx vs,
    MapsTo x nx vs ->
    IndexOf x nx vs.
  Proof.
    intros.
    induction H. {
      auto using index_of_eq.
    }
    auto using index_of_cons.
  Qed.

  Lemma maps_to_lt:
    forall (x:A) n vs,
    MapsTo x n vs ->
    n < length vs.
  Proof.
    induction vs; intros. {
      inversion H.
    }
    inversion H; subst. {
      auto.
    }
    apply IHvs in H4.
    simpl.
    auto.
  Qed.

  Lemma maps_to_absurd_length:
    forall (x:A) vs,
    ~ MapsTo x (length vs) vs.
  Proof.
    intros.
    unfold not; intros.
    apply maps_to_lt in H.
    apply Lt.lt_irrefl in H.
    assumption.
  Qed.

  Lemma index_of_absurd_length:
    forall (x:A) vs,
    ~ IndexOf x (length vs) vs.
  Proof.
    intuition.
    apply index_of_lt in H.
    omega.
  Qed.

  Lemma index_absurd_length:
    forall (vs:list A),
    ~ Index (length vs) vs.
  Proof.
    intuition.
    inversion H.
    apply index_of_absurd_length in H0.
    contradiction.
  Qed.

  Lemma maps_to_absurd_cons:
    forall (x:A) y n vs,
    MapsTo x n vs ->
    ~ (MapsTo y n (y :: vs)).
  Proof.
    intros.
    unfold not; intros.
    assert (n = length vs) by eauto using maps_to_inv_eq; subst.
    apply maps_to_absurd_length in H.
    contradiction.
  Qed.

  Lemma maps_to_inv_key:
    forall (x:A) y l,
    MapsTo y (length l) (x :: l) ->
    y = x.
  Proof.
    intros.
    inversion H; subst. {
      trivial.
    }
    apply maps_to_absurd_length in H4; contradiction.
  Qed.

  Lemma index_of_inv_key:
    forall (x:A) y l,
    IndexOf y (length l) (x :: l) ->
    y = x.
  Proof.
    intros.
    inversion H; subst. {
      trivial.
    }
    apply index_of_absurd_length in H2; contradiction.
  Qed.

  Lemma index_of_fun_2:
    forall l (x:A) y n,
    IndexOf x n l ->
    IndexOf y n l ->
    y = x.
  Proof.
    induction l; intros. {
      inversion H.
    }
    inversion H; subst; clear H. {
      inversion H0; subst; clear H0. {
        trivial.
      }
      apply index_of_absurd_length in H2; contradiction.
    }
    inversion H0; subst; clear H0. {
      apply index_of_absurd_length in H3; contradiction.
    }
    eauto.
  Qed.

  Lemma maps_to_fun_1:
    forall (x:A) y n vs,
    MapsTo x n vs ->
    MapsTo y n vs ->
    y = x.
  Proof.
    intros.
    induction H. {
      eauto using maps_to_inv_key.
    }
    inversion H0; subst. {
      apply maps_to_absurd_length in H1.
      contradiction.
    }
    auto.
  Qed.

  Lemma maps_to_to_in:
    forall (x:A) n vs,
    MapsTo x n vs ->
    List.In x vs.
  Proof.
    intros.
    induction H. {
      auto using List.in_eq.
    }
    auto using List.in_cons.
  Qed.

  Lemma index_eq:
    forall (x:A) vs,
    Index (length vs) (x::vs).
  Proof.
    intros.
    eauto using index_def, index_of_eq.
  Qed.

  Lemma maps_to_to_index:
    forall (x:A) n vs,
    MapsTo x n vs ->
    Index n vs.
  Proof.
    intros.
    eauto using index_def, maps_to_to_index_of.
  Qed.

  Section MapsToDec.
    Variable eq_dec: forall (x y:A), { x = y } + { x <> y }.

    Lemma in_to_maps_to:
      forall (x:A) vs,
      List.In x vs ->
      exists n, MapsTo x n vs.
    Proof.
      induction vs; intros. {
        inversion H.
      }
      destruct H. {
        subst.
        eauto using maps_to_eq.
      }
      destruct (eq_dec x a). {
        subst.
        eauto using maps_to_eq.
      }
      apply IHvs in H.
      destruct H.
      eauto using maps_to_cons.
    Qed.

    Fixpoint lookup x l :=
    match l with
    | nil => None
    | y :: l => if eq_dec x y then Some (length l) else lookup x l
    end.

    Lemma lookup_some:
      forall xs x n,
      lookup x xs = Some n ->
      MapsTo x n xs.
    Proof.
      induction xs; intros. {
        inversion H.
      }
      simpl in *.
      destruct (eq_dec x a). {
        inversion H; subst.
        auto using maps_to_eq.
      }
      auto using maps_to_cons.
    Qed.

    Lemma lookup_none:
      forall xs x,
      lookup x xs = None ->
      ~ List.In x xs.
    Proof.
      induction xs; intros; simpl in *; auto.
      destruct (eq_dec x a).
      - inversion H.
      - unfold not; intros.
        apply IHxs in H.
        destruct H0.
        * contradiction n; auto.
        * contradiction.
    Qed.

    Lemma maps_to_to_lookup:
      forall x n xs,
      MapsTo x n xs ->
      lookup x xs = Some n.
    Proof.
      induction xs; intros. {
        inversion H.
      }
      simpl.
      destruct (eq_dec x a). {
        subst.
        apply maps_to_inv_eq in H; subst.
        trivial.
      }
      apply maps_to_neq in H; auto.
    Qed.

    Lemma not_in_lookup_none:
      forall xs x,
      ~ List.In x xs ->
      lookup x xs = None.
    Proof.
      induction xs; intros. {
        auto.
      }
      simpl.
      destruct (eq_dec x a). {
        subst.
        contradiction H; auto using in_eq.
      }
      apply IHxs.
      unfold not; intros N.
      contradiction H; auto using in_cons.
    Qed.

    Fixpoint index_of n (l:list A) : option A :=
    match l with
    | nil => None
    | x :: l => if eq_nat_dec n (length l) then Some x else index_of n l
    end.

    Lemma index_of_some:
      forall n l x,
      index_of n l = Some x ->
      IndexOf (A:=A) x n l.
    Proof.
      induction l; intros. {
        simpl in *.
        inversion H.
      }
      simpl in *.
      destruct (eq_nat_dec n (length l)). {
        inversion H; subst.
        auto using index_of_eq.
      }
      auto using index_of_cons.
    Qed.

    Lemma index_of_prop:
      forall l n x,
      IndexOf (A:=A) x n l ->
      index_of n l = Some x.
    Proof.
      induction l; intros. {
        inversion H.
      }
      inversion H; subst; clear H. {
        simpl.
        destruct (eq_nat_dec (length l) (length l)). {
          trivial.
        }
        intuition.
      }
      simpl.
      destruct (eq_nat_dec n (length l)). {
        subst.
        apply index_of_absurd_length in H2.
        contradiction.
      }
      auto.
    Qed.

  End MapsToDec.
End MapsTo.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
   - rewrite plus_zero. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : natural), eq (plus (mult x y) z) (qmult x y z).
Proof.
   induction x.

   - intros. simpl. rewrite <- IHx. rewrite plus_assoc. rewrite (plus_commut y z). reflexivity.
   - reflexivity.
Qed.