Require Import List ssreflect.
Require Import Equations.Prop.Equations.
Import ListNotations.

Equations ok_clause (e : nat -> option bool) (xs : list nat) : bool :=
  ok_clause e xs => ok_clause' e xs
    where
      ok_clause' (p : nat -> option bool) (l : list nat) : bool by struct l :=
      ok_clause' _ [] => true;
      ok_clause' p (x::l) with p x =>
      { | Some _ => ok_clause' p l;
        | _ => false }.

Lemma ok_clause_test p : ok_clause p [] = true.
Proof.
  now simp ok_clause.
Qed.

Lemma ok_clause_test' p cl : ok_clause p cl = false -> exists y, In y cl /\ p y = None.
Proof.
  apply (ok_clause_elim (fun e xs call => call = false -> exists y, In y xs /\ e y = None)
    (fun _ _ e xs call => call = false -> exists y, In y xs /\ e y = None)).
  all:try solve [cbn; try discriminate; firstorder eauto].
Qed.


Require Export ZArith.
Require Export Coq.Lists.List.
Require Export Coq.Strings.String.
Require Export Program.
Require Export FMapWeakList.
Require Export FSetWeakList.
Require Export Coq.FSets.FMapInterface.
Require Import Cfuzzi.Tactics.CpdtTactics.

Inductive tau :=
| t_int
| t_bool
| t_arr : tau -> tau
| t_bag : tau -> tau.

Fixpoint tau_denote (t : tau) : Set :=
  match t with
  | t_int => Z
  | t_bool => bool
  | t_arr t => list (tau_denote t)
  | t_bag t => list (tau_denote t)
  end.

Lemma tau_eqdec: forall (t t' : tau), {t = t'} + {t <> t'}.
Proof.
  decide equality.
Defined.

Fixpoint tau_denote_eqdec (t : tau) : forall (x y : tau_denote t), {x = y} + {x <> y} :=
  match t with
  | t_int => Z.eq_dec
  | t_bool => Bool.bool_dec
  | t_arr t => List.list_eq_dec (tau_denote_eqdec t)
  | t_bag t => List.list_eq_dec (tau_denote_eqdec t)
  end.

Definition tau_denote_eqb {t : tau} : tau_denote t -> tau_denote t -> bool :=
  fun x y => if tau_denote_eqdec t x y then true else false.

Inductive val :=
| v_int : Z -> val
| v_bool : bool -> val
| v_arr : tau -> val_arr -> val
| v_bag : tau -> val_arr -> val
with
val_arr :=
| v_nil : val_arr
| v_cons : val -> val_arr -> val_arr.

Scheme val_ind_mut := Induction for val Sort Type
  with val_arr_ind_mut := Induction for val_arr Sort Type.

Lemma val_eqdec: forall v v' : val, {v = v'} + {v <> v'}.
Proof.
  apply (val_ind_mut
           (fun v => forall v', {v = v'} + {v <> v'})
           (fun vs => forall vs', {vs = vs'} + {vs <> vs'})
        ).
  - intros z; destruct v'; auto.
    + destruct (Z.eq_dec z z0); subst; auto.
      right; intros contra; inversion contra; subst; apply n; auto.
    + right; intros contra; inversion contra.
    + right; intros contra; inversion contra.
    + right; intros contra; inversion contra.
  - intros b; destruct v'; auto.
    + right; intros contra; inversion contra.
    + destruct (bool_dec b b0); subst; auto.
      right; intros contra; inversion contra; subst; exfalso; apply n; auto.
    + right; intros contra; inversion contra.
    + right; intros contra; inversion contra.
  - intros t vs IH; destruct v'; auto.
    + right; intros contra; inversion contra.
    + right; intros contra; inversion contra.
    + destruct (IH v); destruct (tau_eqdec t t0); subst; auto.
      * right; intros contra; inversion contra; subst; exfalso; apply n; auto.
      * right; intros contra; inversion contra; subst; exfalso; apply n; auto.
      * right; intros contra; inversion contra; subst; exfalso; apply n; auto.
    + right; intros contra; inversion contra.
  - intros t vs IH; destruct v'; auto.
    + right; intros contra; inversion contra.
    + right; intros contra; inversion contra.
    + right; intros contra; inversion contra.
    + destruct (IH v); destruct (tau_eqdec t t0); subst; auto.
      * right; intros contra; inversion contra; subst; exfalso; apply n; auto.
      * right; intros contra; inversion contra; subst; exfalso; apply n; auto.
      * right; intros contra; inversion contra; subst; exfalso; apply n; auto.
  - intros vs'; destruct vs'; auto.
    right; intros contra; inversion contra.
  - intros v1 IH1 vs1 IH2 vs2.
    destruct vs2; auto.
    + right; intros contra; inversion contra.
    + destruct (IH1 v); destruct (IH2 vs2); subst; auto.
      * right; intros contra; inversion contra; subst; apply n; auto.
      * right; intros contra; inversion contra; subst; apply n; auto.
      * right; intros contra; inversion contra; subst; apply n; auto.
Defined.

Definition tau_default_val (t : tau) :=
  match t with
  | t_int => v_int 0%Z
  | t_bool => v_bool false
  | t_arr t => v_arr t v_nil
  | t_bag t => v_bag t v_nil
  end.

Fixpoint val_arr_index_nat (vs : val_arr) (idx : nat) : option val :=
  match vs, idx with
  | v_nil, _ => None
  | v_cons v _, O => Some v
  | v_cons v vs, S n' => val_arr_index_nat vs n'
  end.

Definition val_arr_index (vs : val_arr) (idx : Z) :=
  match idx with
  | Z0 => val_arr_index_nat vs O
  | Zpos p => val_arr_index_nat vs (Pos.to_nat p)
  | Zneg _ => None
  end.

Fixpoint val_arr_length_nat (vs : val_arr) : nat :=
  match vs with
  | v_nil => O
  | v_cons v vs => S (val_arr_length_nat vs)
  end.

Definition val_arr_length (vs : val_arr) := Z.of_nat (val_arr_length_nat vs).

Lemma val_arr_index_nat_last:
  forall n vs, val_arr_length_nat vs = S n
          -> exists v, val_arr_index_nat vs n = Some v.
Proof.
  intros n vs.
  generalize dependent n.
  induction vs.
  - intros n Hn.
    simpl in Hn.
    inversion Hn.
  - intros n Hn.
    simpl in Hn.
    inversion Hn.
    destruct n eqn:Hn2.
    + rewrite H0. simpl. exists v; auto.
    + destruct (IHvs n0 H0) as [v' Hv'].
      exists v'. simpl.
      rewrite H0.
      auto.
Qed.

Lemma val_arr_index_nat_cons:
  forall n vs v hd, val_arr_index_nat vs n = Some v
               -> exists v', val_arr_index_nat (v_cons hd vs) n = Some v'.
Proof.
  intros n.
  induction n.
  - intros vs v hd.
    intros Hv.
    exists hd. simpl. auto.
  - intros vs v hd.
    intros Hv.
    simpl.
    destruct vs eqn:Hvs.
    + simpl in Hv. inversion Hv.
    + simpl in Hv.
      apply IHn with (v := v); auto.
Qed.

Lemma val_arr_index_nat_range:
  forall idx vs, idx < val_arr_length_nat vs
            -> exists v, val_arr_index_nat vs idx = Some v.
Proof.
  intros idx vs.
  generalize dependent idx.
  induction vs.
  - intros idx Hidx.
    simpl in *.
    inversion Hidx.
  - intros idx Hidx.
    simpl in Hidx.
    inversion Hidx.
    + destruct (val_arr_index_nat_last idx (v_cons v vs)) as [v' Hv'].
      simpl. auto.
      exists v'. rewrite <- H0.
      auto.
    + subst.
      destruct (IHvs idx) as [v' Hv']; auto.
      apply val_arr_index_nat_cons with (v := v'); auto.
Qed.

Lemma val_arr_index_range:
  forall idx vs, (0 <= idx < val_arr_length vs)%Z
            -> exists v, val_arr_index vs idx = Some v.
Proof.
  intros idx vs Hrange.
  destruct Hrange as [Hrange1 Hrange2].
  apply Z_of_nat_complete in Hrange1.
  destruct Hrange1 as [idx_n Hrange1].
  rewrite Hrange1 in Hrange2.
  unfold val_arr_length in Hrange2.
  rewrite <- Nat2Z.inj_lt in Hrange2.
  destruct vs eqn:Hvs.
  - simpl in Hrange2. inversion Hrange2.
  - destruct idx.
    + exists v. auto.
    + unfold val_arr_index.
      apply val_arr_index_nat_range.
      assert (Pos.to_nat p = idx_n).
      {
        destruct idx_n.
        - simpl in *. inversion Hrange1.
        - simpl in Hrange1. inversion Hrange1; subst.
          rewrite SuccNat2Pos.id_succ. auto.
      }
      subst.
      auto.
    + destruct idx_n; simpl in *; inversion Hrange1.
Qed.

Fixpoint val_arr_subarr_nat (vs: val_arr) (len: nat) : option val_arr :=
  match vs, len with
  | _, O => Some v_nil
  | v_cons v vs, S n =>
    match val_arr_subarr_nat vs n with
    | Some vs' => Some (v_cons v vs')
    | None => None
    end
  | v_nil, S _ => None
  end.

Fixpoint val_arr_subarr (vs: val_arr) (len: Z) : option val_arr :=
  match len with
  | Z0 => val_arr_subarr_nat vs O
  | Zpos p => val_arr_subarr_nat vs (Pos.to_nat p)
  | Zneg _ => None
  end.

Lemma val_arr_subarr0: forall vs,
    val_arr_subarr vs 0 = Some v_nil.
Proof.
  intros vs.
  destruct vs; auto.
Qed.

Fixpoint val_arr_to_list (vs : val_arr) : list val :=
  match vs with
  | v_nil => []
  | v_cons v vs => v :: val_arr_to_list vs
  end.

Fixpoint val_arr_from_list (vs : list val) : val_arr :=
  match vs with
  | [] => v_nil
  | v :: vs => v_cons v (val_arr_from_list vs)
  end.

Fixpoint val_arr_update_nat (vs: val_arr) (idx: nat) (v: val) : option val_arr :=
  match vs, idx with
  | v_nil, _ => None
  | v_cons _ vs, O => Some (v_cons v vs)
  | v_cons hd vs, S n =>
    match val_arr_update_nat vs n v with
    | None => None
    | Some vs' => Some (v_cons hd vs')
    end
  end.

Fixpoint val_arr_update (vs: val_arr) (idx: Z) (v: val) : option val_arr :=
  match idx with
  | Z0 => val_arr_update_nat vs O v
  | Zpos idx => val_arr_update_nat vs (Pos.to_nat idx) v
  | Zneg _ => None
  end.

Lemma val_arr_update_nat_last:
  forall n vs v, val_arr_length_nat vs = S n
            -> exists vs', val_arr_update_nat vs n v = Some vs'.
Proof.
  intros n vs.
  generalize dependent n.
  induction vs.
  - intros n v Hv. simpl in Hv.
    inversion Hv.
  - intros n v' Hv'. simpl in Hv'.
    inversion Hv'.
    destruct n.
    + rewrite H0.
      simpl. exists (v_cons v' vs). auto.
    + destruct (IHvs n v') as [vs' Hvs']; auto.
      exists (v_cons v vs'); simpl. rewrite H0. rewrite Hvs'. auto.
Qed.

Lemma val_arr_update_nat_range:
  forall idx vs v, idx < val_arr_length_nat vs
           -> exists vs', val_arr_update_nat vs idx v = Some vs'.
Proof.
  (* TODO *)
Admitted.

Lemma val_arr_update_range:
  forall idx vs v,
    (0 <= idx < val_arr_length vs)%Z
    -> exists vs', val_arr_update vs idx v = Some vs'.
Proof.
  intros idx vs v [Hrange1 Hrange2].
  apply Z_of_nat_complete in Hrange1.
  destruct Hrange1 as [n Hrange1].
  unfold val_arr_length in Hrange2.
  rewrite Hrange1 in Hrange2.
  rewrite <- Nat2Z.inj_lt in Hrange2.
  destruct vs eqn:Hvs.
  - simpl in Hrange2. inversion Hrange2.
  - destruct idx.
    + eexists; reflexivity.
    + unfold val_arr_update.
      apply val_arr_update_nat_range.
      assert (Pos.to_nat p = n).
      {
        destruct n.
        - simpl in *. inversion Hrange1.
        - simpl in Hrange1. inversion Hrange1; subst.
          rewrite SuccNat2Pos.id_succ. auto.
      }
      subst.
      auto.
    + destruct n; simpl in *; inversion Hrange1.
Qed.

Lemma val_arr_update_length_same:
  forall idx vs v vs',
    val_arr_update vs idx v = Some vs'
    -> val_arr_length vs = val_arr_length vs'.
Proof.
  Admitted.

Lemma val_arr_update_index_same:
  forall idx vs v vs',
    val_arr_update vs idx v = Some vs'
    -> val_arr_index vs' idx = Some v.
Proof.
  Admitted.

(* The val_arr_subarr function uses the second argument as the length of the
   subarray starting from position 0, so updating the array would not change the
   subarray at up to length idx.

   This should really be a special case of a more
   general lemma that says updates at any idx >= the length of the subarr will
   not change the subarr
*)
Lemma val_arr_subarr_update:
  forall vs idx v vs',
    val_arr_update vs idx v = Some vs'
    -> val_arr_subarr vs' idx = val_arr_subarr vs idx.
Proof.
Admitted.

Lemma val_arr_subarr_range:
  forall vs len,
    (0 <= len <= val_arr_length vs)%Z
    -> exists vs', val_arr_subarr vs len = Some vs'.
Proof.
Admitted.

Fixpoint val_arr_update_length_nat (t : tau) (vs: val_arr) (len: nat): val_arr :=
  match vs, len with
  | _, O => v_nil
  | v_cons v vs, S n =>
    v_cons v (val_arr_update_length_nat t vs n)
  | v_nil, n =>
    val_arr_from_list (repeat (tau_default_val t) n)
  end.

Definition val_arr_update_length (t : tau) (vs : val_arr) (len: Z): option val_arr :=
  match len with
  | Z0 => Some (val_arr_update_length_nat t vs O)
  | Zpos len => Some (val_arr_update_length_nat t vs (Pos.to_nat len))
  | Zneg _ => None
  end.

Fixpoint val_arr_map (f: val -> val) (vs: val_arr) :=
  match vs with
  | v_nil => v_nil
  | v_cons x xs => v_cons (f x) (val_arr_map f xs)
  end.

Fixpoint val_arr_map_option (f: val -> option val) (vs: val_arr) :=
  match vs with
  | v_nil => Some v_nil
  | v_cons x xs =>
    match f x, val_arr_map_option f xs with
    | Some v, Some vs => Some (v_cons v vs)
    | _, _ => None
    end
  end.

Lemma val_arr_length_positive: forall vs len,
    val_arr_length vs = len
    -> (0 <= len)%Z.
Proof.
  intros vs len Hlen.
  unfold val_arr_length in Hlen.
  rewrite <- Hlen.
  omega.
Qed.

Lemma val_arr_update_length_pos: forall t vs len,
    (0 <= len)%Z
    -> exists vs', val_arr_update_length t vs len = Some vs'.
Proof.
  intros t vs len Hlen_pos.
  assert (Z0 = len \/ exists len_pos, Zpos len_pos = len).
  {
    destruct len eqn:Hlen.
    left; auto.
    right. exists p; auto.
    exfalso. apply Hlen_pos. auto.
  }
  destruct H.
  - subst. exists v_nil.
    destruct vs; auto.
  - destruct H as [len_pos Hlen_pos2].
    unfold val_arr_update_length.
    exists (val_arr_update_length_nat t vs (Pos.to_nat len_pos)).
    subst.
    auto.
Qed.

Lemma val_arr_length_from_list:
  forall l, val_arr_length_nat (val_arr_from_list l) = List.length l.
Proof.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl; auto.
Qed.

Lemma val_arr_update_length_nat_correct: forall t vs vs' len,
    val_arr_update_length_nat t vs len = vs'
    -> val_arr_length_nat vs' = len.
Proof.
  intros t vs vs' len Hlen.
  generalize dependent len.
  generalize dependent vs'.
  induction vs.
  - intros vs' len Hlen.
    simpl in Hlen.
    destruct len.
    + subst. auto.
    + subst. rewrite val_arr_length_from_list.
      simpl. f_equal.
      rewrite repeat_length.
      auto.
  - intros vs' len Hlen.
    simpl in Hlen.
    destruct len.
    + subst. auto.
    + subst. simpl.
      f_equal.
      remember (val_arr_update_length_nat t vs len) as vs'.
      apply IHvs; auto.
Qed.

Lemma val_arr_update_length_correct: forall t vs vs' len,
    val_arr_update_length t vs len = Some vs'
    -> val_arr_length vs' = len.
Proof.
  intros t vs vs' len Hlen.
  unfold val_arr_update_length in Hlen.
  unfold val_arr_length.
  destruct len.
  - inversion Hlen. erewrite val_arr_update_length_nat_correct; eauto.
    reflexivity.
  - inversion Hlen. erewrite val_arr_update_length_nat_correct; eauto.
    rewrite positive_nat_Z; auto.
  - inversion Hlen.
Qed.

Hint Resolve val_arr_length_positive.
Hint Resolve val_arr_update_length_pos.
Hint Resolve val_arr_update_length_correct.

Definition var := string.

Module StringDec <: DecidableType.
  Definition t := string.
  Definition eq : t -> t -> Prop := fun x y => x = y.
  Lemma eq_refl : forall x : t, x = x.
  Proof. auto. Qed.
  Lemma eq_sym : forall x y : t, x = y -> y = x.
  Proof. auto. Qed.
  Lemma eq_trans : forall x y z : t, x = y -> y = z -> x = z.
  Proof. intros x y z H; rewrite H; auto. Qed.
  Definition eq_dec := string_dec.
End StringDec.

Definition var_eqdec := StringDec.eq_dec.

Module VarMap := FMapWeakList.Make(StringDec).
Module VarSet := FSetWeakList.Make(StringDec).

Definition VarMap_includes_compute
           {T} (eq: T -> T -> bool) (m1 m2:VarMap.t T) :=
  VarMap.fold (fun x v is_equal =>
                 match VarMap.find x m2 with
                 | Some v2 => is_equal && (eq v v2)
                 | _ => false
                 end
              ) m1 true.

Definition varmap_from_list {A: Type} (xs: list (var * A)%type) : VarMap.t A :=
  List.fold_right (fun xa m => VarMap.add (fst xa) (snd xa) m) (@VarMap.empty A) xs.

Lemma VarMap_Equal_dec : forall {T}
                           (H: forall x1 x2: T, {x1 = x2} + {x1 <> x2})
                           (m1 m2: VarMap.t T),
    {VarMap.Equal m1 m2} + {~(VarMap.Equal m1 m2)}.
Proof.
  intros T Heq_dec m1 m2.
  (* Not easy to prove, we might need to use Arthur's extensional data structure library *)
Admitted.

Lemma VarMap_Equal_Refl : forall {T} (m : VarMap.t T),
    VarMap.Equal m m.
Proof.
  intros T m.
  unfold VarMap.Equal.
  reflexivity.
Qed.

Lemma VarMap_Equal_Sym : forall {T} (m1 m2 : VarMap.t T),
    VarMap.Equal m1 m2 -> VarMap.Equal m2 m1.
Proof.
  intros T m1 m2.
  unfold VarMap.Equal.
  auto.
Qed.

Lemma VarMap_Equal_Trans : forall {T} (m1 m2 m3 : VarMap.t T),
    VarMap.Equal m1 m2 -> VarMap.Equal m2 m3 -> VarMap.Equal m1 m3.
Proof.
  intros T m1 m2 m3.
  unfold VarMap.Equal.
  intros H1 H2.
  intros y.
  rewrite H1.
  auto.
Qed.

Add Parametric Relation T : (VarMap.t T) (@VarMap.Equal T)
    reflexivity proved by VarMap_Equal_Refl
    symmetry proved by VarMap_Equal_Sym
    transitivity proved by VarMap_Equal_Trans
      as VarMap_Equal_Equiv.

Coercion v_int : Z >-> val.
Coercion v_bool : bool >-> val.

Definition str_to_var : string -> var := fun x => x.
Coercion str_to_var : string >-> var.

Lemma VarMap_MapsTo_Uniq: forall {T} m x (v1 v2 : T),
    VarMap.MapsTo x v1 m -> VarMap.MapsTo x v2 m
    -> v1 = v2.
Proof.
  intros T m x v1 v2.
  intros Hv1.
  intros Hv2.
  apply VarMap.find_1 in Hv1.
  apply VarMap.find_1 in Hv2.
  rewrite Hv1 in Hv2.
  inversion Hv2; subst; auto.
Qed.

Lemma VarMap_MapsTo_remove_False: forall {T} m x (v:T),
    ~(VarMap.MapsTo x v (VarMap.remove x m)).
Proof.
  intros T m x v Hxv.
  assert (H_not_In: ~VarMap.In x (VarMap.remove x m)).
  { apply VarMap.remove_1; auto. }
  unfold VarMap.MapsTo in *. unfold VarMap.In in *.
  unfold VarMap.Raw.PX.MapsTo in *.
  unfold VarMap.Raw.PX.In in *.
  apply H_not_In.
  exists v; auto.
Qed.

Lemma VarMap_remove_same: forall {T} (m : VarMap.t T) x,
    VarMap.find x m = None
    -> VarMap.Equal (VarMap.remove x m) m.
Proof.
  intros T m x Hfind.
  unfold VarMap.Equal.
  intros y.
  destruct (StringDec.eq_dec x y).
  - subst. rewrite Hfind.
    assert (forall v, ~(VarMap.MapsTo y v (VarMap.remove y m))).
    { apply VarMap_MapsTo_remove_False; auto. }
    destruct (VarMap.find y (VarMap.remove y m)) eqn:Hy; auto.
    apply VarMap.find_2 in Hy.
    apply H in Hy. inversion Hy.
  - destruct (VarMap.find y m) eqn:Hy.
    * apply VarMap.find_2 in Hy.
      apply VarMap.find_1.
      apply VarMap.remove_2; auto.
    * destruct (VarMap.find y (VarMap.remove x m)) eqn:Hyx; auto.
      apply VarMap.find_2 in Hyx.
      apply VarMap.remove_3 in Hyx.
      apply VarMap.find_1 in Hyx.
      rewrite Hyx in Hy.
      auto.
Qed.

Lemma VarMap_remove_None: forall {T} (m: VarMap.t T) x,
    VarMap.find x m = None
    -> VarMap.find x (VarMap.remove x m) = None.
Proof.
  intros T m x Hfind.
  rewrite VarMap_remove_same; auto.
Qed.

Hint Resolve VarMap_MapsTo_Uniq.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** This small module is imported in all our files, it exports useful
   modules and defines some basic utilities and tactics *)

Require Export Arith.
Require Export Omega.
Require Export Coq.Program.Equality.
Require Export Setoid Morphisms.

Set Implicit Arguments.

Bind Scope nat_scope with nat.

(** Functional composition *)
Definition comp A B C (f: A -> B) (g: B -> C) := fun x => g (f x).
Notation "f >> g" := (comp f g) (at level 50).

(** This lemma is useful when applied in hypotyheses ([apply apply in H] makes it possible to specialize
   an hypothesis [H] by generating the corresponding subgoals) *)
Definition apply X x Y (f: X -> Y) := f x.

(** Tactics to resolve a goal by using a contradiction in the hypotheses, using either [omega] or [tauto] *)
Ltac omega_false := exfalso; omega.
Ltac tauto_false := exfalso; tauto.

(** This destructor sometimes works better that the standard [destruct] *)
Ltac idestruct H :=
  let H' := fresh in generalize H; intro H'; destruct H'.

(** For debugging *)
Ltac print_goal := match goal with |- ?x => idtac x end.

(** This tactic allows one to infere maximally implicit arguments that failed to be inferred and were
   replaced by sub-goals *)
Ltac ti_auto := eauto with typeclass_instances.

(** The following databases are used all along the library:
   - <compat> contains most "compatibility with equality" and "monotonicity" lemmas: Morphisms with respects to
   [Classes.equal] and [Classes.leq] ; it is useful to solve simple goals like [x <== y |- x*f x <== y*f y],
   and to obtain new morphisms. These morphism are always called [f_compat] and [f_incr], where [f] is the
   name of the compatible or monotone function.
   - <algebra> contains simple algebraic lemmas like [0 <== x], [1 <== x#],
   and [x <== z -> y <== z -> x+y <== z],
   that seem to be appropriate for [(e)auto] proof search.
   - <simpl> is a rewriting database, to be used with the [rsimpl] tactic. It contains lemmas like [1*x == x]
   [0# == 1] and provides a simple way to normalise the goal "in depth", using the setoid infrastructure.
   This is not really efficient, however.
   - <omega> contains hints to use [omega] when proof search failed ; this basically allows us to avoid
   using [omega] in trivial cases.
*)
Create HintDb compat discriminated.
Create HintDb algebra discriminated.

Ltac rsimpl := simpl; autorewrite with simpl using ti_auto.

Hint Extern 9 (@eq nat ?x ?y) => instantiate; abstract omega: omega.
Hint Extern 9 (Peano.le ?x ?y) => instantiate; abstract omega: omega.
Hint Extern 9 (Peano.lt ?x ?y) => instantiate; abstract omega: omega.

(** Tactic to use when apply does not smartly unify *)
Ltac rapply H := first
  [ refine H
  | refine (H _)
  | refine (H _ _)
  | refine (H _ _ _)
  | refine (H _ _ _ _)
  | refine (H _ _ _ _ _)
  | refine (H _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _ _ _)
  | refine (H _ _ _ _ _ _ _ _ _ _ _ _)
  | fail 1 "extend rapply"
  ].


Require Export DeclarationTyping.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
  | abs _ _   => True
  | tabs _ _  => True
  | rec tr    => RValue tr
  | _         => False
  end
with RValue (tr : Rec) : Prop :=
  match tr with
  | rcons _ t tr => Value t /\ RValue tr
  | rnil         => True
  end.

Inductive Match : Pat → Tm → Tm → Tm → Prop :=
  | M_Var {T v t} :
      Match (pvar T) v t (substTm X0 v t)
  | M_Rcd {pr vr t t'} :
      RMatch pr vr t t' →
      Match (prec pr) (rec vr) t t'
with RMatch : PRec → Rec → Tm → Tm → Prop :=
  | RM_Nil {vr t} :
      RMatch pnil vr t t
  | RM_Cons {l p pr} {vr: Rec} {v t t' t''} (vIn: vr l = Some v) :
      RMatch (weakenPRec pr (bindPat p)) (weakenRec vr (bindPat p)) t t' →
      Match p v t' t'' →
      RMatch (pcons l p pr) vr t t''.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (FSubRcd.app (abs T11 t12) t2) (substTm X0 t2 t12)
  | tapptabs {T11 T2 t12} :
      red (tapp (tabs T11 t12) T2) (tsubstTm X0 T2 t12)
  | appfun {t1 t1' t2} :
      red t1 t1' → red (FSubRcd.app t1 t2) (FSubRcd.app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (FSubRcd.app t1 t2) (FSubRcd.app t1 t2')
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tapp t1 T2) (tapp t1' T2)
  | E_Rec {tr tr'} :
      rred tr tr' → red (rec tr) (rec tr')
  | E_Let {p t1 t1' t2} :
      red t1 t1' → red (lett p t1 t2) (lett p t1' t2)
  | E_LetV {p t1 t2 t2'} :
      Value t1 → Match p t1 t2 t2' → red (lett p t1 t2) t2'
  | E_Proj {t t' l} :
      red t t' →
      red (prj t l) (prj t' l)
  | E_ProjRcd {tr t l} :
      RValue tr → tr l = Some t →
      red (prj (rec tr) l) t
with rred : Rec → Rec → Prop :=
  | rred_here {l t t' tr} :
      red t t' → rred (rcons l t tr) (rcons l t' tr)
  | rred_there {l t tr tr'} :
      Value t → rred tr tr' → rred (rcons l t tr) (rcons l t tr').


(** 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.

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


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.
Require Import NPeano.
Require Import NZPow.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import cfl.
Require Import pumping.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* PUMPING LEMMA EXAMPLE                                                 *)
(* --------------------------------------------------------------------- *)

Section Pumping_Square.

Inductive terminal: Type:=
| a.

Definition square: lang terminal:=
fun (s: list terminal) =>
exists i: nat,
length s = i*i.

Fixpoint build (k: nat): list terminal:=
match k with
| 0 => []
| S k => a :: build k
end.

Lemma build_length:
forall k: nat,
length (build k) = k.
Proof.
induction k.
- simpl.
  reflexivity.
- simpl.
  rewrite IHk.
  reflexivity.
Qed.

Lemma not_square:
forall n i: nat,
n > i*i ->
n < (i+1)*(i+1) ->
~ exists j: nat,
  n = j*j.
Proof.
intros n i H1 H2 H3.
destruct H3 as [j H3].
rewrite H3 in H1, H2.
clear H3.
destruct j.
- simpl in H1.
  apply lt_n_0 in H1.
  contradiction.
- rewrite <- Nat.pow_2_r in H1.
  rewrite <- Nat.pow_2_r in H1.
  apply Nat.pow_lt_mono_l_iff in H1.
  + assert (H3: i<=j) by omega.
    clear H1.
    replace (S j) with (j+1) in H2.
    * rewrite <- Nat.pow_2_r in H2.
      rewrite <- Nat.pow_2_r in H2.
      {
      apply Nat.pow_lt_mono_l_iff in H2.
      - assert (H4: j<i) by omega.
        clear H2.
        omega.
      - auto.
      }
    * omega.
  + auto.
Qed.

Lemma square_plus_not_square:
forall i j k,
j>=1 ->
j<=i ->
~ i*i+j=k*k.
Proof.
intros i j k H1 H2 H3.
assert (H4: i*i+j > i*i) by omega.
assert (H5: i*i+j < (i+1)*(i+1)).
  {
  replace ((i + 1) * (i + 1)) with (S i * S i).
  - simpl.
    rewrite <- mult_n_Sm.
    omega.
  - replace (S i) with (i+1).
    + reflexivity.
    + omega.
  }
apply not_square in H4.
- apply H4.
  exists k.
  exact H3.
- exact H5.
Qed.

Lemma sentence_exists:
forall n: nat,
exists w: list terminal,
length w = n*n /\ square w.
Proof.
destruct n.
- exists [].
  split.
  + simpl.
    reflexivity.
  + unfold square.
    exists 0.
    simpl.
    reflexivity.
- exists (build (n*n+n+n+1)).
  split.
  + rewrite build_length.
    apply prod_eq.
  + unfold square.
    exists (S n).
    rewrite build_length.
    apply prod_eq.
Qed.

Lemma not_cfl_square: ~ cfl square.
Proof.
intros H1.
assert (H2: contains_empty square).
  {
  unfold contains_empty.
  unfold square.
  exists 0.
  simpl.
  reflexivity.
  }
assert (H3: contains_non_empty square).
  {
  unfold contains_non_empty.
  exists [a].
  unfold square.
  split.
  - exists 1.
    simpl.
    reflexivity.
  - intros H3.
    inversion H3.
  }
apply pumping_lemma in H1.
- destruct H1 as [n H1].
  assert (H4: exists (s: list terminal), (length s = n*n) /\ square s).
    {
    apply sentence_exists.
    }
  destruct H4 as [s [H4 H5]].
  assert (H98: n*n >= n).
    {
    apply mult_ge.
    }
  assert (H6: length s >= n) by omega.
  specialize (H1 s H5 H6).
  destruct H1 as [u [v [w [x [y [H11 [H12 [H13 [H14 H15]]]]]]]]].
  clear H2 H3 H6 H98.
  specialize (H15 2).
  simpl in H15.
  repeat rewrite app_nil_r in H15.
  unfold square in H15.
  rewrite H11 in H4.
  destruct H15 as [i H15].
  repeat rewrite app_length in H15.
  repeat rewrite app_length in H4.
  replace (length u + (length v + length v + (length w + (length x + length x + length y)))) with
          ((length u + length v + length w + length x + length y) + length v + length x) in H15.
  + replace (length u + length v + length w + length x + length y + length v + length x) with
            (length u + (length v + (length w + (length x + length y))) + (length v + length x)) in H15.
    * rewrite H4 in H15.
      clear H4.
      {
      replace (length v + length x) with (length (v++x)) in H15.
      - apply square_plus_not_square in H15.
        + contradiction.
        + exact H12.
        + rewrite app_length.
          repeat rewrite app_length in H14.
          omega.
      - rewrite app_length.
        reflexivity.
      }
    * omega.
  + omega.
- split.
  + left.
    exact H2.
  + left.
    exact H3.
Qed.

End Pumping_Square.


Require Import XR_Rsqr.
Require Import XR_plus_le_is_le.
Require Import XR_Rle_0_sqr.
Require Import XR_Rsqr_neg_pos_le_0.
Require Import XR_Rsqr_incr_0_var.

Local Open Scope R_scope.

Lemma triangle_rectangle :
  forall x y z:R,
    R0 <= z -> Rsqr x + Rsqr y <= Rsqr z -> - z <= x <= z /\ - z <= y <= z.
Proof.
  intros x y z hz h.

  assert (hxz : Rsqr x <= Rsqr z).
  {
    apply plus_le_is_le with (Rsqr y).
    { apply Rle_0_sqr. }
    { exact h. }
  }

  assert (hyz : Rsqr y <= Rsqr z).
  {
    apply plus_le_is_le with (Rsqr x).
    { apply Rle_0_sqr. }
    {
      rewrite Rplus_comm.
      exact h.
    }
  }

  split.
  {
    split.
    {
      apply Rsqr_neg_pos_le_0.
      { exact hxz. }
      { exact hz. }
    }
    {
      apply Rsqr_incr_0_var.
      { exact hxz. }
      { exact hz. }
    }
  }
  {
    split.
    {
      apply Rsqr_neg_pos_le_0.
      { exact hyz. }
      { exact hz. }
    }
    {
      apply Rsqr_incr_0_var.
      { exact hyz. }
      { exact hz. }
    }
  }
Qed.


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

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

    References:

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

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

Section Paradox.

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

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

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

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

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

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

End Paradox.


Require Import Coq.Lists.List.
Import ListNotations.
(* Heterogeneous lists *)
(***********************)
Section hlist.
(* Heterogeneous lists are lists where the elements of the
 * list can have different types. In Coq, we can define
 * heterogeneous lists by indexing an inductive type by
 * a list of types, one for each element. For convenience
 * in the future however, we will index our type by an
 * a type [iT] and a function (F) that computes a type from
 * [iT]. This will make our definition a little bit easier
 * to use in the next exercise.
 *)
Variable iT : Type.
Variable F : iT -> Type.

Inductive hlist : list iT -> Type :=
| Hnil : hlist nil
| Hcons : forall {T Ts}, F T -> hlist Ts -> hlist (T :: Ts).

(* Exercise: Implement the head and tail functions for hlists.
 *)
Definition hlist_hd {T Ts} (h : hlist (T :: Ts)) : F T :=
  match h with
  | Hcons x _ => x
  | Hnil => tt
  end.

Definition hlist_tl {T Ts} (h : hlist (T :: Ts)) : hlist Ts :=
  match h with
  | Hcons _ xs => xs
  | Hnil => tt
  end.

(* An alternative solution is to build an inductive
 * type that carries the information about the value that
 * we find at a particular location in the list.
 *)
Inductive mem {T : Type} (t : T) : list T -> Type :=
| MO : forall {ts}, mem t (t :: ts)
| MS : forall {t' ts}, mem t ts -> mem t (t' :: ts).

Arguments MO {_ _ _}.
Arguments MS {_ _ _ _} _.

(* Exercise: Implement hlist_nth with the following type.
 *)
Fixpoint hlist_nth {T Ts} (h : hlist Ts) (n : mem T Ts) : F T :=
  match n in mem _ Ts return hlist Ts -> F T with
  | MO => hlist_hd
  | MS m => fun h => hlist_nth (hlist_tl h) m
  end h.

End hlist.

Arguments hlist {_} _ _.
Arguments hlist_hd {_ _ _ _} _.
Arguments hlist_tl {_ _ _ _} _.
Arguments hlist_nth {_ _ _ _} _ _.
Arguments Hnil {_ _}.
Arguments Hcons {_ _ _ _} _ _.

Arguments MO {_ _ _}.
Arguments MS {_ _ _ _} _.

Section mem_dec.
  Variable T : Type.
  (* In order to implement decidable equality for [mem], we
   * need decidable equality for the type T. The reason for
   * this is a little bit unintuitive but it turns out to be
   * true.
   *)
  Variable T_dec : forall a b : T, a = b \/ a <> b.

  Lemma MS_inj : forall t t' ts (m m' : mem t ts),
      @MS T t t' ts m = MS m' ->
      m = m'.
  Proof.
    intros.
    refine
      match H in _ = M
            return match M in mem _ ts return mem _ (tl ts) -> Prop with
                   | MO => fun _ => True
                   | MS m'' => fun m => m = m''
                   end m
      with
      | eq_refl => eq_refl
      end.
  Defined.

  (* A theorem in Coq tells us that decidable equality on
   * a type [T] implies proof irrelevence for proofs of equality
   * of values of type [T].
   *)
  Require Import Coq.Logic.Eqdep_dec.

  Fixpoint mem_dec {ts : list T} {t : T} (a : mem t ts)
  : forall b : mem t ts, {a = b} + {a <> b}.
  refine
    match a as a in mem _ ts
          return forall b : mem t ts, {a = b} + {a <> b}
    with
    | MO => fun b =>
      match b as b in mem _ ts
            return match ts as ts return mem t ts -> Type with
                   | nil => fun _ => unit
                   | t' :: ts => fun b =>
                                   forall pf : t' = t,
                                     {MO = match pf with
                                           | eq_refl => b
                                           end} +
                                     {MO <> match pf with
                                            | eq_refl => b
                                            end}
                   end b
      with
      | MO => fun _ => left _
      | MS m'' => fun _ => right _
      end eq_refl
    | @MS _ _ t' ts' m' => fun (b : mem t (t' :: ts')) =>
      match b as b in mem _ ts
            return forall m' : mem t (tl ts),
          (forall b, {m' = b} + {m' <> b}) ->
          match ts as ts return mem t ts -> mem t (tl ts) -> Type with
          | nil => fun _ _ => unit
          | t'' :: ts'' => fun (b : mem t (t'' :: ts'')) m' =>
                             {MS m' = b} +
                             {MS m' <> b}
          end b m'
      with
      | MO => fun _ _ => right _
      | MS m'' => fun _ rec =>
                        match rec m'' with
                        | left _ => left _
                        | right _ => right _
                        end
      end m' (fun b => mem_dec _ _ m' b)
    end.
  Proof.
  { eapply K_dec with (p := e); auto. }
  { subst. intro. inversion H. }
  { clear. red; intro. inversion H. }
  { f_equal. assumption. }
  { clear - n. intro. apply n.
    eapply MS_inj in H. assumption. }
  Defined.
End mem_dec.

Arguments mem_dec {_} _ {_ _} _ _.

(* A simple Lambda-calculus *)
(****************************)

(* We can use dependent types to describe "well-typed" terms.
 * We start with a type of types.
 *)
Inductive type : Type :=
| Nat
| Bool
| Arr (d c : type)
.

(* I've started a simple definition with just constants, addition
 * and variables.
 *)
Inductive expr (ts : list type) : type -> Type :=
| ConstNat  : nat -> expr ts Nat
| Plus      : expr ts Nat -> expr ts Nat -> expr ts Nat
| ConstBool : bool -> expr ts Bool
| If        : forall t, expr ts Bool -> expr ts t -> expr ts t -> expr ts t
| App       : forall d c, expr ts (Arr d c) -> expr ts d -> expr ts c
| Abs       : forall d c, expr (d :: ts) c -> expr ts (Arr d c)
| Var       : forall {t}, mem t ts -> expr ts t
| PlusE     : expr ts (Arr Nat (Arr Nat Nat)).

Arguments ConstNat {_} _.
Arguments Plus {_} _ _.
Arguments ConstBool {_} _.
Arguments If {_ _} _ _ _.
Arguments App {_ _ _} _ _.
Arguments Abs {_ _ _} _.
Arguments Var {_ _} _.
Arguments PlusE {_}.

(* We can now write functions that map the syntactic definitions
 * into semantic ones.
 *)
Fixpoint typeD (t : type) : Type :=
  match t with
  | Nat => nat
  | Bool => bool
  | Arr l r => typeD l -> typeD r
  end.

Fixpoint exprD {ts : list type} {t : type} (e : expr ts t)
: hlist typeD ts -> typeD t :=
  match e in expr _ t return hlist typeD ts -> typeD t with
  | ConstNat n => fun _ => n
  | Plus a b => let aD := exprD a in let bD := exprD b in
                fun env => aD env + bD env
  | ConstBool b => fun _ => b
  | If t tr fa => let tD := exprD t in
                    let trD := exprD tr in
                    let faD := exprD fa in
                    fun env =>
                      if tD env then trD env else faD env
  | App f x => let fD := exprD f in
                   let xD := exprD x in
                   fun env => (fD env) (xD env)
  | Abs body => let bodyD := exprD body in
                    fun env => (fun x => bodyD (Hcons x env))
  | Var v => fun e => hlist_nth e v
  | PlusE => fun e => plus
  end.

Eval simpl in exprD (ConstNat 3) Hnil.
Eval simpl in exprD (Plus (ConstNat 3) (ConstNat 6)) Hnil.
Eval simpl in fun x : typeD Nat =>
                  exprD (Plus (Var MO) (ConstNat 6)) (Hcons x Hnil).

(* Exercise: Implement semi-decidable equality for this type.
 * (We can implement decidable equality, but it is a bit annoying
 *  due to constructing proofs of disequality.)
 * Avoid using tactics except to construct values whose type is
 * in Prop, i.e. only use tactics to prove equalities and
 * disequalities.
 *)
Definition type_dec (t1 t2 : type) : {t1 = t2} + {t1 <> t2}.
decide equality.
Defined.

Definition nat_dec : forall a b : nat, {a = b} + {a <> b}.
decide equality.
Defined.

Definition bool_dec : forall a b : bool, {a = b} + {a <> b}.
decide equality.
Defined.

Definition type_decidable (t1 t2 : type) : (t1 = t2) \/ (t1 <> t2) :=
  match type_dec t1 t2 with
  | left pf => or_introl pf
  | right pf => or_intror pf
  end.

Definition domain (t : type) : type :=
  match t with
  | Arr a _ => a
  | _ => t
  end.

Definition codomain (t : type) : type :=
  match t with
  | Arr _ b => b
  | _ => t
  end.

Definition expr_match_Nat {ts}
           (P : expr ts Nat -> Type)
           (doConst : forall n, P (ConstNat n))
           (doPlus : forall a b, P (Plus a b))
           (doIf : forall t tr fa, P (If t tr fa))
           (doApp : forall d' f x, P (@App ts d' Nat f x))
           (doVar : forall m, P (Var m))
: forall e : expr ts Nat, P e.
refine (fun e =>
  match e as e in expr _ X
        return match X as X return expr ts X -> Type with
               | Nat => fun e =>
                 forall (doConst : forall n, P (ConstNat n))
                        (doPlus : forall a b, P (Plus a b))
                        (doIf : forall t tr fa, P (If t tr fa))
                        (doApp : forall d' f x, P (@App ts d' Nat f x))
                        (doVar : forall m, P (Var m)),
                   P e
               | _ => fun _ => unit
               end e
  with
  | ConstNat n => fun doConst _ _ _ _ => doConst n
  | _ => _
  end doConst doPlus doIf doApp doVar);
  try solve [ intros; exact tt
            | eauto
            | destruct t; try exact tt; eauto
            | destruct t0; try exact tt; eauto ].
Defined.

Definition expr_match_Bool {ts}
           (P : expr ts Bool -> Type)
           (doConst : forall b, P (ConstBool b))
           (doIf : forall t tr fa, P (If t tr fa))
           (doApp : forall d' f x, P (@App ts d' Bool f x))
           (doVar : forall m, P (Var m))
: forall e : expr ts Bool, P e.
refine (fun e =>
  match e as e in expr _ X
        return match X as X return expr ts X -> Type with
               | Bool => fun e =>
                 forall (doConst : forall n, P (ConstBool n))
                        (doIf : forall t tr fa, P (If t tr fa))
                        (doApp : forall d' f x, P (@App ts d' Bool f x))
                        (doVar : forall m, P (Var m)),
                   P e
               | _ => fun _ => unit
               end e
  with
  | ConstBool n => fun doConst _ _ _ => doConst n
  | _ => _
  end doConst doIf doApp doVar);
  try solve [ intros; exact tt
            | eauto
            | destruct t; try exact tt; eauto
            | destruct t0; try exact tt; eauto ].
Defined.

Definition expr_match_Arr {ts} {d c : type}
           (P : forall d c, expr ts (Arr d c) -> Type)
           (doIf : forall t tr fa, @P d c (If t tr fa))
           (doApp : forall d' f x, @P d c (@App ts d' (Arr d c) f x))
           (doAbs : forall body, P d c (Abs body))
           (doVar : forall m, P d c (Var m))
           (doPlusE : P Nat (Arr Nat Nat) PlusE)
: forall e : expr ts (Arr d c), P d c e.
refine (fun e =>
  match e as e in expr _ X
        return
          match X as X return expr ts X -> Type with
          | Arr d c => fun e =>
            forall (doIf : forall t tr fa, @P d c (If t tr fa))
                   (doApp : forall d' f x, @P d c (@App ts d' (Arr d c) f x))
                   (doAbs : forall body, P d c (Abs body))
                   (doVar : forall m, P d c (Var m))
                   (doPlusE : P Nat (Arr Nat Nat) PlusE), P d c e
          | _ => fun _ => unit
          end e
  with
  | ConstNat _ => tt
  | ConstBool _ => tt
  | Plus _ _ => tt
  | If t tr fa => _
  | _ => _
  end doIf doApp doAbs doVar doPlusE);
  try solve [ intros; exact tt
            | eauto
            | destruct t0; try exact tt; auto
            | destruct t; try exact tt; eauto ].
Defined.

Definition expr_match_Arr' {ts} {d c : type}
           (P : forall d c, expr ts (Arr d c) -> Type)
           (doIf : forall t tr fa, @P d c (If t tr fa))
           (doApp : forall d' f x, @P d c (@App ts d' (Arr d c) f x))
           (doAbs : forall body, P d c (Abs body))
           (doVar : forall m, P d c (Var m))
           (doPlusE : P Nat (Arr Nat Nat) PlusE)
: forall e : expr ts (Arr d c), P d c e.
refine (fun e =>
  match e as e in expr _ X
        return
        forall (doIf : match X return Type with
                       | Arr d c => forall t tr fa, @P d c (If t tr fa)
                       | _ => unit
                       end)
               (doApp : match X return Type with
                        | Arr d c => forall d' f x, @P d c (@App ts d' (Arr d c) f x)
                        | _ => unit
                        end)
               (doAbs : match X return Type with
                        | Arr d c => forall body, P d c (Abs body)
                        | _ => unit
                        end)
               (doVar : match X return Type with
                        | Arr d c => forall m, P d c (Var m)
                        | _ => unit
                        end)
               (doPlusE : P Nat (Arr Nat Nat) PlusE),
          match X as X return expr ts X -> Type with
          | Arr d c => fun e => P d c e
          | _ => fun _ => unit
          end e
  with
  | ConstNat _ => _
  | ConstBool _ => _
  | Plus _ _ => _
  | If t tr fa => _
  | _ => _
  end doIf doApp doAbs doVar doPlusE);
  try solve [ intros; exact tt
            | eauto
            | destruct t0; try exact tt; eauto
            | destruct t; try exact tt; eauto ].
Defined.

Fixpoint expr_dec {ts t} (e1 : expr ts t)
: forall e2 : expr ts t, option (e1 = e2).
refine
  match e1 as e1 in expr _ t
        return forall e2 : expr ts t, option (e1 = e2)
  with
  | ConstNat n => fun e2 =>
    match e2 as e2 in expr _ t
          return option (match t as t return expr ts t -> Prop with
                         | Nat => fun e2 => ConstNat n = e2
                         | _ => fun _ => False
                         end e2) with
    | ConstNat m =>
      match nat_dec n m with
      | left pf => Some match pf with
                        | eq_refl => eq_refl
                        end
      | right _ => None
      end
    | _ => None
    end
  | Plus l r => fun e2 =>
    match e2 as e2 in expr _ t
          return forall a b : expr ts Nat,
        option (match t as t return expr ts t -> Prop with
                | Nat => fun e2 => Plus a b = e2
                | _ => fun _ => False
                end e2)
    with
    | Plus l' r' => fun l r =>
      match expr_dec _ _ l l' , expr_dec _ _ r r' with
      | Some pf1 , Some pf2 => Some match pf1 , pf2 with
                                    | eq_refl , eq_refl => eq_refl
                                    end
      | _ , _ => None
      end
    | _ => fun _ _ => None
    end l r
  | ConstBool b => fun e2 =>
    match e2 as e2 in expr _ t
          return option (match t as t return expr ts t -> Prop with
                         | Bool => fun e2 => ConstBool b = e2
                         | _ => fun _ => False
                         end e2)
    with
    | ConstBool m =>
      match bool_dec b m with
      | left pf => Some match pf with
                        | eq_refl => eq_refl
                        end
      | right _ => None
      end
    | _ => None
    end
  | If t tr fa => fun e2 =>
    match e2 as e2 in expr _ T
          return forall (t : expr ts Bool) (tr fa : expr ts T),
        option (If t tr fa = e2)
    with
    | If t' tr' fa' => fun t tr fa =>
      match expr_dec _ _ t t'
          , expr_dec _ _ tr tr'
          , expr_dec _ _ fa fa'
      with
      | Some pf , Some pf' , Some pf'' =>
        Some match pf , pf' , pf'' with
             | eq_refl , eq_refl , eq_refl => eq_refl
             end
      | _ , _ , _ => None
      end
    | _ => fun _ _ _ => None
    end t tr fa
  | @App _ d c f x => fun e2 =>
    match e2 as e2 in expr _ t
          return forall (f : expr ts (Arr d t))
                        (x : expr ts d)
                        (rec_f : forall e, option (f = e))
                        (rec_x : forall e, option (x = e)),
        option (App f x = e2)
    with
    | @App _ d' c' f' x' =>
      match type_dec d' d with
      | right _ => fun _ _ _ _ => None
      | left pf =>
        match pf in _ = X
              return forall f' x'
                            (f : expr ts (Arr X c'))
                            (x : expr ts X)
                            (rec_f : forall e, option (f = e))
                            (rec_x : forall e, option (x = e)),
            option (App f x = App f' x')
        with
        | eq_refl => fun f' x' _ _ rec_f rec_x =>
                       match rec_f f' , rec_x x' with
                       | Some pf , Some pf' =>
                         Some match pf , pf' with
                              | eq_refl , eq_refl => eq_refl
                              end
                       | _ , _ => None
                       end
        end f' x'
      end
    | _ => fun _ _ _ _ => None
    end f x (fun y => expr_dec _ _ f y) (fun y => expr_dec _ _ x y)
  | @Abs _ d c body => fun e2 =>
    match e2 as e2 in expr _ t
          return forall (body : expr (domain t :: ts) (codomain t))
                        (rec : forall e, option (body = e)),
        option (match t as t
                      return expr (domain t :: ts) (codomain t) -> expr ts t -> Prop
                with
                | Arr d' c' => fun body e2 => Abs body = e2
                | _ => fun _ _ => False
                end body e2)
    with
    | @Abs _ d' c' body' => fun _ rec =>
                           match rec body' with
                           | None => None
                           | Some pf => Some match pf with
                                             | eq_refl => eq_refl
                                             end
                           end
    | _ => fun _ _ => None
    end body (fun y => expr_dec _ _ body y)
  | Var v => fun e2 =>
    match e2 as e2 in expr _ t
          return forall v : mem t ts, option (Var v = e2)
    with
    | Var v' => fun v =>
      match mem_dec type_decidable v v' with
      | left pf => Some match pf in _ = X with
                        | eq_refl => eq_refl
                        end
      | right _ => None
      end
    | _ => fun _ => None
    end v
  | PlusE => fun e2 : expr ts (Arr Nat (Arr Nat Nat)) =>
    match e2 as e2 in expr _ t
          return option (match t as t return expr ts t -> Prop with
                         | Arr Nat (Arr Nat Nat) => fun e2 => PlusE = e2
                         | _ => fun _ => False
                         end e2)
    with
    | PlusE => Some eq_refl
    | _ => None
    end
  end.
Defined.

Fixpoint expr_dec' {ts t} (e1 : expr ts t)
: forall e2 : expr ts t, option (e1 = e2).
refine
  match e1 as e1 in expr _ t
        return forall e2 : expr ts t, option (e1 = e2)
  with
  | ConstNat n =>
    expr_match_Nat (fun e2 => option (ConstNat n = e2))
                   (fun m =>
                      match nat_dec n m with
                      | left pf => Some match pf with
                                        | eq_refl => eq_refl
                                        end
                      | right _ => None
                      end)
                   (fun _ _ => None)
                   (fun _ _ _ => None)
                   (fun _ _ _ => None)
                   (fun _ => None)
  | Plus l r =>
    expr_match_Nat (fun e2 => option (Plus l r = e2))
                   (fun _ => None)
                   (fun l' r' =>
                      match expr_dec' _ _ l l' , expr_dec' _ _ r r' with
                      | Some pf1 , Some pf2 =>
                        Some match pf1 , pf2 with
                             | eq_refl , eq_refl => eq_refl
                             end
                      | _ , _ => None
                      end)
                   (fun _ _ _ => None)
                   (fun _ _ _ => None)
                   (fun _ => None)
  | ConstBool b =>
    expr_match_Bool (fun e2 => option (ConstBool b = e2))
                    (fun b' =>
                       match bool_dec b b' with
                       | left pf => Some match pf with
                                         | eq_refl => eq_refl
                                         end
                       | right _ => None
                       end)
                    (fun _ _ _ => None)
                    (fun _ _ _ => None)
                    (fun _ => None)
  | If t tr fa => fun e2 =>
    match e2 as e2 in expr _ T
          return forall (t : expr ts Bool) (tr fa : expr ts T),
        option (If t tr fa = e2)
    with
    | If t' tr' fa' => fun t tr fa =>
      match expr_dec' _ _ t t'
          , expr_dec' _ _ tr tr'
          , expr_dec' _ _ fa fa'
      with
      | Some pf , Some pf' , Some pf'' =>
        Some match pf , pf' , pf'' with
             | eq_refl , eq_refl , eq_refl => eq_refl
             end
      | _ , _ , _ => None
      end
    | _ => fun _ _ _ => None
    end t tr fa
  | @App _ d c f x => _
  | @Abs _ d c body => fun e2 =>
    expr_match_Arr (fun d c e2 => forall body,
                        (forall e, option (body = e)) ->
                        option (Abs body = e2))
                   (fun _ _ _ _ _ => None)
                   (fun _ _ _ _ _ => None)
                   (fun body' _ rec_body =>
                      match rec_body body' with
                      | Some pf => Some match pf with
                                        | eq_refl => eq_refl
                                        end
                      | None => None
                      end)
                   (fun _ _ _ => None)
                   (fun _ _ => None)
                   e2 body (fun e => expr_dec' _ _ body e)
  | Var v => fun e2 =>
    match e2 as e2 in expr _ t
          return forall v : mem t ts, option (Var v = e2)
    with
    | Var v' => fun v =>
      match mem_dec type_decidable v v' with
      | left pf => Some match pf in _ = X with
                        | eq_refl => eq_refl
                        end
      | right _ => None
      end
    | _ => fun _ => None
    end v
  | PlusE =>
    expr_match_Arr (fun d c e => option (PlusE = e))
                   _ _ _ _ _
  end.

Defined.

(* Exercise: Implement a function that simplifies expressions.
 *)
Definition reduce1 {ts t} (e : expr ts t) : expr ts t :=
  match e in expr _ t return expr ts t -> expr ts t with
  | Plus (ConstNat x) (ConstNat y) => fun _ => ConstNat (x + y)
  | App Nat Nat (App Nat (Arr Nat Nat) PlusE (ConstNat x)) (ConstNat y) =>
    fun _ => ConstNat (x + y)
  | If _ (ConstBool true) tr _ => fun _ => tr
  | If _ (ConstBool false) _ fa => fun _ => fa
  | If _ t tr fa => fun e =>
    if expr_dec tr fa then tr else e
  | _ => fun x => x
  end e.

Lemma if_same : forall T (x : bool) (a : T),
    (if x then a else a) = a.
Proof. destruct x; reflexivity. Qed.

Lemma expr_case_Arr : forall d c ts (e : expr ts (Arr d c)),
    (exists body, e = Abs body) \/
    (exists test tr fa, e = If test tr fa) \/
    (exists d' f x, e = @App ts d' (Arr d c) f x) \/
    (exists m, e = Var m) \/
    (exists (pf : Nat = d) (pf' : Arr Nat Nat = c),
        e = match pf , pf' with
            | eq_refl , eq_refl => PlusE
            end).
Proof.
  intros.
  refine
    match e as e in expr _ t
          return match t as t return expr ts t -> Prop with
                 | Arr d c => fun e =>
                                (exists body : expr (d :: ts) c, e = Abs body) \/
                                (exists (test : expr ts Bool) (tr fa : expr ts (Arr d c)),
                                    e = If test tr fa) \/
                                (exists (d' : type) (f : expr ts (Arr d' (Arr d c)))
                                        (x : expr ts d'), e = App f x) \/
                                (exists m : mem (Arr d c) ts, e = Var m) \/
                                (exists (pf : Nat = d) (pf' : Arr Nat Nat = c),
                                    e =
                                    match pf in (_ = t) return (expr ts (Arr t c)) with
                                    | eq_refl =>
                                      match pf' in (_ = t) return (expr ts (Arr Nat t)) with
                                      | eq_refl => PlusE
                                      end
                                    end)
                 | _ => fun _ => True
                 end e
    with
    | ConstNat _ => I
    | Plus _ _ => I
    | ConstBool _ => I
    | _ => _
    end.
  { destruct t; eauto 10. }
  { destruct c0; eauto 10. }
  { eauto. }
  { destruct t; eauto 10. }
  { repeat right. exists eq_refl. exists eq_refl. reflexivity. }
Qed.

Theorem reduce1_sound : forall ts t (e : expr ts t),
    forall env, exprD (reduce1 e) env = exprD e env.
Proof.
  destruct e; simpl; auto.
  { refine
      match e1 as e1 in expr _ X1
          , e2 as e2 in expr _ X2
            return match X1 as X1 , X2 as X2
                         return expr ts X1 -> expr ts X2 -> Prop
                   with
                   | Nat , Nat => fun e1 e2 =>
                                    forall env : hlist typeD ts,
                                      exprD
                                        (match e1 with
                                         | ConstNat a =>
                                           match e2 with
                                           | ConstNat b => fun _ : expr ts Nat => ConstNat (a + b)
                                           | _ => fun e' : expr ts Nat => e'
                                           end
                                         | _ => fun e' : expr ts Nat => e'
                                         end (Plus e1 e2)) env =
                                      exprD e1 env + exprD e2 env
                   | _ , _ => fun _ _ => True
                   end e1 e2
      with
      | ConstNat _ , ConstNat _ => fun _ => eq_refl
      | _ , _ => _
      end; try solve [ reflexivity | destruct t; reflexivity ].
    destruct c; trivial. destruct c; trivial. }
  { refine
      match e1 as e1 in expr _ X1
            return match X1 as X1 return expr ts X1 -> Prop with
                   | Bool => fun e1 => forall env : hlist typeD ts,
                       exprD
                         (match e1 with
                          | ConstNat _ => fun e : expr ts t => if expr_dec e2 e3 then e2 else e
                          | Plus _ _ => fun e4 : expr ts t => if expr_dec e2 e3 then e2 else e4
                          | ConstBool true => fun _ : expr ts t => e2
                          | ConstBool false => fun _ : expr ts t => e3
                          | If _ _ _ _ => fun e5 : expr ts t => if expr_dec e2 e3 then e2 else e5
                          | App _ _ _ _ => fun e : expr ts t => if expr_dec e2 e3 then e2 else e
                          | Abs _ _ _ => fun e : expr ts t => if expr_dec e2 e3 then e2 else e
                          | Var _ _ => fun e : expr ts t => if expr_dec e2 e3 then e2 else e
                          | PlusE => fun e : expr ts t => if expr_dec e2 e3 then e2 else e
                          end (If e1 e2 e3)) env =
                       (if exprD e1 env then exprD e2 env else exprD e3 env)
                   | _ => fun _ => True
                   end e1
      with
      | ConstBool true => fun _ => eq_refl
      | ConstBool false => fun _ => eq_refl
      | ConstNat _ => I
      | Plus _ _ => I
      | Abs _ _ _ => I
      | _ => _
      end;
    repeat (match goal with
            | |- match ?X with _ => _ end _ => destruct X
            end; trivial; simpl; intros);
    destruct (expr_dec e2 e3); simpl; subst; try rewrite if_same; reflexivity. }
  { (* This case is a little bit ugly due to the deep pattern matching.
     * A more modular optimization approach simplifies this case substantially.
     *)
    specialize (expr_case_Arr _ _ _ e1); intros;
    repeat match goal with
           | H : _ \/ _ |- _ => destruct H
           | H : exists x, _ |- _ => destruct H
           end; subst; try solve [ simpl; auto | destruct c; auto ].
    { destruct d; auto. destruct c; auto. }
    { destruct d; auto. destruct c; auto. }
    { specialize (expr_case_Arr _ _ _ x0); intros;
      repeat match goal with
             | H : _ \/ _ |- _ => destruct H
             | H : exists x, _ |- _ => destruct H
             end; subst; simpl.
      { destruct d; auto. destruct c; auto. destruct x; auto. }
      { destruct d; auto. destruct c; auto. destruct x; auto. }
      { destruct d; auto. destruct c; auto. destruct x; auto. }
      { destruct d; auto. destruct c; auto. destruct x; auto. }
      { inversion x3. subst.
        eapply K_dec with (p:=x3). eapply type_decidable.
        simpl. clear.
        refine
          match x1 as e1 in expr _ X1
                            , e2 as e2 in expr _ X2
                return match X1 as X1 , X2 as X2
                             return expr ts X1 -> expr ts X2 -> Prop
                       with
                       | Nat , Nat => fun e1 e2 =>
                         exprD
                           (match e1 with
                            | ConstNat a =>
                              match e2 with
                              | ConstNat b => fun _ : expr ts Nat => ConstNat (a + b)
                              | _ => fun e' : expr ts Nat => e'
                              end
                            | _ => fun e' : expr ts Nat => e'
                            end (App (App PlusE e1) e2)) env =
                         exprD e1 env + exprD e2 env
                       | _ , _ => fun _ _ => True
                       end e1 e2
          with
          | ConstNat _ , ConstNat _ => _
          | _ , _ => _
          end; try solve [ reflexivity | destruct c ; auto | destruct t; auto ]. } }
    { destruct d; auto. destruct c; auto. } }
Qed.

Fixpoint simplify {ts t} (e : expr ts t) : expr ts t :=
  reduce1
    match e in expr _ t return expr ts t with
    | ConstNat n => ConstNat n
    | Plus a b => Plus (simplify a) (simplify b)
    | ConstBool b => ConstBool b
    | If _ a b c => If (simplify a) (simplify b) (simplify c)
    | App _ _ f x => App (simplify f) (simplify x)
    | Abs _ _ body => Abs (simplify body)
    | Var _ v => Var v
    | PlusE => PlusE
    end.

(* For example, you should optimize (1 + (2 + 3)) to 6. *)

Eval compute in simplify (ts:=[]) (Plus (ConstNat 1) (Plus (ConstNat 2) (ConstNat 3))).

(* Hint: It will be helpful to write a separate function that
 * performs simplification and use the simplify function to
 * apply this function recursively.
 *)

(* Exercise: The dependent types tell us that [simplify] preserves
 * typedness. Can you prove that it also preserves semantic meaning.
 *)
Theorem simplify_sound : forall ts t (e : expr ts t),
    forall env, exprD (simplify e) env = exprD e env.
Proof.
  Opaque reduce1.
  induction e; simpl; intros; auto; try rewrite reduce1_sound; simpl;
  repeat match goal with
         | H : _ |- _ => rewrite H
         end; try reflexivity.
  Require Coq.Logic.FunctionalExtensionality.
  apply FunctionalExtensionality.functional_extensionality.
  auto.
  Transparent reduce1.
Qed.

(* Exercise: Enrich the type language with booleans and the
 * expression language with boolean constants and if expressions.
 * Re-do all of the above functions/proofs.
 *
 * Note: expr_dec becomes a bit more complicated especially in the
 * constant cases.
 *
 * The simplifier should do simplifications of conditionals, i.e.
 *     [If (ConstBool true) tr fa] = [tr]
 *     [If (ConstBool false) tr fa] = [fa]
 *     [If test tr tr] = [tr]
 *)


(*|
####################################
Decide disjunctions in sort ``Prop``
####################################

:Link: https://stackoverflow.com/q/55952695
|*)

(*|
Question
********

I am interested in the probably false lemma:
|*)

Lemma decideOr : forall (P Q : Prop),
    (P \/ Q) -> {P} + {Q}.
Abort. (* .none *)

(*|
that asserts we can algorithmically decide any proof of an ``or`` in
sort ``Prop``. Of course, Coq does not let us ``destruct`` the input
to extract it in sort ``Set``. However, a proof of ``P \/ Q`` is a
lambda-term that Coq accepts to print, so external tools can process
it.

First question: can this lambda-term be decided outside of Coq
(assuming the term uses no axioms, only plain Coq)? It might be,
because the rules of constructive logic demand that all disjunctions
be explicitely chosen, without cheating by a proof by contradiction.
So can we code a parser of Coq proof terms, and try to decide whether
the first or the second operand of the ``or`` was proved? If the term
starts with ``or_introl`` or ``or_intror`` we are done. So I guess the
problems are when the term is a lambda-application. But then Coq terms
are strongly normalizing, so we reduce it to a normal form and it
seems it will start with either ``or_introl`` or ``or_intror``.

Second question: if this problem can be decided outside of Coq, what
prevents us from internalizing it within Coq, ie proving lemma
``decideOr`` above?
|*)

(*|
Answer
******

First question
==============

Yes, you can write a program that takes as input a Coq proof of ``A \/
B`` and outputs ``true`` or ``false`` depending on which side was used
to prove the disjunction. Indeed, if you write

.. code-block:: coq

    Compute P.

in Coq, where ``P : A \/ B``, Coq will normalize the proof ``P`` and
print which constructor was used. This will not work if ``P`` uses
proofs that end in ``Qed`` (because those are not unfolded by the
evaluator), but in principle it is possible to replace ``Qed`` by
``Defined`` everywhere and make it work.

Second question
===============

What prevents us from proving ``decideOr`` is that the designers of
Coq wanted to have a type of propositions that supports the excluded
middle (using an axiom) while allowing programs to execute. If
``decideOr`` were a theorem *and* we wanted to use the excluded middle
(``classical : forall A : Prop, A \/ ~ A``), it would not be possible
to execute programs that branch on the result of ``decideOr (classical
A)``. This does not mean that ``decideOr`` is false: it is perfectly
possible to admit it as an axiom. There is a difference between not
being provable ("there does not exist a proof of ``A``") and being
refutable ("there exists a proof of ``~ A``").
|*)


(* Software Foundations *)
(* Excercice 3 stars, list_exercises *)

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

Notation "[]" := nil.
Notation " x :: l" := (cons x l).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint append(l1 l2: natlist): natlist :=
match l1 with
|nil        => l2
|cons h1 t1 => h1 :: (append t1 l2)
end.

Notation "l1 ++ l2" := (append l1 l2).

Theorem app_nil_end: forall l: natlist, l ++ [] = l.
Proof.
    intros. induction l as [|h t].
    reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.

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.

Lemma rev_snoc: forall (l:natlist)(v: nat), rev (snoc l v) = v::rev(l).
Proof.
    intros. induction l as [|h t].
    reflexivity.
    simpl. rewrite IHt. simpl. reflexivity.
Qed.

Theorem rev_involutive: forall l: natlist, rev(rev l) = l.
Proof.
    intros. induction l as [|h t].
    reflexivity.
    simpl. rewrite rev_snoc. rewrite IHt. reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist, (l1 ++l2)++l3 =l1 ++(l2 ++l3).
Proof.
    intros. induction l1 as [|h t].
    reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++(l2 ++(l3 ++l4))=((l1 ++l2)++l3)++l4.
Proof.
    intros.
    rewrite app_assoc. induction l1 as [|h t].
    reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.

Theorem snoc_append: forall (l: natlist)(v: nat), snoc l v = l ++ [v].
Proof.
    intros. induction l as [|h t].
    reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.

Lemma snoc_app_two_list: forall (l1 l2: natlist)(v: nat), snoc(l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
    intros. induction l1 as [|h1 t1].
    reflexivity.
    simpl. rewrite IHt1. reflexivity.
Qed.

Theorem distr_rev : forall l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
    intros. induction l1 as [|h1 t1].
    simpl. rewrite app_nil_end. reflexivity.
    simpl. rewrite IHt1. rewrite snoc_app_two_list. reflexivity.
Qed.

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

Lemma nonzeros_app: forall l1 l2: natlist, nonzeros(l1++l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
    intros. induction l1 as [|h t].
    reflexivity.
    destruct h as [|h'].
    simpl. rewrite IHt. reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.