(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.

Import Znumtheory.

(* Why3 goal *)
Notation gcd := Zgcd (only parsing).

(* Why3 goal *)
Lemma gcd_nonneg : forall (a:Z) (b:Z), (0%Z <= (gcd a b))%Z.
Proof.
exact Zgcd_is_pos.
Qed.

(* Why3 goal *)
Lemma gcd_def1 : forall (a:Z) (b:Z), (number.Divisibility.divides (gcd a b)
  a).
Proof.
intros a b.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_def2 : forall (a:Z) (b:Z), (number.Divisibility.divides (gcd a b)
  b).
Proof.
intros a b.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_def3 : forall (a:Z) (b:Z) (x:Z), (number.Divisibility.divides x
  a) -> ((number.Divisibility.divides x b) -> (number.Divisibility.divides x
  (gcd a b))).
Proof.
intros a b x.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_unique : forall (a:Z) (b:Z) (d:Z), (0%Z <= d)%Z ->
  ((number.Divisibility.divides d a) -> ((number.Divisibility.divides d b) ->
  ((forall (x:Z), (number.Divisibility.divides x a) ->
  ((number.Divisibility.divides x b) -> (number.Divisibility.divides x
  d))) -> (d = (gcd a b))))).
Proof.
intros.
apply sym_eq.
apply Zis_gcd_gcd.
exact H.
now constructor.
Qed.

(* Why3 goal *)
Lemma Assoc : forall (x:Z) (y:Z) (z:Z), ((gcd (gcd x y) z) = (gcd x (gcd y
  z))).
Proof.
exact Zgcd_ass.
Qed.

(* Why3 goal *)
Lemma Comm : forall (x:Z) (y:Z), ((gcd x y) = (gcd y x)).
Proof.
exact Zgcd_comm.
Qed.

(* Why3 goal *)
Lemma gcd_0_pos : forall (a:Z), (0%Z <= a)%Z -> ((gcd a 0%Z) = a).
Proof.
intros a H.
rewrite <- (Zabs_eq a H) at 2.
apply Zgcd_0.
Qed.

(* Why3 goal *)
Lemma gcd_0_neg : forall (a:Z), (a < 0%Z)%Z -> ((gcd a 0%Z) = (-a)%Z).
Proof.
intros a H.
rewrite <- Zabs_non_eq.
apply Zgcd_0.
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma gcd_opp : forall (a:Z) (b:Z), ((gcd a b) = (gcd (-a)%Z b)).
Proof.
intros a b.
apply Zis_gcd_gcd.
apply Zgcd_is_pos.
apply Zis_gcd_minus.
apply Zis_gcd_sym.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_euclid : forall (a:Z) (b:Z) (q:Z), ((gcd a b) = (gcd a
  (b - (q * a)%Z)%Z)).
Proof.
intros a b c.
apply Zis_gcd_gcd.
apply Zgcd_is_pos.
apply Zis_gcd_sym.
apply Zis_gcd_for_euclid with c.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma Gcd_computer_mod : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((gcd b
  (ZArith.BinInt.Z.rem a b)) = (gcd a b)).
Proof.
intros a b _.
rewrite (Zgcd_comm a b).
rewrite (gcd_euclid b a (Z.quot a b)).
apply f_equal.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.

(* Why3 goal *)
Lemma Gcd_euclidean_mod : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((gcd b
  (int.EuclideanDivision.mod1 a b)) = (gcd a b)).
Proof.
intros a b Zb.
rewrite (Zgcd_comm a b).
rewrite (gcd_euclid b a (EuclideanDivision.div a b)).
apply f_equal.
rewrite (EuclideanDivision.Div_mod a b Zb) at 2.
ring.
Qed.

(* Why3 goal *)
Lemma gcd_mult : forall (a:Z) (b:Z) (c:Z), (0%Z <= c)%Z -> ((gcd (c * a)%Z
  (c * b)%Z) = (c * (gcd a b))%Z).
Proof.
intros a b c H.
apply Zis_gcd_gcd.
apply Zmult_le_0_compat with (1 := H).
apply Zgcd_is_pos.
apply Zis_gcd_mult.
apply Zgcd_is_gcd.
Qed.


Set Warnings "-notation-overridden".
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Arith Euclid Ring Omega.

Check modulo.
Compute modulo 5.

Locate "%|".
Locate dvdn.
Print dvdn.
Locate "%%".
Compute 100 %% 37.
Print modn.
Print modn_rec.

Definition mod' n m := modulo (S m) (lt_O_Sn m) n.

Compute proj1_sig (mod' 5 3).
Check proj1_sig.

Require Import Recdef.
Function gcd (m n : nat) {wf lt m} : nat :=
  match m with
  | 0    => n
  | S m' => gcd (proj1_sig (mod' n m')) m
  end.
  (*減少の証明*)
  intros. destruct (mod' n m'). simpl.
  destruct e as [q [Hn Hm]].
  apply Hm.
  (*清楚性の証明*)
  exact lt_wf.
Defined.

Compute gcd 18 24.

Inductive divides (m:nat) : nat -> Prop :=
  divi : forall a, divides m (a * m).

Lemma divide : forall a m n, n = a * m -> divides m n.
Proof.
  intros. rewrite H. constructor.
Qed.

Lemma divides_mult : forall m q n, divides m n -> divides m (q * n).
Proof.
  induction 1.
  replace (q*(a*m)) with (q*a*m).
  by apply divide with (a:=q*a).
  by rewrite mulnA.
Qed.

Theorem divides_plus : forall m n p, divides m n ->
  divides m p -> divides m (n + p).
Proof.
  intros. destruct H. destruct H0.
  replace (a*m+a0*m) with ((a+a0)*m).
  apply divi.
  by rewrite mulnDl.
Qed.

Theorem divides_1 : forall n, divides 1 n.
Proof.
  intros.
  replace n with (n*1).
  apply divi.
  apply muln1.
Qed.

Theorem divides_0 : forall n, divides n 0.
Proof.
  intros.
  replace 0 with (0*n).
  apply divi.
  apply mul0n.
Qed.

Theorem divides_n : forall n, divides n n.
Proof.
  intros.
  rewrite {2}(_ : n = 1 * n).
  apply divi.
  by rewrite mul1n.
Qed.

Hint Resolve divides_plus divides_mult divides_1 divides_0 divides_n.

Theorem gcd_divides : forall m n,
  divides (gcd m n) m /\ divides (gcd m n) n.
Proof.
  intros.
  functional induction (gcd m n).
  auto.
  destruct (mod' n m').
  simpl in *.
  destruct e as [q [Hn Hm]].
  destruct IHn0.
  split; auto.
  rewrite Hn.
  auto.
Qed.

Theorem plus_inj : forall m n p,
  m + n = m + p -> n = p.
Proof.
  intros.
  induction m.
  by rewrite 2!add0n in H.
  apply IHm.
  assert(H2:S(m+n)=S(m+p)).
  rewrite -add1n. rewrite (_ : (m+p).+1=(1+(m+p))).
  by rewrite addnA. apply add1n.
  by inversion H2.
Qed.

Require Import Omega.

Lemma divides_plus' : forall m n p,
  divides m n -> divides m (n+p) -> divides m p.
Proof.
  induction 1.
  intro.
  induction a. assumption.
  inversion H.
  destruct a0.
  destruct p.
  auto.
  elimtype False.
  destruct m. destruct a. try discriminate.
  rewrite 2!muln0 in H1.
  inversion H1.
  rewrite mul0n in H1.
  inversion H1.
  apply IHa.
  rewrite -add1n in H1. rewrite (_:a.+1=(1+a)) in H1.
  rewrite 2!mulnDl in H1. rewrite (_:(1*m+a*m+p)=(1*m)+(a*m+p)) in H1.
  apply plus_inj in H1. rewrite -H1. constructor.
  by rewrite addnA. apply add1n.
Qed.

Theorem add_compat : forall m n, addn m n = Init.Nat.add m n.
Proof.
  intros. induction m.
  by [].
  by [].
Qed.

Theorem mul_compat : forall m n, muln m n = Init.Nat.mul m n.
Proof.
  by [].
Qed.

Theorem gcd_max : forall g m n,
  divides g m -> divides g n -> divides g (gcd m n).
Proof.
  intros.
  functional induction (gcd m n).
  assumption.
  destruct (mod' n m'). simpl in *.
  destruct e as [q [Hn Hm']].
  apply IHn0.
  apply divides_plus' with (n:=q*S m').
  induction H. rewrite (_ : (q*(a*g))=((q*a)*g)).
  apply divi. by rewrite mulnA.
  rewrite (_ : (q * m'.+1 + x)=(((q * m'.+1)%coq_nat+x)%coq_nat)).
  by rewrite -Hn. Locate addn.
  apply add_compat.
  apply H.
Qed.


Require Export TopologicalSpaces.
Require Export DirectedSets.
Require Export InteriorsClosures.
Require Export Continuity.

Set Asymmetric Patterns.

Section Net.

Variable I:DirectedSet.
Variable X:TopologicalSpace.

Definition Net := DS_set I -> point_set X.

Definition net_limit (x:Net) (x0:point_set X) : Prop :=
  forall U:Ensemble (point_set X), open U -> In U x0 ->
  for large i:DS_set I, In U (x i).

Definition net_cluster_point (x:Net) (x0:point_set X) : Prop :=
  forall U:Ensemble (point_set X), open U -> In U x0 ->
  exists arbitrarily large i:DS_set I, In U (x i).

Lemma net_limit_is_cluster_point: forall (x:Net) (x0:point_set X),
  net_limit x x0 -> net_cluster_point x x0.
Proof.
intros.
red; intros.
red; intros.
pose proof (H U H0 H1).
destruct H2.
destruct (DS_join_cond i x1).
destruct H3.
exists x2; split; trivial.
apply H2; trivial.
Qed.

Lemma net_limit_in_closure: forall (S:Ensemble (point_set X))
  (x:Net) (x0:point_set X),
  (exists arbitrarily large i:DS_set I, In S (x i)) ->
  net_limit x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
red; intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
apply H2.
apply closure_closed.
assumption.
destruct H3.
pose proof (H x1).
destruct H4.
contradiction (H3 x2).
tauto.
apply closure_inflationary; tauto.
Qed.

Lemma net_cluster_point_in_closure: forall (S:Ensemble (point_set X))
  (x:Net) (x0:point_set X),
  (for large i:DS_set I, In S (x i)) ->
  net_cluster_point x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
red; intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
apply H2.
apply closure_closed.
assumption.
destruct H.
destruct (H3 x1).
destruct H4.
contradiction H5.
apply closure_inflationary.
apply H; trivial.
Qed.

End Net.

Arguments net_limit {I} {X}.
Arguments net_cluster_point {I} {X}.
Arguments net_limit_is_cluster_point {I} {X}.
Arguments net_limit_in_closure {I} {X}.
Arguments net_cluster_point_in_closure {I} {X}.

Section neighborhood_net.

Variable X:TopologicalSpace.
Variable x:point_set X.

Inductive neighborhood_net_DS_set : Type :=
  | intro_neighborhood_net_DS :
    forall (U:Ensemble (point_set X)) (y:point_set X),
    open U -> In U x -> In U y -> neighborhood_net_DS_set.

Definition neighborhood_net_DS_ord
  (Uy Vz:neighborhood_net_DS_set) : Prop :=
  match Uy, Vz with
  | intro_neighborhood_net_DS U _ _ _ _,
    intro_neighborhood_net_DS V _ _ _ _ =>
    Included V U
  end.

Definition neighborhood_net_DS : DirectedSet.
refine (Build_DirectedSet neighborhood_net_DS_set
  neighborhood_net_DS_ord _ _).
constructor.
red; intros.
destruct x0.
simpl; auto with sets.
red; intros.
destruct x0; destruct y; destruct z.
simpl in H; simpl in H0; simpl.
auto with sets.

intros.
destruct i; destruct j.
assert (open (Intersection U U0)).
apply open_intersection2; trivial.
assert (In (Intersection U U0) x); auto with sets.

exists (intro_neighborhood_net_DS (Intersection U U0) x
  H H0 H0).
simpl; auto with sets.
Defined.

Definition neighborhood_net : Net neighborhood_net_DS X :=
  fun (x:neighborhood_net_DS_set) => match x with
  | intro_neighborhood_net_DS _ y _ _ _ => y
  end.

Lemma neighborhood_net_limit: net_limit neighborhood_net x.
Proof.
red; intros.
exists (intro_neighborhood_net_DS U x H H0 H0).
intros.
destruct j.
simpl in H1.
simpl.
auto with sets.
Qed.

End neighborhood_net.

Lemma net_limits_determine_topology:
  forall {X:TopologicalSpace} (S:Ensemble (point_set X))
  (x0:point_set X), In (closure S) x0 ->
  exists I:DirectedSet, exists x:Net I X,
  (forall i:DS_set I, In S (x i)) /\ net_limit x x0.
Proof.
intros.
assert (forall U:Ensemble (point_set X), open U -> In U x0 ->
  Inhabited (Intersection S U)).
intros.
apply NNPP; red; intro.
assert (Included (closure S) (Complement U)).
apply closure_minimal.
red; rewrite Complement_Complement; assumption.
red; intros.
red; red; red; intros.
contradiction H2.
exists x; auto with sets.
contradict H1.
apply H3.
assumption.
pose (Ssel := fun n:neighborhood_net_DS_set X x0 =>
  match n with
  | intro_neighborhood_net_DS V y _ _ _ => (In S y)
  end).
pose (our_DS_set := {n:neighborhood_net_DS_set X x0 | Ssel n}).
pose (our_DS_ord := fun (n1 n2:our_DS_set) =>
  neighborhood_net_DS_ord X x0 (proj1_sig n1) (proj1_sig n2)).
assert (preorder our_DS_ord).
constructor; red.
intros; red.
apply preord_refl.
apply (@DS_ord_cond (neighborhood_net_DS X x0)).
intros x y z.
unfold our_DS_ord; apply preord_trans.
apply (@DS_ord_cond (neighborhood_net_DS X x0)).
assert (forall i j:our_DS_set, exists k:our_DS_set,
  our_DS_ord i k /\ our_DS_ord j k).
destruct i.
destruct x.
destruct j.
destruct x.
assert (open (Intersection U U0)).
apply open_intersection2; trivial.
assert (In (Intersection U U0) x0).
auto with sets.
assert (Inhabited (Intersection S (Intersection U U0))).
apply H0; trivial.
destruct H4.
destruct H4.
pose (k0 := intro_neighborhood_net_DS X x0
  (Intersection U U0) x H2 H3 H5).
assert (Ssel k0).
red; unfold k0; simpl.
assumption.
exists (exist _ k0 H6).
split; red; simpl; auto with sets.

pose (our_DS := Build_DirectedSet our_DS_set our_DS_ord H1 H2).
exists our_DS.
exists (fun i:our_DS_set => neighborhood_net X x0 (proj1_sig i)).
split.
intros.
destruct i.
destruct x.
simpl.
simpl in s.
assumption.

red; intros.
assert (Inhabited (Intersection S U)).
apply H0; trivial.
destruct H5.
destruct H5.
pose (i0 := intro_neighborhood_net_DS X x0
  U x H3 H4 H6).
assert (Ssel i0).
simpl; assumption.
exists (exist _ i0 H7).
intros.
destruct j.
destruct x1.
simpl in H8.
red in H8; simpl in H8.
simpl.
auto with sets.
Qed.

Section Nets_and_continuity.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.

Lemma continuous_func_preserves_net_limits:
  forall {I:DirectedSet} (x:Net I X) (x0:point_set X),
    net_limit x x0 -> continuous_at f x0 ->
    net_limit (fun i:DS_set I => f (x i)) (f x0).
Proof.
intros.
red; intros V ? ?.
assert (neighborhood V (f x0)).
apply open_neighborhood_is_neighborhood; split; trivial.
pose proof (H0 V H3).
destruct H4 as [U [? ?]].
destruct H4.
pose proof (H U H4 H6).
apply eventually_impl_base with (fun i:DS_set I => In U (x i));
  trivial.
intros.
assert (In (inverse_image f V) (x i)); auto with sets.
destruct H9; trivial.
Qed.

Lemma func_preserving_net_limits_is_continuous:
  forall x0:point_set X,
  (forall (I:DirectedSet) (x:Net I X),
    net_limit x x0 -> net_limit (fun i:DS_set I => f (x i)) (f x0))
  -> continuous_at f x0.
Proof.
intros.
pose proof (H (neighborhood_net_DS X x0)
  (neighborhood_net X x0)
  (neighborhood_net_limit X x0)).
apply continuous_at_open_neighborhoods; intros.
destruct H1.
pose proof (H0 V H1 H2).
destruct H3.
destruct x as [U].
exists U; repeat split; trivial.
pose proof (H3 (intro_neighborhood_net_DS X x0 U x o i H4)).
apply H5.
simpl; auto with sets.
Qed.

End Nets_and_continuity.

Section Subnet.

Variable X:TopologicalSpace.
Variable I:DirectedSet.
Variable x:Net I X.

Inductive Subnet {J:DirectedSet} : Net J X -> Prop :=
  | intro_subnet: forall h:DS_set J -> DS_set I,
    (forall j1 j2:DS_set J, DS_ord j1 j2 ->
       DS_ord (h j1) (h j2)) ->
    (exists arbitrarily large i:DS_set I,
       exists j:DS_set J, h j = i) ->
    Subnet (fun j:DS_set J => x (h j)).

Lemma subnet_limit: forall (x0:point_set X) {J:DirectedSet}
  (y:Net J X), net_limit x x0 -> Subnet y ->
  net_limit y x0.
Proof.
intros.
destruct H0.
red; intros.
pose proof (H U H2 H3).
destruct H4.
destruct (H1 x1).
destruct H5.
destruct H6.
exists x3.
intros.
apply H4.
apply preord_trans with x2.
apply DS_ord_cond.
assumption.
rewrite <- H6.
apply H0.
assumption.
Qed.

Lemma subnet_cluster_point: forall (x0:point_set X) {J:DirectedSet}
  (y:Net J X), net_cluster_point y x0 ->
  Subnet y -> net_cluster_point x x0.
Proof.
intros.
destruct H0 as [h h_increasing h_dominant].
red; intros.
red; intros.
pose proof (h_dominant i).
destruct H2.
destruct H2.
destruct H3.
pose proof (H U H0 H1 x2).
destruct H4.
destruct H4.
exists (h x3).
split; trivial.
apply preord_trans with x1.
apply DS_ord_cond.
assumption.
rewrite <- H3.
apply h_increasing; assumption.
Qed.

Section cluster_point_subnet.

Variable x0:point_set X.
Hypothesis x0_cluster_point: net_cluster_point x x0.
Hypothesis I_nonempty: inhabited (DS_set I).

Record cluster_point_subnet_DS_set : Type := {
  cps_i:DS_set I;
  cps_U:Ensemble (point_set X);
  cps_U_open_neigh: open_neighborhood cps_U x0;
  cps_xi_in_U: In cps_U (x cps_i)
}.

Definition cluster_point_subnet_DS_ord
  (iU1 iU2 : cluster_point_subnet_DS_set) : Prop :=
  DS_ord (cps_i iU1) (cps_i iU2) /\
  Included (cps_U iU2) (cps_U iU1).

Definition cluster_point_subnet_DS : DirectedSet.
refine (Build_DirectedSet
  cluster_point_subnet_DS_set
  cluster_point_subnet_DS_ord
  _ _).
constructor.
red; intros; split; auto with sets.
apply preord_refl.
apply DS_ord_cond.
red; intros.
destruct H; destruct H0.
red; split; auto with sets.
apply preord_trans with (cps_i y); trivial.
apply DS_ord_cond.

intros.
destruct i as [i0 U0 ? ?]; destruct j as [i1 U1 ? ?].
destruct (DS_join_cond i0 i1).
destruct H.
pose proof (x0_cluster_point
  (Intersection U0 U1)).
match type of H1 with | _ -> _ -> ?C =>
  assert C end.
apply H1.
apply open_intersection2;
  (apply cps_U_open_neigh0 ||
   apply cps_U_open_neigh1).
constructor;
  (apply cps_U_open_neigh0 ||
   apply cps_U_open_neigh1).
destruct (H2 x1).
destruct H3.
pose (ki := x2).
pose (kU := Intersection U0 U1).
assert (open_neighborhood kU x0).
split.
apply open_intersection2.
apply cps_U_open_neigh0.
apply cps_U_open_neigh1.
constructor; (apply cps_U_open_neigh0 ||
              apply cps_U_open_neigh1).
assert (In kU (x ki)).
exact H4.

exists (Build_cluster_point_subnet_DS_set
  ki kU H5 H6).
split; red; simpl; split.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
red; intros.
destruct H7; trivial.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
red; intros.
destruct H7; trivial.
Defined.

Definition cluster_point_subnet : Net
  cluster_point_subnet_DS X :=
  fun (iU:DS_set cluster_point_subnet_DS) =>
  x (cps_i iU).

Lemma cluster_point_subnet_is_subnet:
  Subnet cluster_point_subnet.
Proof.
constructor.
intros.
destruct j1; destruct j2.
simpl in H; simpl.
red in H; tauto.

red; intros.
exists i; split.
apply preord_refl; apply DS_ord_cond.
assert (open_neighborhood Full_set x0).
split.
apply open_full.
constructor.
assert (In Full_set (x i)).
constructor.
exists (Build_cluster_point_subnet_DS_set
  i Full_set H H0).
trivial.
Qed.

Lemma cluster_point_subnet_converges:
  net_limit cluster_point_subnet x0.
Proof.
red; intros.
destruct I_nonempty as [i0].
destruct (x0_cluster_point U H H0 i0).
destruct H1.
assert (open_neighborhood U x0).
split; trivial.
exists (Build_cluster_point_subnet_DS_set
  x1 U H3 H2).
intros.
destruct j.
red in H4; simpl in H4.
red in H4; simpl in H4.
unfold cluster_point_subnet; simpl.
destruct H4; auto with sets.
Qed.

Lemma net_cluster_point_impl_subnet_converges:
  exists J:DirectedSet, exists y:Net J X,
  Subnet y /\ net_limit y x0.
Proof.
exists cluster_point_subnet_DS.
exists cluster_point_subnet.
split.
exact cluster_point_subnet_is_subnet.
exact cluster_point_subnet_converges.
Qed.

End cluster_point_subnet.

End Subnet.


(** * Correctness of Binary Search Trees (BSTs) *)

(* This week we'll continue proving the correctness of a binary search tree implementation.
 * BSTs are a famous data structure for finite sets, allowing fast (log-time)
 * lookup, insertion, and deletion of items. (We omit the rebalancing heuristics
 * needed to achieve worst-case log-time operations, but you will prove the
 * correctness of rotation operations these heuristics use to modify the tree.)
 * In this problem set, we show that insertion and deletion functions are
 * correctly defined by relating them to operations on functional sets. *)

(* As usual, a set of spoiler-containing hints to help you along when you
 * get stuck with certain pset questions has been provided at the bottom of
 * the signature file! *)

Require Import Frap Datatypes Pset4Sig.
Require Import Compare_dec.

(* We will study binary trees of natural numbers only for convenience.
   Almost everything here would also work with an arbitrary type
   [t], but with [nat] you can use [linear_arithmetic] to prove
   goals about ordering of multiple elements (e.g., transitivity). *)
Local Notation t := nat.

Module Impl.
  (* Trees are an inductive structure, where [Leaf] doesn't have any items,
   * whereas [Node] has an item and two subtrees. Note that a [tree] can
   * contain nodes in arbitrary order, so not all [tree]s are valid binary
   * search trees. *)

  (* (* Imported from Sig file: *)
  Inductive tree :=
  | Leaf (* an empty tree *)
  | Node (d : t) (l r : tree).
  *)
  (* Then a singleton is just a node without subtrees. *)
  Definition Singleton (v: t) := Node v Leaf Leaf.

  (* [bst] relates a well-formed binary search tree to the set of elements it
     contains. Note that invalid trees with misordered elements are not valid
     representations of any set. All operations on a binary tree are specified
     in terms of how they affect the set that the tree represents. That
     set is encoded as function that takes a [t] and returns the proposition "[t]
     is in this set". *)
  Fixpoint bst (tr : tree) (s : t -> Prop) :=
    match tr with
    | Leaf => forall x, not (s x) (* s is empty set *)
    | Node d l r =>
        s d /\
        bst l (fun x => s x /\ x < d) /\
        bst r (fun x => s x /\ d < x)
    end.

  (* [member] computes whether [a] is in [tr], but to do so it *relies* on the
     [bst] property -- if [tr] is not a valid binary search tree, [member]
     will (and should, for performance) give arbitrarily incorrect answers. *)
  Fixpoint member (a: t) (tr: tree) : bool :=
    match tr with
    | Leaf => false
    | Node v lt rt =>
      match compare a v with
      | Lt => member a lt
      | Eq => true
      | Gt => member a rt
      end
    end.

  (* Here is a typical insertion routine for BSTs.
   * From a given value, we recursively compare the value with items in
   * the tree from the root, until we find a leaf whose place the new value can take. *)
  Fixpoint insert (a: t) (tr: tree) : tree :=
    match tr with
    | Leaf => Singleton a
    | Node v lt rt =>
      match compare a v with
      | Lt => Node v (insert a lt) rt
      | Eq => tr
      | Gt => Node v lt (insert a rt)
      end
    end.

  (* Helper functions for [delete] below. The *main task* in this pset
     is to understand, specify, and prove these helpers. *)
  Fixpoint rightmost (tr: tree) : option t :=
    match tr with
    | Leaf => None
    | Node v _ rt =>
      match rightmost rt with
      | None => Some v
      | r => r
      end
    end.
  Definition is_leaf (tr : tree) : bool :=
    match tr with Leaf => true | _ => false end.
  Fixpoint delete_rightmost (tr: tree) : tree :=
    match tr with
    | Leaf => Leaf
    | Node v lt rt =>
      if is_leaf rt
      then lt
      else Node v lt (delete_rightmost rt)
    end.
  Definition merge_ordered lt rt :=
    match rightmost lt with
    | Some rv => Node rv (delete_rightmost lt) rt
    | None => rt
    end.

  (* [delete] searches for an element by its value and removes it if it is found.
     Removing an element from a leaf is degenerate (nothing to do), and
     removing the value from a node with no other children (both Leaf) can be done
     by replacing the node itself with a Leaf. Deleting a non-leaf node is
     substantially trickier because the type of [tree] does not allow for a Node
     with two subtrees but no value -- merging two trees is nontrivial. The
     implementation here removes the value anyway and then moves the rightmost
     node of the left subtree up to replace the removed value. This is equivalent
     to using rotations to move the value to be removed into leaf position and
     removing it there. *)
  Fixpoint delete (a: t) (tr: tree) : tree :=
    match tr with
    | Leaf => Leaf
    | Node v lt rt =>
      match compare a v with
      | Lt => Node v (delete a lt) rt
      | Eq => merge_ordered lt rt
      | Gt => Node v lt (delete a rt)
      end
    end.

  (* Here is a lemma that you will almost definitely want to use. *)
  Example bst_iff : forall tr P Q, bst tr P -> (forall x, P x <-> Q x) -> bst tr Q.
  Proof.
    induct tr; simplify.
    { rewrite <- H0. apply H with (x:=x). }
    rewrite H0 in H.
    propositional.
    { apply IHtr1 with (P:=(fun x : t => (fun d => P x /\ x < d) d));
        propositional; cycle 1.
      { rewrite H0; trivial. }
      { rewrite <-H0; trivial. } }
    { apply IHtr2 with (P:=(fun x : t => (fun d => P x /\ d < x) d));
      propositional; cycle 2.
      { rewrite <-H0; trivial. }
      { rewrite H0; trivial. } }
  Qed.

  (* You may want to call these tactics to use the previous lemma. *)
  (* They are just a means to save some typing of [apply ... with]. *)
  Ltac use_bst_iff known_bst :=
    lazymatch type of known_bst with
    | bst ?tree2 ?set2 =>
        lazymatch goal with
        | |- bst ?tree1 ?set1 =>
            apply bst_iff with (P:=set2) (Q := set1);
            lazymatch goal with
            |- bst tree2 set2 => apply known_bst
            | _ => idtac
            end
        end
    end.

  Ltac use_bst_iff_assumption :=
    match goal with
    | H : bst ?t _ |- bst ?t _ =>
      use_bst_iff H
    end.

  (* If you are comfortable with it, [eapply bst_iff] followed by careful
   * application of other [bst] facts (e.g., inductive hypotheses) can
   * save typing in some places where this tactic does not apply, though
   * keep in mind that forcing an incorrect choice for a ?unification
   * variable can make the goal false. *)

  (* It may also be useful to know that you can switch to proving [False] by
   * calling [exfalso]. This, for example, enables you to apply lemmas that end in
   * [-> False]. Of course, only do this if the hypotheses are contradictory. *)

  (* Other tactics used in our solution: apply, apply with, apply with in
   * (including multiple "with" clauses like in [use_bst_iff]), cases, propositional,
     linear_arithmetic, simplify, trivial, try, induct, equality, rewrite, assert. *)

  (* Warm-up exercise: rebalancing rotations *)

  (* Transcribe and prove one of the two rotations shown in [rotation1.svg] and [rotation2.svg].
     The AA-tree rebalancing algorithm applies these only if the annotations of relevant
     subtrees are in violation of a performance-critical invariant, but the rotations
     themselves are correct regardless. (These are straight from
     https://en.wikipedia.org/wiki/AA_tree#Balancing_rotations.) *)
  (* Each one can be written as a simple non-recursive definition
     containing two "match" expressions that returns the original
     tree in cases where the expected structure is not present. *)

  (* HINT 1 (see Pset4Sig.v) *)
  Definition rotate (T : tree) : tree.
  Admitted.

  Lemma bst_rotate T s (H : bst T s) : bst (rotate T) s.
  Admitted.

  (* There is a hint in the signature file that completely gives away the proofs
   * of these rotations. We recommend you study that code after completing this
   * exercise to see how we did it, maybe picking up a trick or two to use below. *)

  Lemma bst_insert : forall tr s a, bst tr s ->
    bst (insert a tr) (fun x => s x \/ x = a).
  Proof.
  Admitted.

  (* To prove [bst_delete], you will need to write specifications for its helper
     functions, find suitable statements for proving correctness by induction, and use
     proofs of some helper functions in proofs of other helper functions. The hints
     in the signature file provide examples and guidance but no longer ready-to-prove
     lemma statements. For time-planning purposes: you are not halfway done yet.
     (The Sig file also has a rough point allocation between problems.)

     It is up to you whether to use one lemma per function, multiple lemmas per
     function, or (when applicable) one lemma per multiple functions. However,
     the lemmas you prove about one function need to specify everything a caller
     would need to know about this function. *)

  (* HINT 2-5 (see Pset4Sig.v) *)
  Lemma bst_delete : forall tr s a, bst tr s ->
    bst (delete a tr) (fun x => s x /\ x <> a).
  Proof.
  Admitted.

  (* Great job! Now you have proven all tree-structure-manipulating operations
     necessary to implement a balanced binary search tree. Rebalancing heuristics
     that achieve worst-case-logarithmic running time maintain annotations on
     nodes of the tree (and decide to rebalance based on these). The implementation
     here omits them, but as the rotation operations are correct regardless of
     the annotations, any way of calling them from heuristic code would result in a
     functionally correct binary tree. *)
End Impl.

Module ImplCorrect : Pset4Sig.S := Impl.

(* Authors:
 * Joonwon Choi
 * Adam Chlipala
 * Benjamin Sherman
 * Andres Erbsen
 * Amanda Liu
 *)


(* week_39b_arithmetic_expressions.v *)
(* dIFP 2014-2015, Q1, Week 38 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* Working version, make sure to download
   the updated version after class.
*)

(* ********** *)

Require Import Arith Bool List unfold_tactic.

(* ********** *)

(* Source syntax: *)

Inductive arithmetic_expression : Type :=
  | Lit : nat -> arithmetic_expression
  | Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
  | Times : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

(* Exercise 0:
   Write samples of arithmetic expressions.
*)

Definition ae_0 :=
  Lit 5.

Definition ae_1 :=
  Plus (Lit 2) (Lit 3).

Definition ae_2 :=
  Times (Plus (Lit 1) (Lit 2))
        (Lit 2).

(* ********** *)

Definition specification_of_interpret (interpret : arithmetic_expression -> nat) :=
  (forall n : nat,
     interpret (Lit n) = n)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Plus ae1 ae2) = (interpret ae1) + (interpret ae2))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Times ae1 ae2) = (interpret ae1) * (interpret ae2)).

(* Exercise 1:
   Write unit tests.
*)

Definition unit_test_for_interpret (interpret : arithmetic_expression -> nat) :=
  (beq_nat (interpret ae_0) 5)
  &&
  (beq_nat (interpret ae_1) 5)
  &&
  (beq_nat (interpret ae_2) 6)
  &&
  (beq_nat (interpret (Times ae_1 ae_2)) 30).

(* Exercise 2:
   Define an interpreter as a function
   that satisfies the specification above
   and verify that it passes the unit tests.
*)

Theorem there_is_only_one_interpret :
  forall (f g : arithmetic_expression -> nat),
    specification_of_interpret f ->
    specification_of_interpret g ->
    forall (ae : arithmetic_expression),
      f ae = g ae.
Proof.
  intros f g.
  unfold specification_of_interpret.
  intros [H_f_lit [H_f_plus H_f_times]] [H_g_lit [H_g_plus H_g_times]].
  intro ae.
  induction ae as [ n | ae1 IHae1 ae2 IHae2 | ae1' IHae1' ae2' IHae2' ].
      rewrite -> H_f_lit.
      rewrite -> H_g_lit.
      reflexivity.
    rewrite -> H_f_plus.
    rewrite -> H_g_plus.
    rewrite -> IHae1.
    rewrite -> IHae2.
    reflexivity.
  rewrite -> H_f_times.
  rewrite -> H_g_times.
  rewrite -> IHae1'.
  rewrite -> IHae2'.
  reflexivity.
Qed.

Fixpoint interpret_ds (ae : arithmetic_expression) :=
  match ae with
  | Lit n => n
  | Plus ae1 ae2 => interpret_ds ae1 + interpret_ds ae2
  | Times ae1 ae2 => interpret_ds ae1 * interpret_ds ae2
  end.

Definition interpret (ae : arithmetic_expression) :=
  interpret_ds ae.

Compute unit_test_for_interpret interpret.

Lemma unfold_interpret_ds_lit :
  forall n : nat,
    interpret_ds (Lit n) = n.
Proof.
  unfold_tactic interpret_ds.
Qed.

Lemma unfold_interpret_ds_plus :
  forall ae1 ae2 : arithmetic_expression,
    interpret_ds (Plus ae1 ae2) = interpret_ds ae1 + interpret_ds ae2.
Proof.
  unfold_tactic interpret_ds.
Qed.

Lemma unfold_interpret_ds_times :
  forall ae1 ae2 : arithmetic_expression,
    interpret_ds (Times ae1 ae2) = interpret_ds ae1 * interpret_ds ae2.
Proof.
  unfold_tactic interpret_ds.
Qed.

Proposition interpret_fits_the_specification_of_interpret :
  specification_of_interpret interpret.
Proof.
  unfold specification_of_interpret.
  split.
    exact unfold_interpret_ds_lit.
  split.
    exact unfold_interpret_ds_plus.
  exact unfold_interpret_ds_times.
Qed.

(* Byte-code instructions: *)

Inductive byte_code_instruction : Type :=
  | PUSH : nat -> byte_code_instruction
  | ADD : byte_code_instruction
  | MUL : byte_code_instruction.

(* ********** *)

(* Byte-code programs: *)

Definition byte_code_program := list byte_code_instruction.

(* Data stack: *)

Definition data_stack := list nat.

(* ********** *)

(* Exercise 3:
   specify a function
     execute_byte_code_instruction : instr -> data_stack -> data_stack
   that executes a byte-code instruction, given a data stack
   and returns this stack after the instruction is executed.

   * Executing (PUSH n) given s has the effect of pushing n on s.

   * Executing ADD given s has the effect of popping two numbers
     from s and then pushing the result of adding them.

   * Executing MUL given s has the effect of popping two numbers
     from s and then pushing the result of multiplying them.

   For now, if the stack underflows, just assume it contains zeroes.
*)

Fixpoint beq_list (T : Type) (l1 l2 : list T) (comp : T -> T -> bool) :=
  match l1 with
  | nil =>
      match l2 with
      | nil => true
      | _ => false
      end
  | e :: l =>
      match l2 with
      | nil => false
      | e' :: l' =>
          match comp e e' with
          | false => false
          | true => beq_list T l l' comp
          end
      end
  end.

Definition beq_nat_list (l1 l2 : list nat) :=
  beq_list nat l1 l2 beq_nat.

Definition s_0 : list nat :=
  nil.
Definition s_1 :=
  2 :: nil.
Definition s_2 :=
  2 :: 3 :: nil.

Compute beq_nat_list s_0 s_0. (* true *)
Compute beq_nat_list s_1 s_1. (* true *)
Compute beq_nat_list s_2 s_2. (* true *)
Compute beq_nat_list s_1 s_2. (* false *)

Definition unit_test_for_execute_byte_code_instruction (exec : byte_code_instruction -> data_stack -> data_stack) :=
  (* Test for push *)
  (beq_nat_list (exec (PUSH 2) s_1)
                (2 :: 2 :: nil))
  &&
  (* Test for add *)
  (beq_nat_list (exec ADD s_0)
                (0 :: nil))
  &&
  (beq_nat_list (exec ADD s_1)
                s_1)
  &&
  (beq_nat_list (exec ADD s_2)
                (5 :: nil))
  &&
  (* Test for mul *)
  (beq_nat_list (exec MUL s_0)
                (0 :: nil))
  &&
  (beq_nat_list (exec MUL s_1)
                (0 :: nil))
  &&
  (beq_nat_list (exec MUL s_2)
                (6 :: nil)).

Definition specification_of_execute_byte_code_instruction (exec : byte_code_instruction -> data_stack -> data_stack) :=
  (forall (n : nat) (s : data_stack),
    exec (PUSH n) s = n :: s)
  /\
  (forall (s : data_stack),
    exec ADD s = match s with
                 | nil => 0 :: nil
                 | n :: nil => n :: nil
                 | n :: n' :: s' => n + n' :: s'
                 end)
  /\
  (forall (s : data_stack),
    exec MUL s = match s with
                 | nil => 0 :: nil
                 | n :: nil => 0 :: nil
                 | n :: n' :: s' => n * n' :: s'
                 end).

Theorem there_is_only_one_execute_byte_code_instruction :
  forall (f g : byte_code_instruction -> data_stack -> data_stack),
    specification_of_execute_byte_code_instruction f ->
    specification_of_execute_byte_code_instruction g ->
    forall (instr : byte_code_instruction) (s : data_stack),
      f instr s = g instr s.
Proof.
  intros f g.
  unfold specification_of_execute_byte_code_instruction.
  intros [H_f_push [H_f_add H_f_mul]].
  intros [H_g_push [H_g_add H_g_mul]].
  intros instr s.
  case instr as [ n | | ].
      rewrite -> H_f_push.
      rewrite -> H_g_push.
      reflexivity.
    rewrite -> H_f_add.
    rewrite -> H_g_add.
    reflexivity.
  rewrite -> H_f_mul.
  rewrite -> H_g_mul.
  reflexivity.
Qed.

Definition execute_byte_code_instruction (instr : byte_code_instruction) (s : data_stack) :=
  match instr with
  | PUSH n => n :: s
  | ADD =>
      match s with
      | nil => 0 :: nil
      | n :: nil => n :: nil
      | n :: n' :: s' => n + n' :: s'
      end
  | MUL =>
      match s with
      | nil => 0 :: nil
      | n :: nil => 0 :: nil
      | n :: n' :: s' => n * n' :: s'
      end
  end.

Compute unit_test_for_execute_byte_code_instruction execute_byte_code_instruction.

Theorem execute_byte_code_instruction_fits_the_specification :
  specification_of_execute_byte_code_instruction execute_byte_code_instruction.
Proof.
  unfold specification_of_execute_byte_code_instruction.
  unfold execute_byte_code_instruction.
  split.
    intros n s.
    reflexivity.
  split.
    intro s.
    reflexivity.
  intro s.
  reflexivity.
Qed.

(* ********** *)

(* Exercise 4:
   Define a function
     execute_byte_code_program : byte_code_program -> data_stack -> data_stack
   that executes a given byte-code program on a given data stack,
   and returns this stack after the program is executed.
*)

Definition p_0 :=
  ADD :: nil.
Definition p_1 :=
  ADD :: ADD :: nil.
Definition p_2 :=
  ADD :: MUL :: nil.

Definition unit_test_for_execute_byte_code_program (exec_prog : byte_code_program -> data_stack -> data_stack) :=
  (beq_nat_list (exec_prog p_0 nil)
                (0 :: nil))
  &&
  (beq_nat_list (exec_prog p_0 s_2)
                (5 :: nil))
  &&
  (beq_nat_list (exec_prog p_1 (s_1 ++ s_2))
                (7 :: nil))
  &&
  (beq_nat_list (exec_prog p_2 (s_1 ++ s_2))
                (12 :: nil)).

Definition specification_of_execute_byte_code_program (exec_prog : byte_code_program -> data_stack -> data_stack) :=
  (forall s : data_stack,
    exec_prog nil s = s)
  /\
  (forall (instr : byte_code_instruction) (prog : byte_code_program) (s : data_stack),
    exec_prog (instr :: prog) s = exec_prog prog (execute_byte_code_instruction instr s)).

Theorem there_is_only_one_execute_byte_code_program :
  forall (f g : byte_code_program -> data_stack -> data_stack),
    specification_of_execute_byte_code_program f ->
    specification_of_execute_byte_code_program g ->
    forall (prog : byte_code_program) (s : data_stack),
      f prog s = g prog s.
Proof.
  intros f g.
  unfold specification_of_execute_byte_code_program.
  intros [H_f_bc H_f_ic] [H_g_bc H_g_ic].

  intros prog.
  induction prog as [ | x xs IHx ].

  intro s.
  rewrite -> H_f_bc.
  rewrite -> H_g_bc.
  reflexivity.

  intro s.
  rewrite -> H_f_ic.
  rewrite -> H_g_ic.
  rewrite -> IHx.
  reflexivity.
Qed.

Fixpoint execute_byte_code_program (prog : byte_code_program) (s : data_stack) :=
  match prog with
  | nil => s
  | instr :: prog => execute_byte_code_program prog (execute_byte_code_instruction instr s)
  end.

Compute unit_test_for_execute_byte_code_program execute_byte_code_program.

Lemma unfold_execute_byte_code_program_bc :
  forall s : data_stack,
    execute_byte_code_program nil s = s.
Proof.
  unfold_tactic execute_byte_code_program.
Qed.

Lemma unfold_execute_byte_code_program_ic :
  forall (instr : byte_code_instruction) (prog : byte_code_program) (s : data_stack),
    execute_byte_code_program (instr :: prog) s = execute_byte_code_program prog (execute_byte_code_instruction instr s).
Proof.
  unfold_tactic execute_byte_code_program.
Qed.

Theorem execute_byte_code_program_fits_the_specification :
  specification_of_execute_byte_code_program execute_byte_code_program.
Proof.
  unfold specification_of_execute_byte_code_program.
  split.
    exact unfold_execute_byte_code_program_bc.
  exact unfold_execute_byte_code_program_ic.
Qed.

(* ********** *)

(* Exercise 5:
   Prove that for all programs p1, p2 and data stacks s,
   executing (p1 ++ p2) with s
   gives the same result as
   (1) executing p1 with s, and then
   (2) executing p2 with the resulting stack.
*)

Lemma unfold_append_bc :
  forall (bcis : list byte_code_instruction),
    nil ++ bcis = bcis.
Proof.
  apply app_nil_l.
Qed.

Lemma unfold_append_ic :
  forall (bci1 : byte_code_instruction) (bci1s' bci2s : list byte_code_instruction),
    (bci1 :: bci1s') ++ bci2s = bci1 :: (bci1s' ++ bci2s).
Proof.
  intros bci1 bci1s' bci2s.
  symmetry.
  apply app_comm_cons.
Qed.

Lemma about_execute_byte_code_program :
  forall (p1 p2 : byte_code_program) (s : data_stack),
    execute_byte_code_program (p1 ++ p2) s = execute_byte_code_program p2 (execute_byte_code_program p1 s).
Proof.
  intro p1.
  induction p1 as [ | instr prog IHprog ].
    intros p2 s.
    rewrite -> unfold_append_bc.
    rewrite -> unfold_execute_byte_code_program_bc.
    reflexivity.
  intros p2 s.
  rewrite -> unfold_append_ic.
  rewrite ->2 unfold_execute_byte_code_program_ic.
  rewrite -> IHprog.
  reflexivity.
Qed.

(* ********** *)

Definition specification_of_compile (compile : arithmetic_expression -> byte_code_program) :=
  (forall n : nat,
     compile (Lit n) = PUSH n :: nil)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Plus ae1 ae2) = (compile ae1) ++ (compile ae2) ++ (ADD :: nil))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Times ae1 ae2) = (compile ae1) ++ (compile ae2) ++ (MUL :: nil)).

(* Exercise 6:
   Define a compiler as a function
   that satisfies the specification above
   and uses list concatenation, i.e., ++.
*)

Definition beq_instr (i1 i2 : byte_code_instruction) :=
  match i1 with
  | PUSH n1 =>
      match i2 with
      | PUSH n2 => beq_nat n1 n2
      | _ => false
      end
  | ADD =>
      match i2 with
      | ADD => true
      | _ => false
      end
  | MUL =>
      match i2 with
      | MUL => true
      | _ => false
      end
  end.

Compute beq_instr (PUSH 2) (PUSH 2). (* true *)
Compute beq_instr (PUSH 2) (PUSH 3). (* false *)
Compute beq_instr ADD ADD.           (* true *)
Compute beq_instr MUL ADD.           (* false *)

Definition beq_instr_list (p1 p2 : byte_code_program) :=
  beq_list byte_code_instruction p1 p2 beq_instr.

Compute beq_instr_list p_0 p_0. (* true *)
Compute beq_instr_list p_1 p_1. (* true *)
Compute beq_instr_list p_2 p_2. (* true *)
Compute beq_instr_list p_1 p_2. (* false *)

Definition unit_test_for_compile (compile : arithmetic_expression -> byte_code_program) :=
  (beq_instr_list (compile ae_0)
                  (PUSH 5 :: nil))
  &&
  (beq_instr_list (compile ae_1)
                  (PUSH 2 :: PUSH 3 :: ADD :: nil))
  &&
  (beq_instr_list (compile ae_2)
                  (PUSH 1 :: PUSH 2 :: ADD :: PUSH 2 :: MUL :: nil)).

Theorem there_is_only_one_compile :
  forall (f g : arithmetic_expression -> byte_code_program),
    specification_of_compile f ->
    specification_of_compile g ->
    forall (ae : arithmetic_expression),
      f ae = g ae.
Proof.
  intros f g.
  unfold specification_of_compile.
  intros [Hf_lit [Hf_plus Hf_times]].
  intros [Hg_lit [Hg_plus Hg_times]].
  intro ae.
  induction ae as [ n | ae1 IHae1 ae2 IHae2 | ae1' IHae1' ae2' IHae2' ].
      rewrite -> Hf_lit.
      rewrite -> Hg_lit.
      reflexivity.
    rewrite -> Hf_plus.
    rewrite -> Hg_plus.
    rewrite -> IHae1.
    rewrite -> IHae2.
    reflexivity.
  rewrite -> Hf_times.
  rewrite -> Hg_times.
  rewrite -> IHae1'.
  rewrite -> IHae2'.
  reflexivity.
Qed.

Fixpoint compile_ds (ae : arithmetic_expression) :=
  match ae with
  | Lit n => PUSH n :: nil
  | Plus ae1 ae2 => (compile_ds ae1) ++ (compile_ds ae2) ++ (ADD :: nil)
  | Times ae1 ae2 => (compile_ds ae1) ++ (compile_ds ae2) ++ (MUL :: nil)
  end.

Definition compile_v0 (ae : arithmetic_expression) :=
  compile_ds ae.

Compute unit_test_for_compile compile_v0.

Lemma unfold_compile_ds_lit :
  forall n : nat,
    compile_ds (Lit n) = PUSH n :: nil.
Proof.
  unfold_tactic compile_ds.
Qed.

Lemma unfold_compile_ds_plus :
  forall (ae1 ae2 : arithmetic_expression),
    compile_ds (Plus ae1 ae2) = (compile_ds ae1) ++ (compile_ds ae2) ++ (ADD :: nil).
Proof.
  unfold_tactic compile_ds.
Qed.

Lemma unfold_compile_ds_times :
  forall (ae1 ae2 : arithmetic_expression),
    compile_ds (Times ae1 ae2) = (compile_ds ae1) ++ (compile_ds ae2) ++ (MUL :: nil).
Proof.
  unfold_tactic compile_ds.
Qed.

Theorem compile_v0_fits_the_specification_of_compile :
  specification_of_compile compile_v0.
Proof.
  unfold specification_of_compile.
  split.
    exact unfold_compile_ds_lit.
  split.
    exact unfold_compile_ds_plus.
  exact unfold_compile_ds_times.
Qed.

(* Exercise 7:
   Write a compiler as a function with an accumulator
   that does not use ++ but :: instead,
   and prove it equivalent to the compiler of Exercise 6.
*)

Fixpoint compile_acc (ae : arithmetic_expression) (prog : byte_code_program) :=
  match ae with
  | Lit n => PUSH n :: prog
  | Plus ae1 ae2 => compile_acc ae1 (compile_acc ae2 (ADD :: prog))
  | Times ae1 ae2 => compile_acc ae1 (compile_acc ae2 (MUL :: prog))
  end.

Definition compile_v1 (ae : arithmetic_expression) :=
  compile_acc ae nil.

Compute unit_test_for_compile compile_v1.

Lemma unfold_compile_acc_lit :
  forall (n : nat) (prog : byte_code_program),
    compile_acc (Lit n) prog = PUSH n :: prog.
Proof.
  unfold_tactic compile_acc.
Qed.

Lemma unfold_compile_acc_plus :
  forall (ae1 ae2 : arithmetic_expression) (prog : byte_code_program),
    compile_acc (Plus ae1 ae2) prog = compile_acc ae1 (compile_acc ae2 (ADD :: prog)).
Proof.
  unfold_tactic compile_acc.
Qed.

Lemma unfold_compile_acc_times :
  forall (ae1 ae2 : arithmetic_expression) (prog : byte_code_program),
    compile_acc (Times ae1 ae2) prog = compile_acc ae1 (compile_acc ae2 (MUL :: prog)).
Proof.
  unfold_tactic compile_acc.
Qed.

Lemma about_compile_acc :
  forall (ae : arithmetic_expression) (prog : byte_code_program),
    compile_acc ae prog = compile_acc ae nil ++ prog.
Proof.
  intro ae.
  induction ae as [ n | ae1 IHae1 ae2 IHae2 | ae1' IHae1' ae2' IHae2' ].
      intro prog.
      rewrite ->2 unfold_compile_acc_lit.
      rewrite -> unfold_append_ic.
      rewrite -> unfold_append_bc.
      reflexivity.
    intro prog.
    rewrite ->2 unfold_compile_acc_plus.
    rewrite -> IHae1.
    rewrite -> IHae2.
    rewrite -> (IHae1 (compile_acc ae2 (ADD :: nil))).
    rewrite -> (IHae2 (ADD :: nil)).
    rewrite ->2 app_assoc_reverse.
    rewrite -> unfold_append_ic.
    rewrite -> unfold_append_bc.
    reflexivity.
  intro prog.
  rewrite ->2 unfold_compile_acc_times.
  rewrite -> IHae1'.
  rewrite -> IHae2'.
  rewrite -> (IHae1' (compile_acc ae2' (MUL :: nil))).
  rewrite -> (IHae2' (MUL :: nil)).
  rewrite ->2 app_assoc_reverse.
  rewrite -> unfold_append_ic.
  rewrite -> unfold_append_bc.
  reflexivity.
Qed.

Theorem compile_v1_fits_the_specification_of_compile :
  specification_of_compile compile_v1.
Proof.
  unfold specification_of_compile.
  unfold compile_v1.
  split.
    intro n.
    apply unfold_compile_acc_lit.
  split.
    intros ae1 ae2.
    rewrite -> unfold_compile_acc_plus.
    rewrite -> about_compile_acc.
    rewrite -> (about_compile_acc ae2 (ADD :: nil)).
    reflexivity.
  intros ae1 ae2.
  rewrite -> unfold_compile_acc_times.
  rewrite -> about_compile_acc.
  rewrite -> (about_compile_acc ae2 (MUL :: nil)).
  reflexivity.
Qed.

Proposition compile_v0_and_compile_v1_are_equivalent :
  forall ae : arithmetic_expression,
    compile_v0 ae = compile_v1 ae.
Proof.
  apply there_is_only_one_compile.
    exact compile_v0_fits_the_specification_of_compile.
  exact compile_v1_fits_the_specification_of_compile.
Qed.

(* ********** *)

(* Exercise 8:
   Prove that interpreting an arithmetic expression gives the same result
   as first compiling it and then executing the compiled program
   over an empty data stack.
*)

Definition unit_test_for_run (run : byte_code_program -> nat) :=
  (beq_nat (run (PUSH 5 :: nil))
           5)
  &&
  (beq_nat (run (PUSH 1 :: PUSH 2 :: ADD :: nil))
           3)
  &&
  (beq_nat (run (PUSH 1 :: PUSH 2 :: MUL :: nil))
           2)
  &&
  (beq_nat (run (nil))
           0)
  &&
  (beq_nat (run (PUSH 1 :: MUL :: nil))
           0)
  &&
  (beq_nat (run (PUSH 1 :: ADD :: nil))
           1)
  &&
  (beq_nat (run (ADD :: MUL :: nil))
           0).

Definition specification_of_run (run : byte_code_program -> nat) :=
  forall prog : byte_code_program,
    run prog =
      match execute_byte_code_program prog nil with
      | result :: nil => result
      | _ => 0
      end.

Theorem there_is_only_one_run :
  forall (f g : byte_code_program -> nat),
    specification_of_run f ->
    specification_of_run g ->
    forall prog : byte_code_program,
      f prog = g prog.
Proof.
  intros f g.
  unfold specification_of_run.
  intros S_f S_g.
  intro prog.
  rewrite -> S_f.
  rewrite -> S_g.
  reflexivity.
Qed.

Definition run (prog : byte_code_program) :=
  match execute_byte_code_program prog nil with
  | result :: nil => result
  | _ => 0
  end.

Compute unit_test_for_run run.

Lemma interpret_exp_cons_datastack_eq_execute_compile_exp_ds :
  forall (ae : arithmetic_expression) (s : data_stack),
    interpret ae :: s = execute_byte_code_program (compile_v0 ae) s.
Proof.
  intro ae.
  induction ae as [ n | ae1 IHae1 ae2 IHae2 | ae1' IHae1' ae2' IHae2' ].
      intro s.
      rewrite -> unfold_interpret_ds_lit.
      rewrite -> unfold_compile_ds_lit.
      rewrite -> unfold_execute_byte_code_program_ic.
      rewrite -> unfold_execute_byte_code_program_bc.
      unfold execute_byte_code_instruction.
      reflexivity.
    intro s.
    unfold interpret.
    rewrite -> unfold_interpret_ds_plus.
    unfold compile_v0.
    rewrite -> unfold_compile_ds_plus.
    rewrite ->2 about_execute_byte_code_program.
    rewrite -> unfold_execute_byte_code_program_ic.
    rewrite -> unfold_execute_byte_code_program_bc.
    rewrite <- IHae1.
    rewrite <- IHae2.
    unfold execute_byte_code_instruction.
    rewrite -> plus_comm.
    reflexivity.
  intro s.
  unfold interpret.
  rewrite -> unfold_interpret_ds_times.
  unfold compile_v0.
  rewrite -> unfold_compile_ds_times.
  rewrite ->2 about_execute_byte_code_program.
  rewrite -> unfold_execute_byte_code_program_ic.
  rewrite -> unfold_execute_byte_code_program_bc.
  rewrite <- IHae1'.
  rewrite <- IHae2'.
  unfold execute_byte_code_instruction.
  rewrite -> mult_comm.
  reflexivity.
Qed.

Theorem interpret_yields_same_result_as_compile_then_execute :
  forall ae : arithmetic_expression,
    interpret ae = run (compile_v0 ae).
Proof.
  intro ae.
  unfold run.
  unfold compile_v0.
  rewrite <- interpret_exp_cons_datastack_eq_execute_compile_exp_ds.
  reflexivity.
Qed.

(* ********** *)

(* Exercise 9:
   Write a Magritte-style execution function for a byte-code program
   that does not operate on natural numbers but on syntactic representations
   of natural numbers:

   Definition data_stack := list arithmetic_expression.

   * Executing (PUSH n) given s has the effect of pushing (Lit n) on s.

   * Executing ADD given s has the effect of popping two arithmetic
     expressions from s and then pushing the syntactic representation of
     their addition.

   * Executing MUL given s has the effect of popping two arithmetic
     expressions from s and then pushing the syntactic representation of
     their multiplication.

   Again, for this week's exercise,
   assume there are enough arithmetic expressions on the data stack.
   If that is not the case, just pad it up with syntactic representations
   of zero.

*)

Definition data_stack2 := list arithmetic_expression.

Fixpoint beq_ae (ae1 ae2 : arithmetic_expression) :=
  match ae1 with
  | (Lit n) =>
      match ae2 with
      | (Lit n') => beq_nat n n'
      | _ => false
      end
  | (Plus ae1' ae2') =>
      match ae2 with
      | (Plus ae1'' ae2'') => (beq_ae ae1' ae1'') && (beq_ae ae2' ae2'')
      | _ => false
      end
  | (Times ae1' ae2') =>
      match ae2 with
      | (Times ae1'' ae2'') => (beq_ae ae1' ae1'') && (beq_ae ae2' ae2'')
      | _ => false
      end
  end.

Compute beq_ae (Plus (Lit 0) (Lit 0)) (Plus (Lit 0) (Lit 0)).
Compute beq_ae (Plus (Lit 1) (Lit 0)) (Plus (Lit 0) (Lit 0)).

Definition beq_ae_list (s1 s2 : data_stack2) :=
  beq_list arithmetic_expression s1 s2 beq_ae.

Definition unit_test_for_magritte (magritte : byte_code_program -> data_stack2) :=
  (beq_ae_list (magritte (PUSH 5 :: nil))
               (Lit 5 :: nil))
  &&
  (beq_ae_list (magritte (PUSH 1 :: PUSH 2 :: ADD :: nil))
               (Plus (Lit 2) (Lit 1) :: nil))
  &&
  (beq_ae_list (magritte (PUSH 1 :: PUSH 2 :: MUL :: nil))
               (Times (Lit 2) (Lit 1) :: nil))
  &&
  (beq_ae_list (magritte (nil))
               nil)
  &&
  (beq_ae_list (magritte (PUSH 1 :: MUL :: nil))
               (Times (Lit 1) (Lit 0) :: nil))
  &&
  (beq_ae_list (magritte (PUSH 1 :: ADD :: nil))
               (Plus (Lit 1) (Lit 0) :: nil))
  &&
  (beq_ae_list (magritte (ADD :: MUL :: nil))
               (Times (Plus (Lit 0) (Lit 0)) (Lit 0) :: nil)).

Definition specification_of_magritte (magritte : byte_code_program -> data_stack2 -> data_stack2) :=
  (forall (s : data_stack2),
    magritte nil s = s)
  /\
  (forall (n : nat) (prog : byte_code_program) (s : data_stack2),
    magritte ((PUSH n) :: prog) s = magritte prog ((Lit n) :: s))
  /\
  (forall (prog : byte_code_program),
    magritte (ADD :: prog) nil = magritte prog ((Plus (Lit 0) (Lit 0)) :: nil))
  /\
  (forall (prog : byte_code_program) (ae : arithmetic_expression),
    magritte (ADD :: prog) (ae :: nil) = magritte prog ((Plus (Lit 0) ae) :: nil))
  /\
  (forall (prog : byte_code_program) (ae1 ae2 : arithmetic_expression) (s : data_stack2),
    magritte (ADD :: prog) (ae1 :: ae2 :: s) = magritte prog ((Plus ae2 ae1) :: s))
  /\
  (forall (prog : byte_code_program),
    magritte (MUL :: prog) nil = magritte prog ((Times (Lit 0) (Lit 0)) :: nil))
  /\
  (forall (prog : byte_code_program) (ae : arithmetic_expression),
    magritte (MUL :: prog) (ae :: nil) = magritte prog ((Times (Lit 0) ae) :: nil))
  /\
  (forall (prog : byte_code_program) (ae1 ae2 : arithmetic_expression) (s : data_stack2),
    magritte (MUL :: prog) (ae1 :: ae2 :: s) = magritte prog ((Times ae2 ae1) :: s)).

Theorem there_is_only_one_magritte :
  forall (f g : byte_code_program -> data_stack2 -> data_stack2),
    specification_of_magritte f ->
    specification_of_magritte g ->
    forall (prog : byte_code_program) (s : data_stack2),
      f prog s = g prog s.
Proof.
  intros f g.
  unfold specification_of_magritte.
  intros [H_f_nil [H_f_push [H_f_add_0 [H_f_add_1 [H_f_add_2 [H_f_mul_0 [H_f_mul_1 H_f_mul_2]]]]]]].
  intros [H_g_nil [H_g_push [H_g_add_0 [H_g_add_1 [H_g_add_2 [H_g_mul_0 [H_g_mul_1 H_g_mul_2]]]]]]].
  intro prog.
  induction prog as [ | instr prog IHprog].
    intro s.
    rewrite -> H_f_nil.
    rewrite -> H_g_nil.
    reflexivity.
  intro s.
  case instr as [ n | | ].
      rewrite -> H_f_push.
      rewrite -> H_g_push.
      rewrite -> IHprog.
      reflexivity.
    case s as [ | ae s' ].
      rewrite -> H_f_add_0.
      rewrite -> H_g_add_0.
      rewrite -> IHprog.
      reflexivity.
    case s' as [ | ae' s''].
      rewrite -> H_f_add_1.
      rewrite -> H_g_add_1.
      rewrite -> IHprog.
      reflexivity.
    rewrite -> H_f_add_2.
    rewrite -> H_g_add_2.
    rewrite -> IHprog.
    reflexivity.
  case s as [ | ae s' ].
    rewrite -> H_f_mul_0.
    rewrite -> H_g_mul_0.
    rewrite -> IHprog.
    reflexivity.
  case s' as [ | ae' s''].
    rewrite -> H_f_mul_1.
    rewrite -> H_g_mul_1.
    rewrite -> IHprog.
    reflexivity.
  rewrite -> H_f_mul_2.
  rewrite -> H_g_mul_2.
  rewrite -> IHprog.
  reflexivity.
Qed.

Fixpoint magritte_ds (prog : byte_code_program) (s : data_stack2) :=
  match prog with
  | nil => s
  | (PUSH n) :: prog' => magritte_ds prog' ((Lit n) :: s)
  | ADD :: prog' =>
      match s with
      | nil => magritte_ds prog' ((Plus (Lit 0) (Lit 0)) :: nil)
      | ae :: nil => magritte_ds prog' ((Plus (Lit 0) ae) :: nil)
      | ae1 :: ae2 :: exps => magritte_ds prog' ((Plus ae2 ae1) :: exps)
      end
  | MUL :: prog' =>
      match s with
      | nil => magritte_ds prog' ((Times (Lit 0) (Lit 0)) :: nil)
      | ae :: nil => magritte_ds prog' ((Times (Lit 0) ae) :: nil)
      | ae1 :: ae2 :: s' => magritte_ds prog' ((Times ae2 ae1) :: s')
      end
  end.

Definition magritte_v0 (prog : byte_code_program) :=
  magritte_ds prog nil.

Compute unit_test_for_magritte magritte_v0.

Lemma unfold_magritte_ds_nil_prog :
  forall (s : data_stack2),
    magritte_ds nil s = s.
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_push :
  forall (n : nat) (prog' : byte_code_program) (s : data_stack2),
    magritte_ds ((PUSH n) :: prog') s = magritte_ds prog' ((Lit n) :: s).
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_add_0 :
  forall (prog' : byte_code_program),
    magritte_ds (ADD :: prog') nil = magritte_ds prog' ((Plus (Lit 0) (Lit 0)) :: nil).
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_add_1 :
  forall (prog' : byte_code_program) (ae : arithmetic_expression),
    magritte_ds (ADD :: prog') (ae :: nil) = magritte_ds prog' ((Plus (Lit 0) ae) :: nil).
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_add_2 :
  forall (prog' : byte_code_program) (ae1 ae2 : arithmetic_expression) (s : data_stack2),
    magritte_ds (ADD :: prog') (ae1 :: ae2 :: s) = magritte_ds prog' ((Plus ae2 ae1) :: s).
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_mul_0 :
  forall (prog' : byte_code_program),
    magritte_ds (MUL :: prog') nil = magritte_ds prog' ((Times (Lit 0) (Lit 0)) :: nil).
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_mul_1 :
  forall (prog' : byte_code_program) (ae : arithmetic_expression),
    magritte_ds (MUL :: prog') (ae :: nil) = magritte_ds prog' ((Times (Lit 0) ae) :: nil).
Proof.
  unfold_tactic magritte_ds.
Qed.

Lemma unfold_magritte_ds_mul_2 :
  forall (prog' : byte_code_program) (ae1 ae2 : arithmetic_expression) (s : data_stack2),
    magritte_ds (MUL :: prog') (ae1 :: ae2 :: s) = magritte_ds prog' ((Times ae2 ae1) :: s).
Proof.
  unfold_tactic magritte_ds.
Qed.

Theorem magritte_ds_fits_the_specification_of_magritte :
  specification_of_magritte magritte_ds.
Proof.
  unfold specification_of_magritte.
  split.
    exact unfold_magritte_ds_nil_prog.
  split.
    exact unfold_magritte_ds_push.
  split.
    exact unfold_magritte_ds_add_0.
  split.
    exact unfold_magritte_ds_add_1.
  split.
    exact unfold_magritte_ds_add_2.
  split.
    exact unfold_magritte_ds_mul_0.
  split.
    exact unfold_magritte_ds_mul_1.
  exact unfold_magritte_ds_mul_2.
Qed.

(* Exercise 10:
   Prove that the Magrite-style execution function from Exercise 9
   implements a decompiler that is the left inverse of the compiler
   of Exercise 6.
*)

Compute ae_0.

Definition unit_test_for_run_magritte (candidate : byte_code_program -> arithmetic_expression) :=
  (beq_ae (candidate (compile_v0 ae_0))
          ae_0)
  &&
  (beq_ae (candidate (compile_v0 ae_1))
          ae_1)
  &&
  (beq_ae (candidate (compile_v0 ae_2))
          ae_2).

Definition specification_of_run_magritte (run_magritte : byte_code_program -> arithmetic_expression) :=
  (forall prog : byte_code_program,
    run_magritte prog =
      match (magritte_v0 prog) with
      | ae :: nil => ae
      | _ => Lit 0
      end).

Theorem there_is_only_one_run_magritte :
  forall (f g : byte_code_program -> arithmetic_expression),
    specification_of_run_magritte f ->
    specification_of_run_magritte g ->
    forall prog : byte_code_program,
      f prog = g prog.
Proof.
  intros f g.
  unfold specification_of_run_magritte.
  intros S_f S_g.
  intro prog.
  rewrite -> S_f.
  rewrite -> S_g.
  reflexivity.
Qed.

Definition run_magritte (prog : byte_code_program) : arithmetic_expression :=
  match (magritte_v0 prog) with
  | ae :: nil => ae
  | _ => Lit 0
  end.

Compute unit_test_for_run_magritte run_magritte.

Proposition run_magritte_fits_the_specification_of_run_magritte :
  specification_of_run_magritte run_magritte.
Proof.
  unfold specification_of_run_magritte.
  intro prog.
  unfold run_magritte.
  reflexivity.
Qed.

Check unfold_append_bc.
Check unfold_append_ic.

Lemma about_magritte_ds_and_append :
  forall (p1 p2 : byte_code_program) (s : data_stack2),
    magritte_ds (p1 ++ p2) s = magritte_ds p2 (magritte_ds p1 s).
Proof.
  intro p1.
  induction p1 as [ | instr prog IHprog ].
    intros p2 s.
    rewrite -> unfold_append_bc.
    rewrite -> unfold_magritte_ds_nil_prog.
    reflexivity.
  intros p2 s.
  rewrite -> unfold_append_ic.
  case instr as [ n | | ].
      rewrite ->2 unfold_magritte_ds_push.
      rewrite -> IHprog.
      reflexivity.
    case s as [ | ae s'].
      rewrite ->2 unfold_magritte_ds_add_0.
      rewrite -> IHprog.
      reflexivity.
    case s' as [ | ae' s''].
      rewrite ->2 unfold_magritte_ds_add_1.
      rewrite -> IHprog.
      reflexivity.
    rewrite ->2 unfold_magritte_ds_add_2.
    rewrite -> IHprog.
    reflexivity.
  case s as [ | ae s'].
    rewrite ->2 unfold_magritte_ds_mul_0.
    rewrite -> IHprog.
    reflexivity.
  case s' as [ | ae' s''].
    rewrite ->2 unfold_magritte_ds_mul_1.
    rewrite -> IHprog.
    reflexivity.
  rewrite ->2 unfold_magritte_ds_mul_2.
  rewrite -> IHprog.
  reflexivity.
Qed.

Lemma magritte_on_compiled_ae_eq_ae_cons_data_stack :
  forall (ae : arithmetic_expression) (s : data_stack2),
    magritte_ds (compile_v0 ae) s = ae :: s.
Proof.
  intro ae.
  unfold compile_v0.
  induction ae as [ n | ae1 IHae1 ae2 IHae2 | ae1' IHae1' ae2' IHae2' ].
      intro s.
      rewrite -> unfold_compile_ds_lit.
      rewrite -> unfold_magritte_ds_push.
      rewrite -> unfold_magritte_ds_nil_prog.
      reflexivity.
    intro s.
    rewrite -> unfold_compile_ds_plus.
    rewrite ->2 about_magritte_ds_and_append.
    rewrite -> IHae1.
    rewrite -> IHae2.
    rewrite -> unfold_magritte_ds_add_2.
    rewrite -> unfold_magritte_ds_nil_prog.
    reflexivity.
  intro s.
  rewrite -> unfold_compile_ds_times.
  rewrite ->2 about_magritte_ds_and_append.
  rewrite -> IHae1'.
  rewrite -> IHae2'.
  rewrite -> unfold_magritte_ds_mul_2.
  rewrite -> unfold_magritte_ds_nil_prog.
  reflexivity.
Qed.

Theorem run_magritte_implements_a_decompiler :
  forall ae : arithmetic_expression,
    run_magritte(compile_v0 ae) = ae.
Proof.
  intro ae.
  unfold run_magritte.
  unfold magritte_v0.
  rewrite -> magritte_on_compiled_ae_eq_ae_cons_data_stack.
  reflexivity.
Qed.

(* ********** *)

(* end of week_39b_arithmetic_expressions.v *)


Require Import Nat Arith.

Inductive Tree : Type := node : nat -> Tree -> Tree -> Tree |  leaf : Tree.

Fixpoint tinsert (tinsert_arg0 : Tree) (tinsert_arg1 : nat) : Tree
           := match tinsert_arg0, tinsert_arg1 with
              | leaf, i => node i leaf leaf
              | node d l r, i => if ltb d i then node d l (tinsert r i) else node d (tinsert l i) r
              end.

Fixpoint tsize (tsize_arg0 : Tree) : nat
           := match tsize_arg0 with
              | leaf => 0
              | node x l r => plus 1 (plus (tsize l) (tsize r))
              end.

Theorem theorem0 : forall (t : Tree) (n : nat), eq (tsize (tinsert t n)) (plus 1 (tsize t)).
Proof.
   intros.
   induction t.
   -  simpl. destruct (ltb n0 n).
   + simpl. rewrite IHt2. f_equal. rewrite <- plus_n_Sm.
   reflexivity.
  + simpl. rewrite IHt1. reflexivity.
  - reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus (mult y x) lf1.


Set Implicit Arguments.
Require Export List.
Require Import MyTactics.

(* ---------------------------------------------------------------------------- *)

(* [repeat n a] is a list of [n] copies of the element [a]. *)

Fixpoint repeat A (n : nat) (a : A) : list A :=
  match n with 0 => nil | S n => a :: repeat n a end.

(* ---------------------------------------------------------------------------- *)

(* If every element satisfies [P], and if [P] implies [Q], then every element
   satisfies [Q]. *)

Lemma Forall_covariant:
  forall A (P Q : A -> Prop) xs,
  Forall P xs ->
  (forall x, P x -> Q x) ->
  Forall Q xs.
Proof.
  induction 1; econstructor; eauto.
Qed.

(* If every element of [xs] satisfies [P], and if [f] maps [P] to [Q],
   then every element of [map f xs] satisfies [Q]. *)

Lemma Forall_map:
  forall A B (f : A -> B) (P : A -> Prop) (Q : B -> Prop) xs,
  Forall P xs ->
  (forall x, P x -> Q (f x)) ->
  Forall Q (map f xs).
Proof.
  induction 1; simpl; eauto.
Qed.

Lemma Forall_map_reverse:
  forall A B (f : A -> B) (P : A -> Prop) (Q : B -> Prop) xs,
  Forall Q (map f xs) ->
  (forall x, Q (f x) -> P x) ->
  Forall P xs.
Proof.
  induction xs; simpl; inversion 1; eauto.
Qed.

(* If every element of [xs] satisfies [P] and every element of [ys]
   satisfies [P], then every element of [xs ++ ys] satisfies [P]. *)

Lemma Forall_app:
  forall A (P : A -> Prop) (xs ys : list A),
  Forall P xs ->
  Forall P ys ->
  Forall P (xs ++ ys).
Proof.
  induction 1; simpl; eauto.
Qed.

(* ---------------------------------------------------------------------------- *)

Lemma Forall2_length:
  forall A B (R : A -> B -> Prop) xs ys,
  Forall2 R xs ys ->
  length xs = length ys.
Proof.
  induction 1; simpl; eauto.
Qed.

Lemma Forall2_Forall_modus_ponens:
  forall A B : Type,
  forall P : A -> B -> Prop,
  forall Q : B -> Prop,
  (forall a b, P a b -> Q b) ->
  forall xs ys,
  Forall2 P xs ys ->
  Forall Q ys.
Proof.
  induction 2; econstructor; eauto.
Qed.

(* ---------------------------------------------------------------------------- *)

(* A definition of [nth] as a relation. *)

Inductive is_nth A : nat -> list A -> A -> Prop :=
| IsNthZero:
    forall x xs,
    is_nth 0 (x :: xs) x
| IsNthSucc:
    forall n y x xs,
    is_nth n xs y ->
    is_nth (S n) (x :: xs) y.

Hint Constructors is_nth : is_nth.

(* This tactic proves that [is_nth n xs x] implies that [xs] is non-empty. *)

Ltac is_nth_nonempty :=
  match goal with h: is_nth _ ?xs _ |- _ =>
    destruct xs; [ inversion h | ]
  end.

(* ---------------------------------------------------------------------------- *)

(* Lemmas about [is_nth]. *)

(* If every element satisfies [P], then the [n]-th element satisfies [P]. *)

Lemma is_nth_Forall:
  forall A P n xs (x : A),
  is_nth n xs x ->
  Forall P xs ->
  P x.
Proof.
  induction 1; inversion 1; subst; eauto.
Qed.

(* If [x] is the [n]-th element of [xs], then [f x] is the [n]-th element
   of [map f xs]. *)

Lemma is_nth_map:
  forall A B (f : A -> B) n xs x,
  is_nth n xs x ->
  is_nth n (map f xs) (f x).
Proof.
  induction 1; econstructor; eauto.
Qed.

Lemma is_nth_map_reverse:
  forall A B (f : A -> B) xs n y,
  is_nth n (map f xs) y ->
  exists x,
  is_nth n xs x /\ f x = y.
Proof.
  induction xs; simpl; dependent_destruction.
  repeat econstructor.
  forwards: IHxs. eauto. unpack.
  repeat econstructor; eauto.
Qed.

(* [is_nth] is injective. *)

Lemma is_nth_injective:
  forall A xs n (x1 x2 : A),
  is_nth n xs x1 ->
  is_nth n xs x2 ->
  x1 = x2.
Proof.
  induction 1; inversion 1; eauto.
Qed.

(* If [x] is the [n]-th element of [xs], then [xs] has length greater than [n]. *)

Lemma is_nth_length:
  forall A n (xs : list A) x,
  is_nth n xs x ->
  n < length xs.
Proof.
  induction 1; simpl; eauto with omega.
Qed.

(* Conversely, if has length greater than [n], then some [x] is the [n]-th
   element of [xs]. *)

Lemma length_is_nth:
  forall A (xs : list A) n,
  n < length xs ->
  exists x,
  is_nth n xs x.
Proof.
  induction xs; simpl; intros; [ false; omega | destruct n ].
  repeat econstructor.
  forwards: IHxs. instantiate (1 := n). omega. unpack. repeat econstructor; eauto.
Qed.

(* A combination of the above two lemmas. *)

Lemma is_nth_common_length:
  forall A n (xs : list A) x,
  is_nth n xs x ->
  forall B (ys : list B),
  length xs = length ys ->
  exists y,
  is_nth n ys y.
Proof.
  introv ? heq.
  eapply length_is_nth.
  rewrite <- heq.
  eauto using is_nth_length.
Qed.

(* Looking for the [n]-th element of [xs ++ ys]. *)

Lemma is_nth_app_near:
  forall A (xs ys : list A) n x,
  is_nth n xs x ->
  is_nth n (xs ++ ys) x.
Proof.
  induction 1; simpl; econstructor; eauto.
Qed.

Lemma is_nth_app_far:
  forall A (xs ys : list A) k n y,
  is_nth k ys y ->
  length xs + k = n ->
  is_nth n (xs ++ ys) y.
Proof.
  induction xs; simpl; intros.
  replace n with k by omega. assumption.
  destruct n; [ false; omega | ].
  econstructor. eauto.
Qed.

Lemma Forall2_is_nth:
  forall A B (R : A -> B -> Prop) xs ys,
  Forall2 R xs ys ->
  forall n x y,
  is_nth n xs x ->
  is_nth n ys y ->
  R x y.
Proof.
  induction 1; inversion 1; inversion 1; subst; eauto.
Qed.

Lemma Forall2_is_nth_left_to_right:
  forall A B (R : A -> B -> Prop) xs ys,
  Forall2 R xs ys ->
  forall n x,
  is_nth n xs x ->
  exists y,
  is_nth n ys y /\ R x y.
Proof.
  dependent_induction; dependent_destruction.
  repeat econstructor; eauto.
  forwards: IHhdi. eauto. unpack.
  repeat econstructor; eauto.
Qed.

Lemma Forall2_is_nth_right_to_left:
  forall A B (R : A -> B -> Prop) xs ys,
  Forall2 R xs ys ->
  forall n y,
  is_nth n ys y ->
  exists x,
  is_nth n xs x /\ R x y.
Proof.
  dependent_induction; dependent_destruction.
  repeat econstructor; eauto.
  forwards: IHhdi. eauto. unpack.
  repeat econstructor; eauto.
Qed.

Lemma is_nth_inversion:
  forall A (xs : list A) n x y,
  is_nth n (xs ++ x :: nil) y ->
  is_nth n xs y \/ x = y.
Proof.
  induction xs; simpl; dependent_destruction.
  right. eauto.
  inversion hdd.
  left. econstructor.
  forwards [ | ]: IHxs; [ eauto | left | right ].
    econstructor; eauto.
    eauto.
Qed.

(* ---------------------------------------------------------------------------- *)

(* A function that updates the [n]-th element of a list. *)

Fixpoint set_nth A (n : nat) (xs : list A) (y : A) : list A :=
  match n, xs with
  | 0, _ :: xs =>
      y :: xs
  | S n, x :: xs =>
      x :: set_nth n xs y
  | _, nil =>
      nil (* dummy; considered non-sensical *)
  end.

(* ---------------------------------------------------------------------------- *)

(* Lemmas about [set_nth]. *)

Lemma Forall_set_nth:
  forall A (P : A -> Prop) (n : nat) (xs : list A) (y : A),
  Forall P xs ->
  P y ->
  Forall P (set_nth n xs y).
Proof.
  induction n; inversion 1; simpl; intros; eauto.
Qed.

Lemma Forall2_set_nth:
  forall A B (R : A -> B -> Prop) xs ys x y,
  Forall2 R xs ys ->
  R x y ->
  forall n,
  Forall2 R (set_nth n xs x)(set_nth n ys y).
Proof.
  induction 1; destruct n; simpl; intros; econstructor; eauto.
Qed.

Lemma is_nth_set_nth_there:
  forall A n (xs : list A) x1 x2,
  is_nth n xs x1 ->
  is_nth n (set_nth n xs x2) x2.
Proof.
  induction 1; simpl; econstructor; eauto.
Qed.

Lemma is_nth_set_nth_elsewhere:
  forall A n (xs : list A) x1 x2,
  is_nth n xs x1 ->
  forall m,
  m <> n ->
  is_nth n (set_nth m xs x2) x1.
Proof.
  induction 1; simpl; intros; destruct m; solve [
    false; omega
  | econstructor; eauto
  ].
Qed.

Lemma set_nth_identity:
  forall A n (xs : list A) x,
  is_nth n xs x ->
  set_nth n xs x = xs.
Proof.
  induction 1; simpl; f_equal; eauto.
Qed.

Lemma length_set_nth:
  forall A (xs : list A) n y,
  length (set_nth n xs y) = length xs.
Proof.
  induction xs; destruct n; intros; simpl; eauto.
Qed.

Lemma is_nth_set_nth_inversion:
  forall A (xs : list A) m n x1 x2,
  is_nth n (set_nth m xs x1) x2 ->
  m <> n /\ is_nth n xs x2 \/
  m  = n /\ x1 = x2.
Proof.
  induction xs; destruct m; simpl; dependent_destruction.
  right. eauto.
  left. eauto with is_nth.
  left. eauto with is_nth.
  forwards [ | ]: IHxs; [ eauto | left | right ]; unpack;
  eauto with omega is_nth.
Qed.

Lemma set_nth_app_left:
  forall A n (xs : list A) x1,
  is_nth n xs x1 ->
  forall ys x2,
  set_nth n (xs ++ ys) x2 = set_nth n xs x2 ++ ys.
Proof.
  induction 1; simpl; intros; eauto with f_equal.
Qed.

Lemma set_nth_set_nth:
  forall A (xs : list A) n1 a1,
  is_nth n1 xs a1 ->
  forall n2 a2,
  is_nth n2 xs a2 ->
  n1 <> n2 ->
  forall b1 b2,
  set_nth n2 (set_nth n1 xs b1) b2 = set_nth n1 (set_nth n2 xs b2) b1.
Proof.
  induction 1; inversion 1; intros; simpl; subst; eauto with falseomega f_equal omega.
Qed.

Lemma set_nth_overwrite:
  forall A n (xs : list A) y1 y2,
  set_nth n (set_nth n xs y1) y2 = set_nth n xs y2.
Proof.
  induction n; destruct xs; intros; simpl; eauto with f_equal.
Qed.

Lemma map_set_nth:
  forall A B (f : A -> B) n xs y,
  map f (set_nth n xs y) =
  set_nth n (map f xs) (f y).
Proof.
  induction n; destruct xs; intros; simpl; eauto with f_equal.
Qed.

(* ---------------------------------------------------------------------------- *)

(* A function that applies a transformation [f] to the [n]-th element of a list.
   This can be viewed as a generalization of [set_nth]. *)

Fixpoint apply_nth A (n : nat) (xs : list A) (f : A -> A) { struct xs } : list A :=
  match xs, n with
  | nil, _ =>
      nil (* dummy; considered non-sensical *)
  | x :: xs, 0 =>
      f x :: xs
  | x :: xs, S n =>
      x :: apply_nth n xs f
  end.

Lemma is_nth_set_nth_apply_nth:
  forall A (xs: list A) n a f,
  is_nth n xs a ->
  apply_nth n xs f = set_nth n xs (f a).
Proof.
  induction xs.
  destruct n; simpl; eauto.
  destruct n; inversion 1; subst; simpl; [ eauto | f_equal; eauto ].
Qed.

Lemma length_apply_nth:
  forall A (xs : list A) n f,
  length (apply_nth n xs f) = length xs.
Proof.
  induction xs; destruct n; intros; simpl; eauto.
Qed.

Lemma Forall_apply_nth:
  forall A (P : A -> Prop) f,
  (forall x, P x -> P (f x)) ->
  forall n xs,
  Forall P xs ->
  Forall P (apply_nth n xs f).
Proof.
  induction n; inversion 1; simpl; intros; eauto.
Qed.

Lemma is_nth_apply_nth_there:
  forall A n xs f (x : A),
  is_nth n xs x ->
  is_nth n (apply_nth n xs f) (f x).
Proof.
  induction 1; simpl; econstructor; eauto.
Qed.

Lemma is_nth_apply_nth_elsewhere:
  forall A n xs f (x : A),
  is_nth n xs x ->
  forall m,
  m <> n ->
  is_nth n (apply_nth m xs f) x.
Proof.
  induction 1; simpl; intros; destruct m; solve [
    false; omega
  | econstructor; eauto
  ].
Qed.

Lemma is_nth_apply_nth_inversion:
  forall A (xs : list A) m n x2 f,
  is_nth n (apply_nth m xs f) x2 ->
  m <> n /\ is_nth n xs x2 \/
  m  = n /\ exists x1, is_nth n xs x1 /\ f x1 = x2.
Proof.
  induction xs; destruct m; simpl; dependent_destruction.
  right. eauto with is_nth.
  left. eauto with is_nth.
  left. eauto with is_nth.
  forwards [ | ]: IHxs; [ eauto | left | right ]; unpack;
  eauto with omega is_nth.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The combinator [zip] maps a function [f] over two lists [xs] and [ys]. *)

Fixpoint zip A B C (f : A -> B -> C) (xs : list A) (ys : list B) : list C :=
  match xs, ys with
  | nil, _
  | _, nil =>
      nil
  | x :: xs, y :: ys =>
      f x y :: zip f xs ys
  end.

(* ---------------------------------------------------------------------------- *)

(* If [x] and [y] are the [n]-th elements of [xs] and [ys], then [f x y] is
   the [n]-th element of [zip f xs ys]. *)

Lemma is_nth_zip:
  forall A B C (f : A -> B -> C) n xs x,
  is_nth n xs x ->
  forall ys y,
  is_nth n ys y ->
  is_nth n (zip f xs ys) (f x y).
Proof.
  induction 1; inversion 1; subst; simpl; econstructor; eauto.
Qed.

Lemma is_nth_zip_eq:
  forall A B C (f : A -> B -> C) n xs x,
  is_nth n xs x ->
  forall ys y,
  is_nth n ys y ->
  forall z,
  z = f x y ->
  is_nth n (zip f xs ys) z.
Proof.
  intros; subst; eauto using is_nth_zip.
Qed.

Lemma zip_set_nth:
  forall A B C (f : A -> B -> C) n xs ys x y,
  zip f (set_nth n xs x) (set_nth n ys y) =
  set_nth n (zip f xs ys) (f x y).
Proof.
  induction n; destruct xs; destruct ys; intros; simpl; eauto with f_equal.
Qed.

(* [zip] preserves the length of the lists when there is agreement. *)

Lemma zip_length_left:
  forall A B C (f : A -> B -> C) (xs : list A) (ys : list B),
  length xs = length ys ->
  length (zip f xs ys) = length xs.
Proof.
  induction xs; destruct ys; simpl; eauto.
Qed.

Lemma zip_length_right:
  forall A B C (f : A -> B -> C) (xs : list A) (ys : list B),
  length xs = length ys ->
  length (zip f xs ys) = length ys.
Proof.
  induction xs; destruct ys; simpl; eauto.
Qed.

(* If [f] is commutative, then [zip f] is commutative. *)

Lemma zip_commutative:
  forall A C (f : A -> A -> C),
  (forall x y, f x y = f y x) ->
  forall (xs ys : list A),
  zip f xs ys = zip f ys xs.
Proof.
  induction xs; destruct ys; simpl; eauto with f_equal.
Qed.

(* If [f] is associative, then [zip f] is associative. *)

Lemma zip_associative:
  forall A (f : A -> A -> A),
  (forall x y z, f x (f y z) = f (f x y) z) ->
  forall (xs ys zs : list A),
  zip f xs (zip f ys zs) = zip f (zip f xs ys) zs.
Proof.
  induction xs; destruct ys; destruct zs; simpl; eauto with f_equal.
Qed.

(* An ad hoc lemma about [zip] and [map]. *)

Lemma zip_map_right:
  forall A B (f : A -> B -> A) (g : A -> B),
  (forall x, f x (g x) = x) ->
  forall xs,
  zip f xs (map g xs) = xs.
Proof.
  induction xs; simpl; eauto with f_equal.
Qed.

(* [zip] and [++] commute. *)

Lemma zip_app:
  forall A B C (f : A -> B -> C) xs1 xs2 ys1 ys2,
  length xs1 = length xs2 ->
  length ys1 = length ys2 ->
  zip f (xs1 ++ ys1) (xs2 ++ ys2) =
  zip f xs1 xs2 ++ zip f ys1 ys2.
Proof.
  induction xs1; destruct xs2; simpl; intros;
  solve [ false; omega | eauto with f_equal].
Qed.

(* [zip] applied to [nil] is [nil]. *)

Lemma zip_nil_right:
  forall A B C (f : A -> B -> C) xs,
  zip f xs nil = nil.
Proof.
  destruct xs; reflexivity.
Qed.

(* ------------------------------------------------------------------------- *)

(* The predicate [growth P Q xs ys] means that [xs] ``has grown'' into [ys].
   More precisely, the list [ys] is potentially longer than the list [xs].
   At indices that exist in both lists, the elements of [xs] and [ys] are
   related by [P]. At indices that exist only in the list [ys], the elements
   satisfy [Q]. *)

Inductive growth A B (P : A -> B -> Prop) (Q : B -> Prop) : list A -> list B -> Prop :=
| GrowthZero:
    forall ys,
    Forall Q ys ->
    growth P Q nil ys
| GrowthSucc:
    forall x xs y ys,
    P x y ->
    growth P Q xs ys ->
    growth P Q (x :: xs) (y :: ys).

(* ------------------------------------------------------------------------- *)

(* If [P] is reflexive, then [growth P Q] is reflexive. *)

Lemma growth_reflexive:
  forall A (P : A -> A -> Prop) (Q : A -> Prop),
  (forall x, P x x) ->
  forall xs,
  growth P Q xs xs.
Proof.
  induction xs; econstructor; eauto.
Qed.

(* If [xs] grows to [ys], and if [x] is the [n]-th element of [xs], then [ys]
   has an [n]-th element [y] which is related to [x] by [P]. *)

Lemma growth_is_nth:
  forall A B (P : A -> B -> Prop) (Q : B -> Prop) xs ys,
  growth P Q xs ys ->
  forall n x,
  is_nth n xs x ->
  exists y,
  is_nth n ys y /\ P x y.
Proof.
  induction 1; dependent_destruction; subst.
  repeat econstructor; eauto.
  forwards: IHgrowth; [ eauto | unpack ].
  repeat econstructor; eauto.
Qed.

Lemma growth_is_nth_reverse:
  forall A B (P : A -> B -> Prop) (Q : B -> Prop) xs ys,
  growth P Q xs ys ->
  forall n y,
  is_nth n ys y ->
  (exists x, is_nth n xs x /\ P x y) \/ Q y.
Proof.
  dependent_induction.
  right. eapply is_nth_Forall; eauto.
  dependent_destruction.
  left. repeat econstructor; eauto.
  forwards h: IHhdi. eauto. destruct h; unpack.
  left. repeat econstructor; eauto.
  right. eauto.
Qed.

Lemma growth_set_nth:
  forall A (P : A -> A -> Prop) (Q : A -> Prop) n xs x1 x2,
  (forall x, P x x) ->
  is_nth n xs x1 ->
  P x1 x2 ->
  growth P Q xs (set_nth n xs x2).
Proof.
  induction 2; simpl; econstructor; eauto using growth_reflexive.
Qed.

Lemma growth_set_nth_set_nth:
  forall A (P : A -> A -> Prop) (Q : A -> Prop) n xs d x y,
  is_nth n xs d ->
  forall ys,
  growth P Q xs ys ->
  P x y ->
  growth P Q (set_nth n xs x) (set_nth n ys y).
Proof.
  induction 1; inversion 1; intros; subst; simpl; econstructor; eauto.
  (* I don't even know what I am doing *)
Qed.

Lemma growth_apply_nth_apply_nth:
  forall A (P : A -> A -> Prop) (Q : A -> Prop) n xs d f,
  (forall x y, P x y -> P (f x) (f y)) ->
  is_nth n xs d ->
  forall ys,
  growth P Q xs ys ->
  growth P Q (apply_nth n xs f) (apply_nth n ys f).
Proof.
  induction 2; inversion 1; intros; subst; simpl; econstructor; eauto.
  (* I don't even know what I am doing, but I am really happy. *)
Qed.

(* If [P] is reflexive and if every element of [ys] satisfies [Q], then [xs]
   can grow to [xs ++ ys]. *)

Lemma growth_app:
  forall A (P : A -> A -> Prop) (Q : A -> Prop),
  (forall x, P x x) ->
  forall xs ys,
  Forall Q ys ->
  growth P Q xs (xs ++ ys).
Proof.
  induction xs; intros; simpl; econstructor; eauto.
Qed.

Lemma growth_length:
  forall A (P : A -> A -> Prop) (Q : A -> Prop) xs ys,
  growth P Q xs ys ->
  length xs <= length ys.
Proof.
  induction 1; simpl; eauto with omega.
Qed.

Lemma growth_map_map:
  forall (A B A' B' : Type) (P : A -> B -> Prop) (P' : A' -> B' -> Prop) Q Q' f g xs ys,
  (forall x y, P x y -> P' (f x) (g y)) ->
  (forall ys, Forall Q ys -> Forall Q' (map g ys)) ->
  growth P Q xs ys ->
  growth P' Q' (map f xs) (map g ys).
Proof.
  induction 3; simpl; econstructor; eauto.
Qed.

(* ---------------------------------------------------------------------------- *)

(* This handy tactic does a lot of useful work in the presence of lists. *)

Ltac my_list_cleanup :=
  injections;
  simpl in *;
  try discriminate;
  match goal with
    (* simplify cons-cons goal *)
  | |- _ :: _ = _ :: _ =>
      f_equal; my_list_cleanup
    (* simplify Forall-cons hypothesis *)
  | h: Forall _ (_ :: _) |- _ =>
      inversion h; clear h; my_list_cleanup
    (* simplify length-nil hypothesis *)
  | h: 0 = length ?xs |- _ =>
      destruct xs; [ clear h | false ]; my_list_cleanup
  | h: length ?xs = 0 |- _ =>
      destruct xs; [ clear h | false ]; my_list_cleanup
    (* simplify length-cons hypothesis *)
  | h: S _ = length ?xs |- _ =>
      destruct xs; [ false | ]; my_list_cleanup
  | h: length ?xs = S _ |- _ =>
      destruct xs; [ false | ]; my_list_cleanup
    (* simplify is-nth-nil hypothesis *)
  | h: is_nth _ nil _ |- _ =>
      inversion h; clear h; my_list_cleanup
    (* simplify is-nth-cons hypothesis *)
  | h: is_nth _ (_ :: _) _ |- _ =>
      inversion h; clear h; my_list_cleanup
    (* simplify nil-equal-zip or cons-equal-zip hypothesis *)
  | h: nil = zip _ ?xs ?ys |- _ =>
      destruct xs; destruct ys; simpl in h; try solve [ discriminate ]; my_list_cleanup
  | h: zip _ ?xs ?ys = nil |- _ =>
      destruct xs; destruct ys; simpl in h; try solve [ discriminate ]; my_list_cleanup
  | h: _ :: _ = zip _ ?xs ?ys |- _ =>
      destruct xs; destruct ys; simpl in h; try solve [ discriminate ]; my_list_cleanup
  | h: zip _ ?xs ?ys = _ :: _ |- _ =>
      destruct xs; destruct ys; simpl in h; try solve [ discriminate ]; my_list_cleanup
  | _ =>
      idtac
  end.

(* ---------------------------------------------------------------------------- *)

(* This tactic finds all lists in the hypotheses and performs induction on one
   of them and destruction on the others. *)

Ltac induction_lists :=
  repeat match goal with xs: list _ |- _ => generalize dependent xs end;
  intro xs; induction xs;
  repeat match goal with |- forall xs: list _, _ => intro ys; destruct ys end;
  intros; my_list_cleanup.