Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.MapCast.
Require Import Crypto.Reflection.Named.InterpretToPHOAS.
Require Import Crypto.Reflection.Named.Compile.
Require Import Crypto.Reflection.Named.PositiveContext.
Require Import Crypto.Reflection.Named.PositiveContext.Defaults.
Require Import Crypto.Reflection.Syntax.

(** N.B. This procedure only works when there are no nested lets,
    i.e., nothing like [let x := let y := z in w] in the PHOAS syntax
    tree.  This is a limitation of [compile]. *)

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (base_type_code_beq : base_type_code -> base_type_code -> bool)
          (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y)
          (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t))
          {interp_base_type_bounds : base_type_code -> Type}
          (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst)
          (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code).
  Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v).
  Context (cast_op : forall t tR (opc : op t tR) args_bs,
              op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))).

  Local Notation PContext var := (PositiveContext _ var _ base_type_code_bl_transparent).

  Section MapCast.
    Context {t} (e : Expr base_type_code op t)
            (input_bounds : interp_flat_type interp_base_type_bounds (domain t)).

    Definition MapCastCompile
      := compile (e _) (DefaultNamesFor e).
    Definition MapCastDoCast (e' : option (Named.expr base_type_code op BinNums.positive t))
      := option_map
           (fun e'' => map_cast
                         interp_op_bounds pick_typeb cast_op
                         (BoundsContext:=PContext _)
                         empty
                         e''
                         input_bounds)
           e'.
    Definition MapCastDoInterp
               (e' : option
                       (option
                          { output_bounds : interp_flat_type interp_base_type_bounds (codomain t) &
                                           Named.expr _ _ _ (Arrow (pick_type input_bounds) (pick_type output_bounds)) }))
      : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                                 & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
      := match e' with
         | Some (Some (existT output_bounds e''))
           => Some (existT _ output_bounds (InterpToPHOAS (Context:=fun var => PContext var) failb e''))
         | Some None | None => None
         end.
    Definition MapCast
      : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                                 & Expr base_type_code op (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
      := MapCastDoInterp (MapCastDoCast MapCastCompile).
  End MapCast.
End language.


(* lifted from https://github.com/arthuraa/coq-utils/blob/master/theories/string.v *)
From mathcomp Require Import
  ssreflect ssrfun ssrbool eqtype choice seq.

Require Import Coq.Strings.Ascii Coq.Strings.String.

Notation string := string.

Definition tuple_of_ascii c :=
  let: Ascii x1 x2 x3 x4 x5 x6 x7 x8 := c in
  (x1, x2, x3, x4, x5, x6, x7, x8).

Definition ascii_of_tuple t :=
  let: (x1, x2, x3, x4, x5, x6, x7, x8) := t in
  Ascii x1 x2 x3 x4 x5 x6 x7 x8.

Lemma tuple_of_asciiK : cancel tuple_of_ascii ascii_of_tuple.
Proof. by case. Qed.

Definition ascii_eqMixin := CanEqMixin tuple_of_asciiK.
Canonical ascii_eqType := Eval hnf in EqType ascii ascii_eqMixin.
Definition ascii_choiceMixin := CanChoiceMixin tuple_of_asciiK.
Canonical ascii_choiceType := Eval hnf in ChoiceType ascii ascii_choiceMixin.
Definition ascii_countMixin := CanCountMixin tuple_of_asciiK.
Canonical ascii_countType := Eval hnf in CountType ascii ascii_countMixin.

Fixpoint seq_of_string s :=
  if s is String c s' then c :: seq_of_string s'
  else [::].

Fixpoint string_of_seq s :=
  if s is c :: s' then String c (string_of_seq s')
  else EmptyString.

Lemma seq_of_stringK : cancel seq_of_string string_of_seq.
Proof. by elim=> [|c s /= ->]. Qed.

Definition string_eqMixin := CanEqMixin seq_of_stringK.
Canonical string_eqType := Eval hnf in EqType string string_eqMixin.
Definition string_choiceMixin := CanChoiceMixin seq_of_stringK.
Canonical string_choiceType :=
  Eval hnf in ChoiceType string string_choiceMixin.
Definition string_countMixin := CanCountMixin seq_of_stringK.
Canonical string_countType := Eval hnf in CountType string string_countMixin.


Require Import A1_Plan A2_Orientation A4_Droite A7_Tactics .
Require Import B7_Tactics .
Require Import D3_SecondDimension D5_Tactics .
Require Import E2_NotEquidirectedIntersection .
Require Import L6_Tactics .
Require Import M1_SuperImposedLines.

Unset Standard Proposition Elimination Names.

Section PARALLEL_LINES.

Lemma ParallelLinesRefl : forall d : Line,
	ParallelLines d d.
Proof.
	intro; simplLine1.
	immediate11.
Qed.

Lemma ParallelLinesSym : forall d1 d2 : Line,
	ParallelLines d1 d2 ->
	ParallelLines d2 d1.
Proof.
	intros; simplLine1.
	immediate11.
Qed.

Lemma EqParallelLine : forall d1 d2 : Line,
	EqLine d1 d2 ->
	ParallelLines d1 d2.
Proof.
	intros; inversion H.
	destruct (TwoPointsOnLineOrientation (LineA d2) (LineB d2) d1 H0 H1).
	 simplLine1; canonize1.
	 simplLine1; canonize1.
Qed.

Lemma ParallelEqParallelLine : forall d1 d2 d3 : Line,
	ParallelLines d1 d2 ->
	EqLine d2 d3 ->
	ParallelLines d1 d3.
Proof.
	intros.
	inversion H0.
	destruct (EqLineOrEquiOriented d2 d3 H0).
	 destruct d1; destruct d2; destruct d3; simplLine1; canonize1.
	  right; left; intros.
	    step11 H9.
	    step11 H.
	  do 3 right; left; intros.
	    step11 H9.
	    step11 H.
	  do 2 right; left; intros.
	    step11 H2.
	    step11 H5.
	  do 7 right; intros.
	    step11 H5.
	    step11 H2.
	 destruct d1; destruct d2; destruct d3; simplLine1; canonize1.
	  left; intros.
	    step11 H2.
	   canonize1.
	   step11 H.
	  do 2 right; left; intros.
	    step11 H2.
	   canonize1.
	   step11 H.
	  do 6 right; left; intros.
	    step11 H5.
	    step11 H2.
	    left; canonize1.
	  do 7 right; intros.
	    step11 H.
	    step11 H2.
	    left; canonize1.
Qed.

Lemma EqEqParallelLine : forall d1 d2 d3 d4: Line,
	EqLine d1 d3 ->
	EqLine d2 d4 ->
	ParallelLines d1 d2 ->
	ParallelLines d3 d4.
Proof.
	intros.
	apply (ParallelEqParallelLine d3 d2 d4).
	 apply ParallelLinesSym.
	   apply (ParallelEqParallelLine d2 d1 d3).
	  apply ParallelLinesSym; immediate11.
	  immediate11.
	 immediate11.
Qed.

Lemma ParallelEqLine : forall M : Point, forall d1 d2 : Line,
	OnLine d1 M ->
	OnLine d2 M ->
	ParallelLines d1 d2 ->
	EqLine d1 d2.
Proof.
	intros.
	destruct d2.
	byApartCases3 A B M.
	 assert (EqLine (Ruler A M H2) (Ruler A B n)).
	  apply EqLineDef; immediate11.
	  apply EqLineTrans with (d2 := Ruler A M H2).
	   assert (ParallelLines d1 (Ruler A M H2)).
	    apply ParallelEqParallelLine with (d2 := Ruler A B n).
	     immediate11.
	     apply EqLineSym; immediate11.
	    destruct d1.
	      by3Cases1 A0 B0 A.
	     assert (~ EquiDirected A0 B0 A M).
	      apply FourPointsSecantLine; immediate11.
	      simplLine1.
	        elim H6; immediate11.
	     assert (~ EquiDirected B0 A0 A M).
	      apply FourPointsSecantLine; immediate11.
	      simplLine1; elim H5; immediate11.
	     apply EqLineDef; immediate11.
	   immediate11.
	 assert (EqLine (Ruler B M H2) (Ruler A B n)).
	  apply EqLineDef; immediate11.
	  apply EqLineTrans with (d2 := Ruler B M H2).
	   assert (ParallelLines d1 (Ruler B M H2)).
	    apply ParallelEqParallelLine with (d2 := Ruler A B n).
	     immediate11.
	     apply EqLineSym; immediate11.
	    destruct d1.
	      by3Cases1 A0 B0 B.
	     assert (~ EquiDirected A0 B0 B M).
	      apply FourPointsSecantLine; immediate11.
	      simplLine1; elim H6; immediate11.
	     assert (~ EquiDirected B0 A0 B M).
	      apply FourPointsSecantLine; immediate11.
	      simplLine1; elim H5; immediate11.
	     apply EqLineDef; immediate11.
	   immediate11.
Qed.

Lemma ParallelLinesDistinctLines : forall d1 d2 : Line, forall A : Point,
	ParallelLines d1 d2 ->
	OnLine d1 A ->
	~OnLine d2 A ->
	forall M : Point, ~ (OnLine d1 M /\ OnLine d2 M).
Proof.
	intros.
	contrapose0 H1.
	destruct H1; assert (EqLine d1 d2).
	 apply (ParallelEqLine M d1 d2); immediate11.
	 apply (EqLineOnLine d1 d2 A); immediate11.
Qed.

End PARALLEL_LINES.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo10 : goal 10. Time solve_P. Time Qed.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : word 8 }.
Definition format (m : msg) := format_word m.(data).
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


Set Implicit Arguments.

Require Import Coq.Strings.String.

Inductive ADTScheme :=
| Primitive : string -> ADTScheme
| Product : ADTScheme -> ADTScheme -> ADTScheme.

Require Import Bedrock.Platform.AutoSep.

Record ADTEntry :=
  {
    Model : Type;
    RepInv : W -> Model -> HProp;
    RepInvGood : forall p a, RepInv p a ===> p =?> 1 * any
  }.

Require Import Bedrock.Platform.Cito.StringMap.
Import StringMap.

Definition PrimitiveTable := t ADTEntry.

Definition Empty_adt : ADTEntry :=
  {|
    Model := Empty_set;
    RepInv := fun _ a => match a with end;
    RepInvGood := fun _ a => match a with end
  |}.

Definition product_adt (a b : ADTEntry) : ADTEntry.
  refine (
      {|
        Model := (Model a * Model b)%type;
        RepInv := fun p adt => (Ex x, Ex y, (p ==*> x, y) * RepInv a x (fst adt) * RepInv b y (snd adt))%Sep;
        RepInvGood := _
      |}).

  intros.
  destruct a0; simpl in *.
  unfold any.
  sepLemma.
  unfold himp.
  intros.
  step auto_ext.
  eauto.
Defined.

Section TableSection.

  Variable primitive_table : PrimitiveTable.

  Fixpoint interp_adt (ty : ADTScheme) : ADTEntry :=
    match ty with
      | Primitive name =>
        match find name primitive_table with
          | Some adt => adt
          | None => Empty_adt
        end
      | Product a b => product_adt (interp_adt a) (interp_adt b)
    end.

  Record ADTValue :=
    {
      Ty : ADTScheme;
      Value : Model (interp_adt Ty)
    }.

End TableSection.

Module Type ADTTable.

  Parameter primitive_table : PrimitiveTable.

End ADTTable.

Require Import Bedrock.Platform.Cito.ADT.

Module TabledADT (Import T : ADTTable) <: ADT.

  Definition ADTValue := ADTValue primitive_table.

End TabledADT.

Module Make (Import T : ADTTable).

  Module Import A := TabledADT T.

  Require Import Bedrock.Platform.Cito.RepInv.

  Module TabledADTRepInv <: RepInv A.

    Definition rep_inv p a := RepInv (interp_adt primitive_table (Ty a)) p (Value a).

    Definition rep_inv_ptr p a := RepInvGood (interp_adt primitive_table (Ty a)) p (Value a).

    Definition RepInv := W -> ADTValue -> HProp.

  End TabledADTRepInv.

End Make.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                 Intensional Lambda Calculus                        *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        LamSF_Residuals.v                           *)
(*                                                                    *)
(* adapted from Residuals.v for Lambda Calculus                       *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.
Require Import LamSF_Substitution.
Require Import LamSF_Redexes.
Require Import Omega.

(*************************************************)
(* Parallel beta reduction with residual tracing *)
(*************************************************)

(* (residuals U V W) means W are residuals of redexes U by step V *)

Inductive residuals : redexes -> redexes -> redexes -> Prop :=
  | Res_Oper : forall o, residuals (Opp o) (Opp o) (Opp o)
  | Res_Var : forall i, residuals (Var i) (Var i) (Var i)
  | Res_Ap :
      forall U1 V1 W1 : redexes,
      residuals U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      residuals U2 V2 W2 ->
      forall (b : bool), residuals (Ap b U1 U2) (Ap false V1 V2) (Ap b W1 W2)
   | Res_Fun :
      forall U V W ,
      residuals U V W -> residuals (Fun U) (Fun V) (Fun W)
  | Res_redex :
      forall U1 V1 W1 : redexes,
      residuals U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      residuals U2 V2 W2 ->
      forall (b : bool),
      residuals (Ap b (Fun U1) U2) (Ap true (Fun V1) V2) (subst_r W2 W1)
.

Hint Resolve Res_Var Res_Oper Res_Fun Res_Ap Res_redex.

Lemma residuals_function :
 forall U V W : redexes,
 residuals U V W -> forall (W' : redexes) (R : residuals U V W'), W' = W.
Proof.
(* Remark use of name R necessary for uniform expression of next line *)
simple induction 1; intros; inversion R; auto with arith.
elim H1 with W0; elim H3 with W3; trivial with arith.
elim H1 with W1; trivial with arith.
elim H1 with W0; elim H3 with W3; trivial with arith.
Qed.

(* Commutation theorem *)

Lemma residuals_lift_rec :
 forall U1 U2 U3 : redexes,
 residuals U1 U2 U3 ->
 forall k n : nat,
 residuals (lift_rec_r U1 n k) (lift_rec_r U2 n k) (lift_rec_r U3 n k).
Proof.
simple induction 1; simpl in |- *; intros; auto with arith; split_all.
assert(n = 0+n) by omega. rewrite H4 at 5.
unfold subst_r.  rewrite lift_rec_subst_rec.
eapply2 Res_redex.
Qed.

Lemma residuals_lift :
 forall U1 U2 U3 : redexes,
 residuals U1 U2 U3 ->
 forall k : nat, residuals (lift_r k U1) (lift_r k U2) (lift_r k U3).
Proof.
unfold lift_r in |- *; intros; apply residuals_lift_rec; trivial with arith.
Qed.
Hint Resolve residuals_lift.

Lemma residuals_subst_rec :
 forall U1 U2 U3 : redexes,
 residuals U1 U2 U3 -> forall V1 V2 V3,
 residuals V1 V2 V3 ->
 forall k : nat,
 residuals (subst_rec_r U1 V1 k) (subst_rec_r U2 V2 k) (subst_rec_r U3 V3 k).
Proof.
simple induction 1; simpl in |- *; auto with arith; split_all.
 unfold insert_Var in |- *; elim (compare k i); auto with arith.
simple induction a; auto with arith.
unfold subst_r.
assert(k = 0+k) by omega. rewrite H5.
rewrite subst_rec_subst_rec; auto with arith.
eapply2 Res_redex.
Qed.
Hint Resolve residuals_subst_rec.

(***************************)
(* The Commutation Theorem *)
(***************************)

Theorem commutation :
 forall U1 U2 U3 V1 V2 V3 : redexes,
 residuals U1 U2 U3 ->
 residuals V1 V2 V3 ->
 residuals (subst_r V1 U1) (subst_r V2 U2) (subst_r V3 U3).
Proof.
unfold subst_r in |- *; auto with arith.
Qed.

Lemma residuals_comp : forall U V W : redexes, residuals U V W -> comp U V.
Proof.
simple induction 1; simpl in |- *; auto with arith.
Qed.

Lemma preservation1 :
 forall U V UV : redexes,
 residuals U V UV ->
 forall (T : redexes) (UVT : union U V T), residuals T V UV.
Proof.
(* Remark use of name UVT for uniform command below *)
simple induction 1; simple induction T; intros; inversion UVT;
 auto with arith.
rewrite (max_false b); auto with arith.
inversion H8; auto with arith.
Qed.

Lemma preservation :
 forall U V W UV : redexes,
 union U V W -> residuals U V UV -> residuals W V UV.
Proof.
intros; apply preservation1 with U; auto with arith.
Qed.

Lemma mutual_residuals_comp :
 forall (W U UW : redexes) (RU : residuals U W UW)
   (V VW : redexes) (RV : residuals V W VW), comp UW VW.
Proof.
simple induction W; split_all.
inversion_clear RU; inversion_clear RV; trivial with arith.
inversion_clear RU; inversion_clear RV; trivial with arith.
2: inversion_clear RU; inversion_clear RV; trivial with arith;
 eapply2 Comp_Fun.
induction b; split_all.
2: inversion_clear RU; inversion_clear RV;
apply Comp_Ap;[ eapply2 H| eapply2 H0].

inversion RU; inversion RV; subst. invsub.
apply subst_preserve_comp.
assert(residuals (Fun U1) (Fun V1) (Fun W1)). eapply2 Res_Fun.
assert(residuals (Fun U0) (Fun V1) (Fun W0)). eapply2 Res_Fun.
assert(comp (Fun W1) (Fun W0)) by
eapply2 (H (Fun U1) (Fun W1) H1 (Fun U0) (Fun W0) H2).
inversion H3. subst. auto.
eapply2 H0.
Qed.

(* We take residuals only by regular redexes *)

Lemma residuals_regular :
 forall U V W : redexes, residuals U V W -> regular V.
Proof.
simple induction 1; simpl in |- *; auto with arith.
Qed.

(* Conversely, residuals by compatible regular redexes always exist
   (and are unique by residuals_function lemma above) *)

Lemma residuals_intro :
 forall U V : redexes,
 comp U V -> regular V -> exists W : redexes, residuals U V W.
Proof.
simple induction 1; simpl in |- *; split_all; eauto.
2: elim H1; split_all; eauto.
gen_case H4 b2.
2: elim H1; elim H3; split_all; exist (Ap b1 x0 x).
gen2_case H1 H4 V1.
elim H1; elim H3; split_all.
inversion H7; subst.
inversion H0. subst.
exist (subst_r x W).
Qed.

(* Residuals preserve regularity *)

Lemma residuals_preserve_regular :
 forall U V W : redexes, residuals U V W -> regular U -> regular W.
Proof.
simple induction 1; simpl in |- *; auto with arith.
simple induction b.
split_all.
gen3_case H1 H0 H4 U1.
gen2_case H0 H1 W1; inversion H0.
split_all.
split_all.
split_all.
split_all.
gen_case H4 b;
eapply2 subst_rec_preserve_regular.
Qed.


(* PUBLIC DOMAIN *)
(* Author: Georgy Dunaev, georgedunaev@gmail.com *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
Require Import Lia.
Add LoadPath "/home/user/0my/COQ".
Require Export UNIV_INST.

Require Import Logic.ClassicalFacts.
Axiom EquivThenEqual: prop_extensionality.

Inductive myeq (A : Type) (x : A) : A -> Type :=
| myeq_refl : myeq A x x.

Fixpoint myvec_comp_as {A B C} (f:B->C) (g:A->B) (n:nat) (t0: Vector.t A n) :
myeq _ (Vector.map f (Vector.map g t0))
(Vector.map (fun x=>(f(g x))) t0).
Proof.
destruct t0.
simpl.
reflexivity.
simpl.
rewrite -> myvec_comp_as.
reflexivity.
Defined.

Fixpoint vec_comp_as {A B C} (f:B->C) (g:A->B) (n:nat) (t0: Vector.t A n) :
Vector.map f (Vector.map g t0) =
Vector.map (fun x=>(f(g x))) t0.
Proof.
destruct t0.
simpl.
reflexivity.
simpl.
rewrite -> vec_comp_as.
reflexivity.
Defined.

Module VS.
Section sec0.
Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.
Check MPSV 0 0.
Notation A1Type:=Set.
Unset Elimination Schemes.
Inductive Terms : A1Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Set Elimination Schemes.

Definition Terms_rect (T : Terms -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

Definition Terms_ind (T : Terms -> Prop)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

(*Formulas*)
(*Unset Elimination Schemes.*)
Inductive Fo :=
|Atom (p:PSV) : (Vector.t Terms (psv p)) ->  Fo
|Bot :Fo
|Conj:Fo->Fo->Fo
|Disj:Fo->Fo->Fo
|Impl:Fo->Fo->Fo
|Fora(x:SetVars)(f:Fo): Fo
|Exis(x:SetVars)(f:Fo): Fo
.
(*Set Elimination Schemes.
Section Fo_rect_section.
Definition Fo_rect (T : Fo -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.
End Fo_rect_section.*)

(* Substitution *)

Fixpoint substT (t:Terms) (xi: SetVars) (u:Terms): Terms.
Proof.
destruct u.
2 : { refine (FSC _ _).
Check @Vector.map.
Check @Vector.map _ _ (substT t xi) _ t0.
exact ( @Vector.map _ _ (substT t xi) _ t0 ). }

{
(*Check my.beq_natP s xi.*)
destruct (PeanoNat.Nat.eqb s xi).
Print bool.
exact t.
exact s. }
(*Show Proof.*)
Defined.

Fixpoint isParamT (xi : SetVars) (t : Terms) {struct t} : bool :=
   match t with
   | FVC s => PeanoNat.Nat.eqb s xi
   | FSC f t0 => Vector.fold_left orb false (Vector.map (isParamT xi) t0)
   end.

Fixpoint isParamF (xi:SetVars) (f:Fo): bool.
Proof.
(*elim f; intros. *)
destruct f.
Show Proof.
Search "Exists".
exact (Vector.fold_left orb false (Vector.map (isParamT xi) t)).
exact false.
Show Proof.
exact (orb (isParamF xi f1) (isParamF xi f2)).
exact (orb (isParamF xi f1) (isParamF xi f2)).
exact (orb (isParamF xi f1) (isParamF xi f2)).
Show Proof.
exact (match (PeanoNat.Nat.eqb x xi) with
       | true => false
       | false => (isParamF xi f)
       end).
exact (match (PeanoNat.Nat.eqb x xi) with
       | true => false
       | false => (isParamF xi f)
       end).
Show Proof.
Defined.

Fixpoint substF (t:Terms) (xi: SetVars) (u : Fo): option Fo.
Proof.
pose(g := substT t xi).
pose(f := substF t xi).
destruct u.
refine (Some (Atom p _)).
exact (Vector.map g t0).
exact (Some Bot).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Conj f0 f1))
 | _,_ => None
 end).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Disj f0 f1))
 | _,_ => None
 end).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Impl f0 f1))
 | _,_ => None
 end).
(*destruct (isParamF xi (Fora x0 u)).*)
refine (match (isParamF xi (Fora x u)) with
| true => match (isParamT x t) with
          | false => match substF t xi u with
                    | Some q => Some (Fora x q)
                    | None => None
                    end
          | true => None
          end
| false => Some (Fora x u) end).
refine (match (isParamF xi (Exis x u)) with
| true => match (isParamT x t) with
          | false => match substF t xi u with
                    | Some q => Some (Exis x q)
                    | None => None
                    end
          | true => None
          end
| false => Some (Exis x u) end).
Defined.

Definition Top:Fo := Impl Bot Bot.

Notation " x --> y ":=(Impl x y) (at level 80).
(*
Notation " u '[' t >> xi ] ":=(substT t xi u ) (at level 10).
Set Warnings "-notation-overridden".
Notation " ph [ t | xi ] ":=(substF t xi ph ) (at level 10).
(*Set Warnings "default".*)
Check fun (t:Terms) (x:SetVars) => ( t [ t >> x ]).
Check fun (t:Terms) (x:SetVars) (ph:Fo) => ( ph [ t | x ] ).
*)

Open Scope list_scope.
Print List.In.
Locate "+".
Print sum.
Definition InL { A : Type } :=
fix InL (a : A) (l : list A) {struct l} : Type :=
  match l with
  | Datatypes.nil => False
  | b :: m => (sum (b = a) (InL a m))
  end.

Inductive PR (axi:list Fo) : Fo -> Type :=
| hyp (A : Fo): (InL A axi)-> @PR axi A
| a1 (A B: Fo) : @PR axi (Impl A (Impl B A))
| a2 (A B C: Fo) : @PR axi ((A-->(B-->C))-->((A-->B)-->(A-->C)))
| a12 (ph: Fo) (t:Terms) (xi:SetVars)
: @PR axi (match (substF t xi ph) with
      | Some q => (Impl (Fora xi ph) q)
      | None => Top
      end)
| b1 (ps ph: Fo) (xi:SetVars) (H:isParamF xi ps = false):
@PR axi (Impl (Fora xi (Impl ps ph)) (Impl ps (Fora xi ph)) )
| MP (A B: Fo) : (@PR axi A)->(@PR axi (Impl A B))->(@PR axi B)
| GEN (A : Fo) (xi:SetVars): (@PR axi A)->(@PR axi (Fora xi A))
.

Check @PR.
Definition AtoA (A:Fo) : PR (List.nil) (A-->A).
Proof.
apply (MP nil (A-->(A-->A)) _).
apply a1.
apply (MP nil (A-->((A-->A)-->A)) _).
apply a1.
apply a2.
Defined.

Definition B1 (ps ph:Fo) (xi:SetVars) (H:isParamF xi ps = false):
 PR nil (ps --> ph) -> PR nil (ps --> Fora xi ph).
Proof.
intro q.
apply (MP nil (Fora xi (ps --> ph))).
+ apply GEN.
  exact q.
+ apply (b1 _).
  exact H.
Defined.

Definition gen (A:Fo) (xi:SetVars) (*Generalization from Bernay's rule*)
: PR nil (A) -> PR nil (Fora xi A).
Proof.
intro q.
apply (MP nil Top).
unfold Top.
exact (AtoA Bot).
apply (MP nil (Fora xi (Top --> A))).
* apply GEN.
  apply (MP nil A).
  + exact q.
  + apply a1.
* apply b1.
  trivial.
Defined.

Definition neg (f:Fo):= (Impl f Bot).

Definition a1i (A B : Fo)(l : list Fo):(PR l B)->(PR l (Impl A B)).
Proof.
intros x.
apply (MP l B).
exact x.
apply a1.
Defined.

Fixpoint weak (A F:Fo) (l :list Fo) (x: (PR l F)) : (PR (A::l) F).
Proof.
destruct x.
apply hyp.
apply inr. (*or_intror *)
exact i.
apply a1.
apply a2.
apply a12.
apply b1.
assumption.
apply (@MP _ A0).
apply weak.
exact x1.
apply weak.
exact x2.
apply GEN. (* Order is not important! *)
apply weak. (* Order is not important! *)
exact x.
Defined.

Fixpoint weaken (F:Fo) (li l :list Fo) (x: (PR l F)) {struct li}: (PR (li ++ l) F).
Proof.
destruct li.
simpl.
exact x.
simpl.
simple refine (@weak f F (li ++ l) _).
apply weaken.
exact x.
Defined.

(*Export List Notations.*)
Fixpoint notGenWith (xi:SetVars)(l:list Fo)(B:Fo)(m:(PR l B)){struct m}:bool.
Proof.
destruct m.
exact true.
exact true.
exact true.
exact true.
exact true.
exact (andb (notGenWith xi l _ m1) (notGenWith xi l _ m2)).
exact (andb (negb (PeanoNat.Nat.eqb xi xi0)) (notGenWith xi l _ m) ).
Defined.
Check isParamF.
(*Check fun A B=> forall xi:SetVars, (true = isParamF xi A)->(notGenWith xi m).*)
Fixpoint HA xi : true = PeanoNat.Nat.eqb (xi) (xi).
Proof.
destruct xi.
reflexivity.
simpl.
exact (HA xi).
Defined.

Fixpoint ZX (xi:SetVars) :true = negb (PeanoNat.Nat.eqb xi xi) -> False.
Proof.
intro q.
destruct xi.
compute in q.
inversion q.
rewrite <- HA in q.
inversion q.
Defined.

Theorem lm (a b :bool)(G:true = (a && b) ): true = a.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Theorem lm2 (a b :bool)(G:true = (a && b) ): true = b.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Theorem N (rr:bool): (true=rr \/ rr=false).
Proof.
destruct rr; firstorder.
Defined.

Fixpoint Ded (A B:Fo)(il:list Fo)(m:(PR (cons A il) B))
(H:forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m))
{struct m}:(PR il (A-->B)).
Proof.
destruct m. (*as [i|i|i|i|i|i|i].*)
+ unfold In in i.
  simpl in i .
  destruct i .
  * rewrite <- e.
    pose (J:=weaken _ il nil (AtoA A )).
    rewrite app_nil_r in J.
    exact J.
(*exact (weaken _ il nil (AtoA A )).
apply weak.
exact (AtoA A ).
exfalso.*)
  * simpl in H.
    apply a1i.
    exact (hyp il _ i).
+ apply a1i.
  apply a1.
+ apply a1i.
  apply a2.
+ apply a1i.
  apply a12.
+ apply a1i.
  apply b1.
  trivial.
+ apply (MP _ (A-->A0)).
- simple refine (@Ded _ _ _ _ _).
  exact m1.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  pose (J:=notGenWith xi (A :: il) A0 m1).
  try reflexivity.
  fold J.
  fold J in W.
  apply (lm _ _ W).
-
apply (MP _ (A-->(A0-->B))).
simple refine (@Ded _ _ _ _ _).
  exact m2.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  apply (lm2 _ _ W).
(*Last part about GEN*)
apply a2.
+
apply (MP _ (Fora xi (A-->A0))).
apply GEN.
simple refine (@Ded _ _ _ _ _).
  exact m.
  intros xi0 H0.
  pose (W:=H xi0 H0).
  simpl in W.
* exact (lm2 _ _ W).
* simpl.
apply b1.
pose (r := isParamF xi A).
pose (U := H xi).
fold r in U |- *.
simpl in U.

destruct (N r).
pose (C:= lm _ _(U H0)).
exfalso.
exact (ZX _ C).
exact H0.
Show Proof.
Defined.

(*Fixpoint Ded (A B:Fo)(m:(PR (cons A nil) B)) *)

Definition lm3 (a b :bool)(A: true = a)(B: true = b):true = (a && b)
:=
 (if a as a0 return (true = a0 -> true = a0 && b)
  then
   fun _ : true = true =>
   (if b as b0 return (true = b0 -> true = true && b0)
    then fun _ : true = true => eq_refl
    else fun B0 : true = false => B0) B
  else
   fun A0 : true = false =>
   (if b as b0 return (true = b0 -> true = false && b0)
    then fun _ : true = true => A0
    else fun _ : true = false => A0) B) A.
(*destruct a,b.
reflexivity.
simpl.
exact B.
simpl.
exact A.
simpl.
exact A.
Show Proof.
Defined.*)

Fixpoint forClosed (A B:Fo)(m:(PR (cons A nil) B)):
(forall xi:SetVars, (false = isParamF xi A))
->
(forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m)).
Proof.
intros H xi Q.
destruct m; simpl; try reflexivity.
+ apply lm3.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
+ apply lm3.
  2 : simple refine (@forClosed _ _ _ _ _ _); assumption.
  pose (U:=H xi).
  rewrite <- Q in U.
  exfalso.
  inversion U.
Show Proof.
Defined.

Fixpoint SimplDed (A B:Fo) (il: list Fo)(m:(PR (cons A il) B))
(NP:forall xi:SetVars, (false = isParamF xi A))
{struct m}:(PR il (A-->B)).
Proof.
simple refine (Ded _ _ _ _ _).
exact m.
intros xi H.
rewrite <- NP in H.
inversion H.
Defined.
End sec0.

Module ModProp.
Definition Omega := Prop.
Definition OFalse := False.
Definition OAnd := and.
Definition OOr := or.
Definition OImp := (fun x y:Omega => x->y).
End ModProp.

Module ModBool.
Definition Omega := bool.
Definition OFalse := false.
Definition OAnd := andb.
Definition OOr := orb.
Definition OImp := implb.
End ModBool.

(* Here we choose an interpretation. *)
(*Export ModBool.*)
Export ModProp. (* + classical axioms *)

(** Correctness theorem **)
(** for two-valued logic **)
Section cor.
 (* Truth values*)
Context (X:Type).
(*Context (val:SetVars->X).*)
Context (fsI:forall(q:FSV),(Vector.t X (fsv q))->X).
Context (prI:forall(q:PSV),(Vector.t X (psv q))->Omega).
(*Context (prI:forall(q:PSV),(Vector.t X (psv q))->Prop).*)

Fixpoint teI (val:SetVars->X) (t:Terms): X.
Proof.
destruct t.
exact (val s).
refine (fsI f _).
simple refine (@Vector.map _ _ _ _ _).
2 : apply teI.
exact val.
exact t.
Show Proof.
Defined.
(*
Fixpoint foI (val:SetVars->X) (f:Fo): Omega.
Proof.
destruct f.
+ refine (prI p _).
  apply (Vector.map  (teI val)).
  exact t.
+ exact false.
+ exact ( andb (foI val f1) (foI val f2)).
+ exact (  orb (foI val f1) (foI val f2)).
+ exact (implb (foI val f1) (foI val f2)).
+  (*Infinite conjunction!!!*)
 Show Proof.
*)

(** (\pi + (\xi \mapsto ?) ) **)
Definition cng (val:SetVars -> X) (xi:SetVars) (m:X) :=
(fun r:SetVars =>
match Nat.eqb r xi with
| true => m
| false => (val r)
end).

(*Inductive foI (val:SetVars->X) (f:Fo): Prop
:=
   | cAtom p t0 => ?Goal0@{t:=t0}
.
   | cBot => ?Goal
   | cConj f1 f2 => ?Goal1
   | cDisj f1 f2 => ?Goal2
   | cImpl f1 f2 => ?Goal3
   | cFora x f0 => ?Goal4@{f:=f0}
   | cExis x f0 => ?Goal5@{f:=f0}
.*)

Fixpoint foI (val:SetVars->X) (f:Fo): Omega.
Proof.
destruct f.
Show Proof.
+ refine (prI p _).
  apply (@Vector.map Terms X (teI val)).
  exact t.
+ exact OFalse.
+ exact ( OAnd (foI val f1) (foI val f2)).
+ exact (  OOr (foI val f1) (foI val f2)).
+ exact ( OImp (foI val f1) (foI val f2)).
Show Proof.
+ exact (forall m:X, foI (cng val x m) f).
(*forall m:X, foI (fun r:SetVars =>
match Nat.eqb r x with
| true => m
| false => (val r)
end
) f*)
+ exact (exists m:X, foI (fun r:SetVars =>
match Nat.eqb r x with
| true => m
| false => (val r)
end
) f
).
Defined.

Definition ap {A B}{a0 a1:A} (f:A->B) (h:a0=a1):((f a0)=(f a1))
:= match h in (_ = y) return (f a0 = f y) with
   | eq_refl => eq_refl
   end.

Section Lem1.
(*Context (t : Terms).*)

(* page 136 of the book *)
Definition lem1 (t : Terms) : forall (u :Terms) (xi : SetVars) (pi : SetVars->X) ,
(teI pi (substT t xi u))=(teI (cng pi xi (teI pi t)) u).
Proof.
fix lem1 1.
intros.
induction u as [s|f].
(*destruct u as [s|f] .*)
+ simpl.
  unfold cng.
  destruct (Nat.eqb s xi) eqn:ek. (* fsI as [H1|H2].*)
  * reflexivity.
  * simpl.
    reflexivity.
Show Proof.
+
  simpl. (* fsI teI *)
  destruct f.
  simpl.
  apply ap.
 simpl in * |- *.
apply (*Check *)
(proj1 (
eq_nth_iff X fsv0
(Vector.map (teI pi) (Vector.map (substT t xi) v))
(Vector.map (teI (cng pi xi (teI pi t))) v)
)).
intros.
(*rewrite H0.*)
 simpl in * |- *.
(* now I need to show that .nth and .map commute *)
Check nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0.
rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
Check nth_map (teI (cng pi xi (teI pi t))) v.
rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
Check nth_map (substT t xi) v p2 p2 eq_refl.
rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
exact (H p2).
reflexivity.
Defined.

(*Theorem additi pi xi n (v:Vector.t _ n) :
Vector.map (teI pi) (Vector.map (substT t xi) v) =
Vector.map (teI (cng pi xi (teI pi t))) v.
apply (*Check *)
(proj1 (
eq_nth_iff X fsv0
(Vector.map (teI pi) (Vector.map (substT t xi) v))
(Vector.map (teI (cng pi xi (teI pi t))) v)
)).
intros.
(*rewrite H0.*)
 simpl in * |- *.
(* now I need to show that .nth and .map commute *)
Check nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0.
rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
Check nth_map (teI (cng pi xi (teI pi t))) v.
rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
Check nth_map (substT t xi) v p2 p2 eq_refl.
rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
exact (H p2).
reflexivity.*)

End Lem1.

Theorem SomeInj {foo} :forall (a b : foo), Some a = Some b -> a = b.
Proof.
  intros a b H.
  inversion H.
  reflexivity.
Defined.

Theorem eq_equ (A B:Prop) : A=B -> (A <-> B).
Proof.
intro p.
destruct p.
firstorder.
Defined. (* rewrite p. firstorder. *)

Theorem conj_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 /\ B0) = (A1 /\ B1).
Proof. destruct pA, pB; reflexivity. Defined.
Theorem disj_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 \/ B0) = (A1 \/ B1).
Proof. destruct pA, pB; reflexivity. Defined.
Theorem impl_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 -> B0) = (A1 -> B1).
Proof. destruct pA, pB; reflexivity. Defined.
Lemma dbl_cng pi xi m1 m2: forall q,(cng (cng pi xi m1) xi m2) q = (cng pi xi m2) q.
Proof. intro q. unfold cng. destruct (Nat.eqb q xi); reflexivity. Defined.

Theorem l01 h n v :
Vector.fold_left orb false (Vector.cons bool h n v) = Vector.fold_left orb (orb false h) v.
Proof.
simpl. reflexivity.
Defined.
(*Fixpoint {struct v}*)
(*fold_left orb true v*)
(*Lemma l00 h n v :  Vector.fold_left orb false (Vector.cons bool h n v) = false
-> (h=false).
intros.
destruct h eqn:y.
simpl in * |- *.
simpl.
auto. *)

(** NOW SEE seq_of_bool.v **)
Check all_then_someV.
(*Lemma all_then_some (A:Type)(n:nat)(p:Fin.t (n)) (v:Vector.t bool (n))
(H : Vector.fold_left orb false v = false)
 : (Vector.nth v p) = false.
Proof.
induction v.
inversion p.
rewrite -> l01 in H.
destruct h.
admit.
simpl in H.
(*pose (G:= IHv (@Fin.F1 n) H).
simpl.
destruct p.*)
Abort.*)

Lemma all_then_someP (A:Type)(n:nat)(p:Fin.t (n)) (v:Vector.t A (n)) (P:A->bool)
(H : Vector.fold_left orb false (Vector.map P v) = false)
 : (P (Vector.nth v p)) = false.
Proof.
Check nth_map P v p p eq_refl.
rewrite <- (nth_map P v p p eq_refl).
apply all_then_someV. trivial.
Defined.

(* Not a parameter then not changed afted substitution (for Terms) *)
Lemma NPthenNCAST (u:Terms)(xi:SetVars)(t:Terms) (H:(isParamT xi u=false))
: (substT t xi u) = u.
Proof. induction u.
+ simpl in * |- *.
  rewrite H. reflexivity.
+ simpl in * |- *.
  apply ap.
apply eq_nth_iff.
intros p1 p2 ppe.
Check nth_map _ _ _ p2 ppe.
rewrite (nth_map _ _ _ p2 ppe).
apply H0.
simpl.
apply all_then_someP.
trivial.
Defined.

Lemma NPthenNCAST_vec:forall p xi t ts (H:(isParamF xi (Atom p ts)=false)),
  (Vector.map (substT t xi) ts) = ts.
Proof.
  intros p xi t1 ts H.
  apply eq_nth_iff.
  intros p1 p2 H0.
  Check nth_map (substT t1 xi) ts p1 p2 H0.
  rewrite -> (nth_map (substT t1 xi) ts p1 p2 H0).
  apply NPthenNCAST.
  apply all_then_someP.
  simpl in H.
  exact H.
Defined.

(* Not a parameter then not changed afted substitution (for Formulas) *)
Fixpoint NPthenNCASF (mu:Fo) : forall (xi:SetVars)(t:Terms) (H:(isParamF xi mu=false))
   , substF t xi mu = Some mu .
Proof. (*induction mu eqn:u0.*)
destruct mu eqn:u0.
Check t.
* intros xi t0 H.
  simpl.
  rewrite -> NPthenNCAST_vec; (trivial || assumption).
* intros xi t H.
  simpl; trivial.
* intros xi t H.
  simpl.
  simpl in H.
  (*pose (Q:=A1 _ _ H).*)
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  (*rewrite -> IHf1 with xi t.
  rewrite -> IHf2 with xi t.*)
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  (*rewrite -> IHmu1 with xi t.
  rewrite -> IHmu2 with xi t.*)
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (PeanoNat.Nat.eqb x xi) eqn:u2.
  trivial.
  destruct (isParamF xi f) eqn:u1.
  inversion H.
  trivial.
* simpl.
  intros xi t H.
  destruct (PeanoNat.Nat.eqb x xi) eqn:u2.
  trivial.
  destruct (isParamF xi f) eqn:u1.
  inversion H.
  trivial.
Defined.

(* p.137 *)
Section Lem2.
Definition lem2 : forall (t : Terms) (fi : Fo) (xi : SetVars) (pi : SetVars->X),
option_map (foI pi ) (substF t xi fi) = Some (foI (cng pi xi (teI pi t)) fi).
Proof.
fix lem2 1. intros.
destruct (substF t xi fi).
2 : { simpl.
Abort.

Definition lem2 : forall (t : Terms) (fi : Fo) (xi : SetVars) (pi : SetVars->X),
match (substF t xi fi) with
| Some r => (foI pi r)=(foI (cng pi xi (teI pi t)) fi)
| None => True
end.
Proof. fix lem2 1. intros. destruct (substF t xi fi). 2 : exact I.
destruct f eqn:u0.
simpl in * |- *.
Fail  apply
    (proj1 (
      eq_nth_iff X (psv p)
      (Vector.map (teI pi) (Vector.map (substT t xi) t0))
      (Vector.map (teI (cng pi xi (teI pi t))) t0)
    )).
Abort.
Lemma mqd x t pi m (H:isParamT x t = false): (teI (cng pi x m) t) = (teI pi t).
Proof.
induction t.
 simpl.
simpl in H.
unfold cng.
rewrite -> H.
reflexivity.
 simpl.
simpl in H.
apply ap.
apply eq_nth_iff.
intros.
Check nth_map (teI (cng pi x m)) v p1 p1 eq_refl.
rewrite -> (nth_map (teI (cng pi x m)) v p1 p1 eq_refl).
rewrite -> (nth_map (teI pi) v p2 p2 eq_refl).
rewrite <- H1.
apply H0.
exact (all_then_someP _ _ p1 _ (isParamT x) H).
Defined.

Lemma cng_commF  x xi m0 m1 pi fi :
PeanoNat.Nat.eqb x xi = false ->
foI (cng (cng pi x m0) xi m1) fi = foI (cng (cng pi xi m1) x m0) fi.
Proof. intro i.
destruct fi.
simpl.
Abort. (* TODO replace cng_commEXT with cng_commF and cng_commT *)

Lemma cng_commEXT  x xi m0 m1 pi :
PeanoNat.Nat.eqb x xi = false ->
(cng (cng pi x m0) xi m1) = (cng (cng pi xi m1) x m0).
Proof. intro i.
apply functional_extensionality.
intro b.
unfold cng.
destruct (Nat.eqb b xi) eqn:e1, (Nat.eqb b x) eqn:e2.
rewrite -> (proj1 (PeanoNat.Nat.eqb_eq b x) e2) in e1.
rewrite e1 in i.
inversion i.
reflexivity.
reflexivity.
reflexivity.
Defined.

Context (t : Terms).
Definition lem2 : forall (fi : Fo) (xi : SetVars) (pi : SetVars->X)
(r:Fo) (H:(substF t xi fi) = Some r), (*(SH:sig (fun(r:Fo)=>(substF t xi fi) = Some r)),*)
(foI pi r)=(foI (cng pi xi (teI pi t)) fi).
Proof.
fix lem2 1.
intros fi xi pi.
(*destruct (substF t xi fi) eqn: j.*)
(**)
induction fi.
+  simpl in *|-*; intros r H.
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl.
  (*apply eq_equ.*)
  apply ap.
  apply
    (proj1 (
      eq_nth_iff X (psv p)
      (Vector.map (teI pi) (Vector.map (substT t xi) t0))
      (Vector.map (teI (cng pi xi (teI pi t))) t0)
    )).
  rename t0 into v.
  intros p1 p2 H0.
  rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
  rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
  rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
  apply lem1. reflexivity.
+  simpl in *|-*; intros r H.
   inversion H. trivial.
+  simpl in *|-*; intros r H.
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  apply conj_eq ;   fold foI.
  simpl in * |- *.
  * apply (IHfi1 f1 eq_refl).
  * apply (IHfi2 f2 eq_refl).
  * inversion H.
  * inversion H.
+ simpl in *|-*; intros r H.
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl in * |- *.
  apply disj_eq ;   fold foI.
  * apply (IHfi1 f1 eq_refl).
  * apply (IHfi2 f2 eq_refl).
  * inversion H.
  * inversion H.
+ simpl in *|-*; intros r H.
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl in * |- *.
  apply impl_eq ;   fold foI.
  * apply (IHfi1 f1 eq_refl).
  * apply (IHfi2 f2 eq_refl).
  * inversion H.
  * inversion H.
+ intros r H.
  (*simpl in * |- *.
  destruct (PeanoNat.Nat.eqb x xi) eqn:j0.
  * destruct (isParamF xi (Fora x fi) ) eqn:tuc.
    -
  simpl.*)
 destruct (isParamF xi (Fora x fi) ) eqn:tuc.
2 : {
Check NPthenNCASF.
rewrite NPthenNCASF in H.
 pose (Q:=SomeInj _ _ H).
rewrite <- Q.
apply lem2.
pose (J:=(PeanoNat.Nat.eqb x xi)).
simpl.
simpl in tuc.
destruct (PeanoNat.Nat.eqb x xi) (*as [J0|J1]*).
reflexivity.
destruct (isParamF xi fi).
inversion tuc.
reflexivity.
assumption.
}
simpl in tuc.
simpl in H.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
inversion tuc.
rewrite tuc in H.
destruct (isParamT x t) eqn:k2.
inversion H.
destruct (substF t xi fi) eqn:k3.
2 : inversion H.
pose(Q:=SomeInj _ _ H).
rewrite <- Q.
simpl in *|-*.
assert (AS0 : exists ro:Fo, (substF t xi fi) = Some ro).
 exists f.
 exact k3. clear AS0.
apply EquivThenEqual.
split.
intros.
pose (K:=H0 m).
rewrite -> lem2 with (fi:=fi) (xi:=xi) in K .
2 : exact k3.
rewrite -> mqd in K.
2 : exact k2. (* x and xi are different so they are interchangeable *)
simpl.
rewrite cng_commEXT in K.
exact K.
exact k1.

intros.
pose (K:=H0 m).
rewrite cng_commEXT in K.

rewrite <- mqd with (x:=x) (t:=t)(m:=m) in K.

Check lem2 fi xi (cng pi x m) f k3.
rewrite <- lem2 with (fi:=fi) (xi:=xi) (r:=f) in K .
exact K.
exact k3.
exact k2.
Check reflect.

destruct (PeanoNat.Nat.eq_dec x xi) eqn:w.
rewrite e in k1.
Check not_iff_compat.
Check PeanoNat.Nat.eqb_eq x xi.
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
Lemma IOF xi : PeanoNat.Nat.eqb xi xi = true.
induction xi.
simpl. trivial.
simpl. exact IHxi.
Defined.
rewrite -> (IOF xi) in k1.
inversion k1.
pose (n2:= not_eq_sym n).
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
pose (n3:= proj2 (not_iff_compat (PeanoNat.Nat.eqb_eq xi x)) n2).
apply not_true_is_false.
exact n3.
(* FORALL case is proved but with funext! *)
+

auto with arith.
compute in k1.
Check PeanoNat.Nat.compare_eq_iff.
Print Eq.
simpl in k1.
inversion k1.
simpl in H2.
inversion H2.
destruct (PeanoNat.Nat.eqb xi x) eqn: s.

assert (ASSE: reflect (x=xi) (PeanoNat.Nat.eqb x xi)).
admit.
destruct ASSE eqn:j.
inversion k1.
Check reflect_iff _ _ ASSE.
admit.
(*rewrite e in .
Check iff_reflect.
Check eqb_eq _ _ k1.
exact k1.*)

+ admit.
Admitted.

simpl in K.
rewrite -> lem2 with (fi:=fi) (xi:=xi) in K .
2 : exact k3.
rewrite -> mqd in K.
2 : exact k2. (* x and xi are different so they are interchangeable *)
simpl.
rewrite cng_commEXT in K.
exact K.
exact k1.

(**** HERE IS THE DEVELOPMENT ****)

simpl.
Check functional_extensionality.

exact K.
Abort.
End Lem2. (*temporary*)

Check equal_f.

(* rewrite IHfi in H0. ne pomozhet *)
assert (AS1 :
simpl in *|-*.
(*
Abort.
End Lem2. (*temporary*)
Fixpoint lmi t xi x psi r : substF t xi (Fora x psi) = Some r ->
        exists ro:Fo, (substF t xi psi) = Some ro.
Proof.
intros H.
simpl in H.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
destruct r eqn:ln.
inversion H.
inversion H.
inversion H.
inversion H.
inversion H.
exists psi.
reflexivity.

simpl in *|-*.
simpl .

(SomeInj _ _ H).
simpl in *|-*.

(*unfold substF in H.*)
(*cbv delta in H.*)
simpl in H.
destruct (substF t xi (Fora x psi)) eqn:k2.

pose(Y:=(substF t xi (Fora x psi))).
destruct (substF t xi (psi)) eqn:k0.
exists f0.
reflexivity.
simpl in k2, Y.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
induction r.
inversion H.
inversion H.
inversion H.
inversion H.
inversion H.

*)

fold substF in H.
induction (substF t xi (psi)) eqn:e1.
exists a; reflexivity.
induction (substF t xi (Fora x psi)) eqn:e1.

simpl in *|-*.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
inversion tuc.
destruct (isParamF xi fi) eqn:k2.
destruct (isParamT x t) eqn:k3.
inversion H.
destruct (substF t xi fi) eqn:k4.
simpl in *|-*.
pose(Q:=SomeInj _ _ H).
rewrite <- Q.
simpl in *|-*.
(*p.137.*)
assert (AS0 : exists ro:Fo, (substF t xi f) = Some ro).

apply EquivThenEqual.
split.
intros.
assert (U : forall m :X, (foI (cng pi x m) f) = (foI (cng (cng pi xi (teI pi t)) x m) fi)).
intro m.

admit.
rewrite U.
apply ap.

ENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDEND

apply IHfi.
symmetry.
simpl.
rewrite <- IHfi.

HJJHJHJH

simpl.
destruct (PeanoNat.Nat.eqb x xi) eqn:xxi.
admit.
admit.
admit.
  simpl in *|-*.

  pose (Q:=SomeInj _ _ H).
  pose (E:=proj1 (@PeanoNat.Nat.eqb_eq x xi) xxi).
  rewrite -> E.
  rewrite <- Q.
  simpl in * |- *.
Check fun m=>(cng (cng pi xi (teI pi t)) xi m).
Check fun m1 m2 =>(functional_extensionality _ _ (dbl_cng pi xi m1 m2)).
(*rewrite -> (fun m=> (dbl_cng  pi xi (teI pi t) m)) .*)
 (*to be continued... *)
  *
(*rewrite -> IHfi.*)
(*destruct fi; simpl.*)
  admit.
  * destruct (isParamF xi fi) eqn: yu.
    destruct (isParamT x t) eqn: os.
simpl.
Abort.
(*
Vector.map (teI pi) (Vector.map (substT t xi) v) =
Vector.map (teI (cng pi xi (teI pi t))) v
*)
End Lem2.

(* lem2  is not proven yet! *)

Fixpoint correct (f:Fo) (l:list Fo) (val:SetVars->X) (m:PR l f)
(lfi : forall h:Fo, (InL h l)->(foI val h)) {struct m}: foI val f.
Proof.
destruct m (* eqn: meq *).
+ exact (lfi A i).
+ simpl.
  intros a b.
  exact a.
+ simpl.
  intros a b c.
  exact (a c (b c)).
+ destruct (substF t xi ph) eqn: j.
  2 : {simpl. trivial. }
  apply (correct _ l).
  2 : {assumption. }
  simpl.
pose (Z:=(@Ded (Fora xi ph) f l )).
simple refine (Z _ _ ).
(*
  pose (W:= lfi f).
  destruct (Nat.eqb r xi).
  simpl in H.
  exact H.
  unfold foI.
  simpl.
*)
Abort.

End cor.
(* Definition ACK : list Fo := . *)

End VS.

(*Theorem AA (a:nat):nat.
elim a;
[> revert a | idtac 1].
elim a;
[> idtac 1 | idtac 1].
destruct a.
(*Unfocus.*)
[> idtac 1 | idtac 1].*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import FunInd.
Require Export Qhomographic.

Functional Scheme fraction_encoding_ind :=
  Induction for fraction_encoding Sort Prop.

Lemma fraction_encoding_equal :
 forall (m n : Z) (Hn1 Hn2 : n <> 0%Z),
 fraction_encoding m n Hn1 = fraction_encoding m n Hn2.
Proof.
 intros m n Hn1.
 unfold fraction_encoding at 2; fold fraction_encoding.
 functional induction (fraction_encoding m n Hn1); intros Hn2;
 rewrite e;
   trivial || (
 f_equal;
 apply positive_fraction_encoding_equal).
Defined.

Ltac Rewrite_eq_ :=
  repeat
   match goal with
   | id1:(_ = left _ _) |- _ => rewrite id1; clear id1
   | id1:(_ = right _ _) |- _ => rewrite id1; clear id1
   | id1:(_ = inleft _ _) |- _ =>
       rewrite id1; clear id1
   | id1:(_ = inright _ _) |- _ => rewrite id1; clear id1
   end.

Ltac Clear_eq_ :=
  repeat
   match goal with
   | id1:(_ = left _ _) |- _ => clear id1
   | id1:(_ = right _ _) |- _ => clear id1
   | id1:(_ = inleft _ _) |- _ => clear id1
   | id1:(_ = inright _ _) |- _ => clear id1
   end.

Ltac Sign_mismatch :=
  Clear_eq_;
   match goal with
   | id1:(?X1 = 1%Z),id2:(?X1 = 0%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = 0%Z),id2:(?X1 = 1%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = (-1)%Z),id2:(?X1 = 0%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = 0%Z),id2:(?X1 = (-1)%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = 1%Z),id2:(?X1 = (-1)%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = (-1)%Z),id2:(?X1 = 1%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   end.

Functional Scheme Qhomographic_Qpositive_to_Q_ind :=
  Induction for Qhomographic_Qpositive_to_Q Sort Prop.

Lemma Qhomographic_Qpositive_to_Q_0 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p)
   (Hc : c <> 0%Z),
 (a * d)%Z = (b * c)%Z ->
 d = 0%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 fraction_encoding a c Hc.
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction ( Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);
   intros;
     try solve [ Falsum ]; unfold Qhomographic_Qpositive_to_Q in |- *.
 apply fraction_encoding_equal.
 apply fraction_encoding_equal.
Defined.

Lemma Qhomographic_Qpositive_to_Q_1 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p)
   (Hd : d <> 0%Z),
 (a * d)%Z = (b * c)%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 fraction_encoding b d Hd.
Proof.
  intros a b c d p H_Qhomographic_sg_denom_nonzero.
  functional induction (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);intros;
    try solve [ Falsum ]; unfold Qhomographic_Qpositive_to_Q in |- *.
      apply fraction_encoding_equal.
Defined.

Lemma Qhomographic_Qpositive_to_Q_2 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 0%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero = Zero.
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);intros;
   try solve [Falsum|Sign_mismatch];
   reflexivity.
Qed.

(** This tactic solves the goal by contradiction, if in the hypothesis there are two terms `a<c` and `c<=a` *)
Ltac Order_mismatch :=
  Clear_eq_;
   match goal with
   | id1:(?X1 < ?X2)%Z,id2:(?X2 <= ?X1)%Z |- _ =>
       match goal with
       | id1:(?X1 < ?X2)%Z,id2:(?X2 <= ?X1)%Z |- _ =>
           first [ apply False_ind | apply False_rec ]; apply (Z.lt_irrefl X1);
            apply Z.lt_le_trans with X2; assumption
       end
   | id2:(?X1 <= ?X2)%Z,id1:(?X2 < ?X1)%Z |- _ =>
       match goal with
       | id1:(?X1 < ?X2)%Z,id2:(?X2 <= ?X1)%Z |- _ =>
           first [ apply False_ind | apply False_rec ]; apply (Z.lt_irrefl X1);
            apply Z.lt_le_trans with X2; assumption
       end
   end.

Lemma Qhomographic_Qpositive_to_Q_3 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z ->
 forall
   hyp_homographicAcc : homographicAcc
                          (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_b a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_d a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_p a b c d p H_Qhomographic_sg_denom_nonzero),
 (0 <
  Z.sgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero))%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 Qpos
   (Qhomographic_Qpositive_to_Qpositive
      (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_b a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_d a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_p a b c d p H_Qhomographic_sg_denom_nonzero) hyp_homographicAcc).
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);intros;
             try solve [ Falsum | Sign_mismatch | Order_mismatch ];
             unfold Qhomographic_Qpositive_to_Q in |- *;
             apply f_equal with Qpositive;
             apply Qhomographic_Qpositive_to_Qpositive_equal.
Qed.

Lemma Qhomographic_Qpositive_to_Q_4 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = 1%Z ->
 forall
   hyp_homographicAcc : homographicAcc
                          (- new_a a b c d p H_Qhomographic_sg_denom_nonzero)
                          (- new_b a b c d p H_Qhomographic_sg_denom_nonzero)
                          (- new_c a b c d p H_Qhomographic_sg_denom_nonzero)
                          (- new_d a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_p a b c d p H_Qhomographic_sg_denom_nonzero),
 (Z.sgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero) <= 0)%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 Qpos
   (Qhomographic_Qpositive_to_Qpositive
      (- new_a a b c d p H_Qhomographic_sg_denom_nonzero)
      (- new_b a b c d p H_Qhomographic_sg_denom_nonzero)
      (- new_c a b c d p H_Qhomographic_sg_denom_nonzero)
      (- new_d a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_p a b c d p H_Qhomographic_sg_denom_nonzero) hyp_homographicAcc).
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction
   (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);intros;
   try solve [ Falsum | Sign_mismatch | Order_mismatch ];
     unfold Qhomographic_Qpositive_to_Q in |- *;
       apply f_equal with Qpositive;
         apply Qhomographic_Qpositive_to_Qpositive_equal.
Qed.

Lemma Qhomographic_Qpositive_to_Q_5 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = (-1)%Z ->
 forall
   hyp_homographicAcc : homographicAcc
                          (- new_a a b c d p H_Qhomographic_sg_denom_nonzero)
                          (- new_b a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_d a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_p a b c d p H_Qhomographic_sg_denom_nonzero),
 (Z.sgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero) < 0)%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 Qneg
   (Qhomographic_Qpositive_to_Qpositive
      (- new_a a b c d p H_Qhomographic_sg_denom_nonzero)
      (- new_b a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_c a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_d a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_p a b c d p H_Qhomographic_sg_denom_nonzero) hyp_homographicAcc).
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction
   (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);
   intros;
     try solve [ Falsum | Sign_mismatch | Order_mismatch ];
        (unfold Qhomographic_Qpositive_to_Q in |- *;
         apply f_equal with Qpositive;
           apply Qhomographic_Qpositive_to_Qpositive_equal).
Qed.

Lemma Qhomographic_Qpositive_to_Q_6 :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p),
 (a * d)%Z <> (b * c)%Z ->
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero = (-1)%Z ->
 forall
   hyp_homographicAcc : homographicAcc
                          (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_b a b c d p H_Qhomographic_sg_denom_nonzero)
                          (- new_c a b c d p H_Qhomographic_sg_denom_nonzero)
                          (- new_d a b c d p H_Qhomographic_sg_denom_nonzero)
                          (new_p a b c d p H_Qhomographic_sg_denom_nonzero),
 (0 <=
  Z.sgn
    (new_a a b c d p H_Qhomographic_sg_denom_nonzero +
     new_b a b c d p H_Qhomographic_sg_denom_nonzero))%Z ->
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero =
 Qneg
   (Qhomographic_Qpositive_to_Qpositive
      (new_a a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_b a b c d p H_Qhomographic_sg_denom_nonzero)
      (- new_c a b c d p H_Qhomographic_sg_denom_nonzero)
      (- new_d a b c d p H_Qhomographic_sg_denom_nonzero)
      (new_p a b c d p H_Qhomographic_sg_denom_nonzero) hyp_homographicAcc).
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero.
 functional induction
   (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero);intros;
             try solve [ Falsum | Sign_mismatch | Order_mismatch ];
             unfold Qhomographic_Qpositive_to_Q in |- *;
             apply f_equal with Qpositive;
             apply Qhomographic_Qpositive_to_Qpositive_equal.
Qed.

Lemma h_sign_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero1 =
 h_sign a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 abstract (intros a b c d p H_Qhomographic_sg_denom_nonzero1
            H_Qhomographic_sg_denom_nonzero2;
            change
              (fst
                 (Qhomographic_sign a b c d p
                    H_Qhomographic_sg_denom_nonzero1) =
               fst
                 (Qhomographic_sign a b c d p
                    H_Qhomographic_sg_denom_nonzero2))
             in |- *;
            apply f_equal with (Z * (Z * (Z * (Z * Z)) * Qpositive))%type;
            apply Qhomographic_sign_equal).
Defined.

Lemma new_a_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 new_a a b c d p H_Qhomographic_sg_denom_nonzero1 =
 new_a a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 abstract (intros a b c d p H_Qhomographic_sg_denom_nonzero1
            H_Qhomographic_sg_denom_nonzero2; unfold new_a in |- *;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * Qpositive)%type;
            apply f_equal with (Z * (Z * (Z * (Z * Z)) * Qpositive))%type;
            apply Qhomographic_sign_equal).
Defined.

Lemma new_b_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 new_b a b c d p H_Qhomographic_sg_denom_nonzero1 =
 new_b a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 abstract (intros a b c d p H_Qhomographic_sg_denom_nonzero1
            H_Qhomographic_sg_denom_nonzero2; unfold new_b in |- *;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * Qpositive)%type;
            apply f_equal with (Z * (Z * (Z * (Z * Z)) * Qpositive))%type;
            apply Qhomographic_sign_equal).
Defined.

Lemma new_c_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 new_c a b c d p H_Qhomographic_sg_denom_nonzero1 =
 new_c a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 abstract (intros a b c d p H_Qhomographic_sg_denom_nonzero1
            H_Qhomographic_sg_denom_nonzero2; unfold new_c in |- *;
            apply f_equal with (Z * Z)%type;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * Qpositive)%type;
            apply f_equal with (Z * (Z * (Z * (Z * Z)) * Qpositive))%type;
            apply Qhomographic_sign_equal).
Defined.

Lemma new_d_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 new_d a b c d p H_Qhomographic_sg_denom_nonzero1 =
 new_d a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 abstract (intros a b c d p H_Qhomographic_sg_denom_nonzero1
            H_Qhomographic_sg_denom_nonzero2; unfold new_d in |- *;
            apply f_equal with (Z * Z)%type;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * Qpositive)%type;
            apply f_equal with (Z * (Z * (Z * (Z * Z)) * Qpositive))%type;
            apply Qhomographic_sign_equal).
Defined.

Lemma new_p_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 new_p a b c d p H_Qhomographic_sg_denom_nonzero1 =
 new_p a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 abstract (intros a b c d p H_Qhomographic_sg_denom_nonzero1
            H_Qhomographic_sg_denom_nonzero2; unfold new_p in |- *;
            apply f_equal with (Z * (Z * (Z * Z)) * Qpositive)%type;
            apply f_equal with (Z * (Z * (Z * (Z * Z)) * Qpositive))%type;
            apply Qhomographic_sign_equal).
Defined.

Lemma Qhomographic_Qpositive_to_Q_equal :
 forall (a b c d : Z) (p : Qpositive)
   (H_Qhomographic_sg_denom_nonzero1
    H_Qhomographic_sg_denom_nonzero2 : Qhomographic_sg_denom_nonzero c d p),
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero1 =
 Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero2.
Proof.
 intros a b c d p H_Qhomographic_sg_denom_nonzero1.

 functional induction
   (Qhomographic_Qpositive_to_Q a b c d p H_Qhomographic_sg_denom_nonzero1);intros.

 (* 1 *)
generalize
 (Qhomographic_sg_denom_nonzero_nonzero_3 _ _ _
    H_Qhomographic_sg_denom_nonzero1).
 intros [Hc| Hd].

 rewrite
  (Qhomographic_Qpositive_to_Q_0 a b c 0 p H_Qhomographic_sg_denom_nonzero2
     Hc _x (refl_equal 0%Z)).
 apply fraction_encoding_equal.
 Falsum.
generalize
 (Qhomographic_sg_denom_nonzero_nonzero_3 _ _ _
    H_Qhomographic_sg_denom_nonzero1).
 intros [Hc| Hd].

 rewrite
  (Qhomographic_Qpositive_to_Q_0 a b c 0 p H_Qhomographic_sg_denom_nonzero2
     Hc _x (refl_equal 0%Z)).
 apply fraction_encoding_equal.
 Falsum.

 (* 2 *)
 rewrite
  (Qhomographic_Qpositive_to_Q_1 a b c d p H_Qhomographic_sg_denom_nonzero2
     d_neq_zero _x).
 apply fraction_encoding_equal.
 (* 3 *)
 clear e0.
 rewrite
  (h_sign_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in _x.
 rewrite
  (Qhomographic_Qpositive_to_Q_2 a b c d p H_Qhomographic_sg_denom_nonzero2
     ad_neq_bc _x).
 reflexivity.
 (* 4 *)

 Clear_eq_.
 generalize
  (Qhomographic_Qpositive_to_Q_homographicAcc_pos_1 a b c d p
     H_Qhomographic_sg_denom_nonzero1 ad_neq_bc l1_eq_one z).
 assert (l1_eq_one0 := l1_eq_one).
 rewrite
  (h_sign_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in l1_eq_one0.
 change
   (0 <
    Z.sgn
      (new_a a b c d p H_Qhomographic_sg_denom_nonzero1 +
       new_b a b c d p H_Qhomographic_sg_denom_nonzero1))%Z
  in z.
 assert (z0 := z).
 rewrite (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (Qhomographic_Qpositive_to_Q_3 a b c d p H_Qhomographic_sg_denom_nonzero2
     ad_neq_bc l1_eq_one0
     (Qhomographic_Qpositive_to_Q_homographicAcc_pos_1 a b c d p
        H_Qhomographic_sg_denom_nonzero2 ad_neq_bc l1_eq_one0 z0) z0)
  .
 intro H_any_homographicAcc.
 apply f_equal with Qpositive.
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong;
  [ rewrite
     (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_c_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_d_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_p_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2) ]; reflexivity.

 (* 5 *)
 Clear_eq_.
 generalize
  (Qhomographic_Qpositive_to_Q_homographicAcc_pos_2 a b c d p
     H_Qhomographic_sg_denom_nonzero1 ad_neq_bc l1_eq_one z).
 assert (l1_eq_one0 := l1_eq_one).
 rewrite
  (h_sign_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in l1_eq_one0.
 change
   (Z.sgn
      (new_a a b c d p H_Qhomographic_sg_denom_nonzero1 +
       new_b a b c d p H_Qhomographic_sg_denom_nonzero1) <= 0)%Z
  in z.
 assert (z0 := z).
 rewrite
  (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (Qhomographic_Qpositive_to_Q_4 a b c d p H_Qhomographic_sg_denom_nonzero2
     ad_neq_bc l1_eq_one0
     (Qhomographic_Qpositive_to_Q_homographicAcc_pos_2 a b c d p
        H_Qhomographic_sg_denom_nonzero2 ad_neq_bc l1_eq_one0 z0) z0)
  .
 intro H_any_homographicAcc.
 apply f_equal with Qpositive.
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong;
  [ rewrite
     (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_c_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_d_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_p_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2) ]; reflexivity.
 (* 6 *)
 Clear_eq_.
 generalize
  (Qhomographic_Qpositive_to_Q_homographicAcc_neg_1 a b c d p
     H_Qhomographic_sg_denom_nonzero1 ad_neq_bc l1_eq__minus_one z).
 assert (l1_eq__minus_one0 := l1_eq__minus_one).
 rewrite
  (h_sign_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in l1_eq__minus_one0.
 change
   (Z.sgn
      (new_a a b c d p H_Qhomographic_sg_denom_nonzero1 +
       new_b a b c d p H_Qhomographic_sg_denom_nonzero1) < 0)%Z
  in z.
 assert (z0 := z).
 rewrite
  (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (Qhomographic_Qpositive_to_Q_5 a b c d p H_Qhomographic_sg_denom_nonzero2
     ad_neq_bc l1_eq__minus_one0
     (Qhomographic_Qpositive_to_Q_homographicAcc_neg_1 a b c d p
        H_Qhomographic_sg_denom_nonzero2 ad_neq_bc l1_eq__minus_one0 z0) z0)
  .
 intro H_any_homographicAcc.
 apply f_equal with Qpositive.
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong;
  [ rewrite
     (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_c_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_d_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_p_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2) ]; reflexivity.
 (* 7 *)
 Clear_eq_.
 generalize
  (Qhomographic_Qpositive_to_Q_homographicAcc_neg_2 a b c d p
     H_Qhomographic_sg_denom_nonzero1 ad_neq_bc l1_eq__minus_one z).
 assert (l1_eq__minus_one0 := l1_eq__minus_one).
 rewrite
  (h_sign_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in l1_eq__minus_one0.
 change
   (0 <=
    Z.sgn
      (new_a a b c d p H_Qhomographic_sg_denom_nonzero1 +
       new_b a b c d p H_Qhomographic_sg_denom_nonzero1))%Z
  in z.
 assert (z0:=z).
 rewrite
  (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
     H_Qhomographic_sg_denom_nonzero2) in z0.
 rewrite
  (Qhomographic_Qpositive_to_Q_6 a b c d p H_Qhomographic_sg_denom_nonzero2
     ad_neq_bc l1_eq__minus_one0
     (Qhomographic_Qpositive_to_Q_homographicAcc_neg_2 a b c d p
        H_Qhomographic_sg_denom_nonzero2 ad_neq_bc l1_eq__minus_one0 z0) z0)
  .
 intro H_any_homographicAcc.
 apply f_equal with Qpositive.
 apply Qhomographic_Qpositive_to_Qpositive_equal_strong;
  [ rewrite
     (new_a_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_b_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_c_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_d_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2)
  | rewrite
     (new_p_equal a b c d p H_Qhomographic_sg_denom_nonzero1
        H_Qhomographic_sg_denom_nonzero2) ]; reflexivity.
Defined.


(***************************************************************************
 * Cast-Free Featherweight Java
 *
 * Bruno De Fraine, with help from Erik Ernst and Mario Sudholt, Summer 2008
 ***************************************************************************)

(** printing \in %\ensuremath{\in}% *)
(** printing \notin %\ensuremath{\notin}% *)
(** printing == %\ensuremath{\doteq}% *)

(** This library provides a number of auxiliary constructs (and their
    properties) for the study of programming languages in Coq. The definition
    of these constructs is mostly straightforward. *)

Require Import AdditionalTactics.
Require Export Atom.
Require Export List.

Set Implicit Arguments.

(** * Atoms *)

Notation "x == y" := (eq_atom_dec x y) (at level 67).

Fact eq_atom_true: forall (A : Type) a (c d : A),
    (if a == a then c else d) = c.
Proof.
  intros.
  destruct (a == a).
    reflexivity.
    destruct n. reflexivity.
Qed.

Hint Rewrite eq_atom_true.

Fact eq_atom_false: forall (A : Type) a b (c d : A),
    a <> b -> (if a == b then c else d) = d.
Proof.
  intros.
  destruct (a == b); [ subst; destruct H | ]; reflexivity.
Qed.

Hint Rewrite eq_atom_false.

Definition In_atom_list_dec := In_dec eq_atom_dec.

Lemma symmetry_neq : forall A (x y : A),
    (x <> y) -> (y <> x).
Proof.
    intros.
    unfold not in * |- *.
    intros.
    symmetry in H0.
    apply H.
    auto.
Qed.

Lemma cons_app_equiv {A: Type} : forall (x:A) xs,
    x :: xs = (x :: nil) ++ xs.
Proof.
    intros.
    simpl.
    reflexivity.
Qed.

(** * Environments *)

(** An environment maps atoms to some value of an variable type [A]. We model
    an environment as a list of pairs: [list (atom * A)]. *)

Notation "x \in E" := (In x E) (at level 69).
Notation "x \notin E" := (~ In x E) (at level 69).

Lemma not_in_split {A : Type} : forall (x : A) (e : A) E,
    x \notin (e :: E) ->
    x <> e /\ x \notin E.
Proof.
    intros.
    assert (Hneq: x <> e). (* Want to re-use this *)
    Case "x <> e".
    unfold not.
    intros.
    subst.
    assert (forall xs, e \in e :: xs).
    intros.
    simpl. auto.
    auto.
    split.
    assumption.
    Case "x \notin E".
    unfold not in H.
    assert (x \in E -> False).
    intros.
    apply H.
    apply in_cons.
    assumption.
    unfold not.
    assumption.
Qed.

Section Environment.

    Variable A: Type.

    (** The function [get x E] retrieves the first binding of [x] in
        environment [E]. *)

    Fixpoint get (x: atom) (E: list (atom * A)) : option A :=
        match E with
        | nil => None
        | (y,v)::E => if x == y then Some v else get x E
        end.

    (** [binds x v E] holds when [x] is bound to [v] in [E].  [no_binds x E]
        holds when there is no binding for [x] in [E].  *)

    Definition binds x v E : Prop :=
        get x E = Some v.

    Definition no_binds x E : Prop :=
        get x E = None.

    Fact binds_first: forall x (a : A) E, binds x a ((x,a)::E).
    Proof.
      intros.
      unfold binds. simpl.
      apply eq_atom_true.
    Qed.

    Fact binds_other: forall x y (a b : A) E,
        binds y b E -> x <> y -> binds y b ((x,a)::E).
    Proof.
      intros.
      unfold binds in *. simpl.
      rewrite eq_atom_false with (1:=sym_not_eq H0).
      assumption.
    Qed.

    Fact binds_nil: forall x (a : A), ~binds x a nil.
    Proof.
      unfold binds. simpl. intros. discriminate.
    Qed.

    Fact binds_nil2: forall x (a : A), binds x a nil -> False.
    Proof.
      unfold binds. simpl. intros. discriminate.
    Qed.

    Fact binds_fun: forall E x (a b : A),
        binds x a E -> binds x b E -> a = b.
    Proof.
      unfold binds. intros E x a b H H'.
      rewrite H' in H. injection H.
      auto.
    Qed.

    Fact binds_elim_eq: forall x (a b : A) E,
        binds x a ((x,b)::E) -> a = b.
    Proof.
      intros x a b E.
      unfold binds. simpl.
      rewrite eq_atom_true.
      injection 1. auto.
    Qed.

    Fact binds_elim_neq: forall x y (a b : A) E,
        x <> y -> binds x a ((y,b)::E) -> binds x a E.
    Proof.
      intros x y a b E H.
      unfold binds. simpl.
      rewrite eq_atom_false; trivial.
    Qed.

    Fact binds_head : forall x a E F,
        binds x a F -> binds x a (F ++ E).
    Proof.
      intros x a E F.
      unfold binds.
      induction F as [|(y,b)]; simpl; intros H.
      Case "nil". discriminate.
      Case "cons". destruct (x == y); auto.
    Qed.

    Fact binds_nobinds : forall x a E,
        binds x a E -> no_binds x E -> False.
    Proof.
      unfold binds. unfold no_binds. intros.
      rewrite H in H0. discriminate.
    Qed.

    Fact nobinds_nil: forall x, no_binds x nil.
    Proof.
      intros.
      unfold no_binds. reflexivity.
    Qed.

    Fact nobinds_cons: forall x y b E,
        no_binds x E ->
        x <> y ->
        no_binds x ((y,b)::E).
    Proof.
      unfold no_binds. intros.
      simpl.
      rewrite eq_atom_false with (1:=H0).
      assumption.
    Qed.

    Fact nobinds_app: forall x E1 E2,
       no_binds x E1 ->
       no_binds x E2 ->
       no_binds x (E1++E2).
    Proof.
      unfold no_binds. intros.
      induction E1 as [|(y,v)]; simpl.
      Case "nil". assumption.
      Case "cons". destruct (x==y).
        SCase "x=y".
          subst. rewrite binds_first in H. discriminate H.
        SCase "x<>y".
          simpl in H. rewrite eq_atom_false with (1:=n) in H.
          auto.
    Qed.

    Fact nobinds_weaken : forall x y a E,
        no_binds x ((y, a) :: E) ->
        no_binds x E.
    Proof.
        intros.
        induction E.
        apply nobinds_nil.
        destruct a0 as [z b].
        unfold no_binds in H.
        unfold get in H.
        fold get in H.
        destruct (x == y).
        discriminate.
        unfold no_binds.
        unfold get.
        fold get.
        assumption.
    Qed.

    Fact nobinds_split_app : forall x E F,
        no_binds x (E ++ F) ->
        no_binds x E /\ no_binds x F.
    Proof.
        intros.
        induction E.
        - (* nil *)
        split.
        apply nobinds_nil.
        rewrite app_nil_l in H.
        assumption.
        - (* cons *)
        destruct a as [y a].
        destruct (x == y).
        + (* x = y *)
        subst.
        unfold no_binds in H.
        unfold get in H.
        simpl in H.
        rewrite eq_atom_true in H.
        discriminate.
        + (* x <> y *)
        assert (no_binds x E /\ no_binds x F).
        apply IHE.
        apply nobinds_weaken with (y:=y) (a:=a).
        assumption.
        split.
        apply nobinds_cons.
        tauto.
        tauto.
        tauto.
    Qed.

    (** The functions [keys E] and [dom E] retrieve the atoms that are bound in
        the environment [E]. *)

    Definition keys (E: list (atom * A)) : list atom :=
        List.map (fun p => match p with (x,_) => x end) E.

    Definition dom := keys.

    Fact dom_binds: forall (E : list (atom * A)) (x : atom),
        x \in dom E -> exists v:A, binds x v E.
    Proof.
      intros.
      induction E as [| (u, v) E]; simpl in H.
      Case "nil". contradiction.
      Case "cons".
        unfold binds in *. simpl in *.
        destruct (x == u); [ eauto | apply IHE ].
        destruct H; [ symmetry in H; contradiction | apply H ].
    Qed.

    Fact binds_In : forall a x E,
        binds x a E -> x \in dom E.
    Proof.
      intros.
      induction E as [| (u, v) E].
      Case "nil". contradiction (binds_nil H).
      Case "cons".
        unfold binds in *. simpl in *.
        destruct (x == u); auto.
    Qed.

    Fact dom_binds_neg: forall (E : list (atom * A)) (x : atom),
        x \notin dom E -> get x E = None.
    Proof.
      intros.
      induction E as [| (u, v) E].
      Case "nil". reflexivity.
      Case "cons".
        simpl in *.
        destruct (x == u); [ contradiction H | apply IHE ]; auto.
    Qed.

    Fact dom_distribute_cons : forall (E : list (atom * A)) (x : atom) (a : A),
        dom ((x, a) :: E) = x :: dom E.
    Proof.
        intros.
        simpl.
        reflexivity.
    Qed.

    (** The function [imgs E] retrieves the values in [E]. [map f E] applies
        [f] to the values in [E]. *)

    Definition imgs (E: list (atom * A)) : list A :=
        List.map (fun p => match p with (_,v) => v end) E.

    Definition map (B: Type) (f: A -> B) (E: list (atom * A)) : list (atom * B) :=
        List.map (fun p => match p with (x,v) => (x, f v) end) E.

    (** [ok E] holds when the environment [E] contains no duplicate bindings. *)

    Inductive ok: list (atom * A) -> Prop :=
    | ok_nil: ok nil
    | ok_cons: forall E x v, ok E -> no_binds x E -> ok ((x,v)::E).

    Fact binds_concat_ok : forall x a E F,
      binds x a E -> ok (F ++ E) -> binds x a (F ++ E).
    Proof.
      intros x a E F.
      induction F as [|(y,b)]; simpl; intros H Ok.
      Case "nil". assumption.
      Case "cons".
        inversion Ok. subst.
        destruct (y == x).
        SCase "x=y".
          subst.
          contradiction binds_nobinds with (a:=a) (2:=H4).
          eauto.
        SCase "x<>y".
          apply binds_other; [ auto | assumption ].
    Qed.

    Fact binds_concat_ok_2 : forall x a E F,
      binds x a F -> ok (F ++ E) -> binds x a (F ++ E).
    Proof.
      intros x a E F.
      induction E as [|(y,b)]; simpl; intros H Ok.
      Case "nil".  rewrite app_nil_r. assumption.
      Case "cons".
        inversion Ok.
        + (* ok nil *)
        exfalso.
        symmetry in H1.
        apply app_eq_nil in H1.
        absurd ((y, b) :: E = nil).
        discriminate.
        tauto.
        + (* ok  (F ++ (y, b) :: E) *)
        rewrite H0.
        apply binds_head.
        assumption.
    Qed.

    Fact binds_weaken : forall x a E F G,
      binds x a (G ++ E) ->
      ok (G ++ F ++ E) ->
      binds x a (G ++ F ++ E).
    Proof.
      induction G as [|(y,b)]; simpl; intros H Ok.
      Case "nil". apply binds_concat_ok; assumption.
      Case "cons".
        inversion Ok. subst.
        destruct (y == x).
        SCase "x=y".
          subst.
          rewrite binds_elim_eq with (1:=H).
          apply binds_first.
        SCase "x<>y".
          apply binds_other with (2:=n).
          apply IHG; [ eauto using binds_elim_neq | assumption ].
    Qed.

    Fact ok_split_app : forall E F,
        ok (F ++ E) ->
        ok F /\ ok E.
    Proof.
        intros.
        induction F.
        - (* nil *)
        split.
        exact ok_nil.
        rewrite app_nil_l in H.
        assumption.
        - (* cons *)
        inversion H.
        subst.
        assert (ok F /\ ok E).
        apply IHF. assumption.
        destruct H0.
        split.
        + (* F *)
        apply ok_cons.
        assumption.
        exact (proj1 (nobinds_split_app _ _ H3)).
        + (* E *)
        assumption.
    Qed.

    Fact ok_disjoint_app : forall a b x y E F,
        binds x a E ->
        binds y b F ->
        ok (E ++ F) ->
        x <> y.
    Proof.
      intros.
      induction E.
      - (* nil *)
      exfalso. eapply binds_nil. apply H.
      - (* cons *)
      destruct a0 as [z a'].
      destruct (z == x).
      + (* z = x, x in head of E *)
      subst.
      rewrite <- app_comm_cons in H1.  (* (x :: E) ++ F = x :: (E ++ F) *)
      inversion H1.
      subst.

      assert (H_y : binds y b (E ++ F)).
      apply binds_concat_ok; assumption; assumption.
      unfold no_binds in H6.
      unfold binds in H_y.
      unfold not. intros.
      rewrite H2 in H6.
      rewrite H6 in H_y.
      absurd (None = Some b).
      discriminate.
      discriminate.
      + (* z <> x *)
      apply IHE.
      eapply binds_elim_neq with (y := z).
      *
      unfold not.
      intros.
      symmetry in H2.
      contradiction.
      *
      exact H.
      *
      rewrite <- app_comm_cons in H1.  (* (x :: E) ++ F = x :: (E ++ F) *)
      rewrite cons_app_equiv in H1.
      eapply ok_split_app.
      exact H1.
    Qed.

    Fact ok_binds_cons : forall x a F,
        ok ((x, a) :: F) ->
        binds x a ((x, a) :: F) ->
        no_binds x F.
    Proof.
        intros.
        inversion H.
        subst.
        assumption.
    Qed.

    Fact ok_binds_once : forall x a E F,
        ok (E ++ F) ->
        binds x a E ->
        no_binds x F.
    Proof.
        intros.
        induction E.
        apply binds_nil in H0.
        exfalso. auto.

        destruct a0 as [y b].
        destruct (y == x).
        subst.

    Admitted.

   (** [forall_env P E] holds when proposition [P x v] holds for all bindings
       [(x, v)] in environment [E]. *)

    Variable P: atom -> A -> Prop.

    Inductive forall_env : list (atom * A) -> Prop :=
    | fa_nil: forall_env nil
    | fa_cons: forall E x v, forall_env E -> P x v -> forall_env ((x,v)::E).

    Hint Constructors forall_env.

    Fact fa_single: forall x a, P x a -> forall_env ((x,a)::nil).
    Proof.
      auto.
    Qed.

    Fact fa_app: forall E F,
        forall_env E -> forall_env F -> forall_env (E++F).
    Proof.
      intros; induction H; simpl; auto.
    Qed.

    Fact fa_weaken: forall E F G,
        forall_env (E++F++G) -> forall_env (E++G).
    Proof.
      intros; induction E as [| (y,a)]; simpl.
      Case "nil".
        induction F as [| (y,a)].
        SCase "nil". trivial.
        SCase "cons". apply IHF. inversion H. subst. assumption.
      Case "cons". inversion H. subst. auto.
    Qed.

    Fact fa_binds_elim: forall x a E,
        binds x a E -> forall_env E -> P x a.
    Proof.
      intros; induction H0.
      Case "fa_nil". contradiction (binds_nil H).
      Case "fa_cons". destruct (x == x0).
        SCase "x = x0". subst. rewrite (binds_elim_eq H). assumption.
        SCase "x <> x0". eauto using binds_elim_neq.
    Qed.

End Environment.

Unset Implicit Arguments.
Hint Constructors ok.
Hint Constructors forall_env.
Implicit Arguments fa_nil [A].

Hint Resolve
    binds_first
    binds_other
    binds_nil
    binds_nil2
    binds_fun
    binds_elim_eq
    binds_elim_neq
    binds_head
    binds_nobinds
    nobinds_nil
    nobinds_cons
    nobinds_app
    nobinds_weaken
    nobinds_split_app
    dom_binds
    binds_In
    dom_binds_neg
    dom_distribute_cons
    binds_concat_ok
    binds_concat_ok_2
    binds_weaken
    ok_split_app
    ok_disjoint_app
    ok_binds_cons.

    (* Summaries
    Fact binds_first: forall x (a : A) E, binds x a ((x,a)::E).
    Fact binds_other: forall x y (a b : A) E,
        binds y b E -> x <> y -> binds y b ((x,a)::E).
    Fact binds_nil: forall x (a : A), ~binds x a nil.

    Fact binds_fun: forall E x (a b : A),
        binds x a E -> binds x b E -> a = b.
    Fact binds_elim_eq: forall x (a b : A) E,
        binds x a ((x,b)::E) -> a = b.
    Fact binds_elim_neq: forall x y (a b : A) E,
        x <> y -> binds x a ((y,b)::E) -> binds x a E.
    Fact binds_head : forall x a E F,
        binds x a F -> binds x a (F ++ E).
    Fact binds_nobinds : forall x a E,
        binds x a E -> no_binds x E -> False.

    Fact nobinds_nil: forall x, no_binds x nil.

    Fact nobinds_cons: forall x y b E,
        no_binds x E ->
        x <> y ->
        no_binds x ((y,b)::E).

    Fact nobinds_app: forall x E1 E2,
       no_binds x E1 ->
       no_binds x E2 ->
       no_binds x (E1++E2).

    Fact nobinds_weaken : forall x y a E,
        no_binds x ((y, a) :: E) ->
        no_binds x E.

    Fact nobinds_split_app : forall x E F,
        no_binds x (E ++ F) ->
        no_binds x E /\ no_binds x F.
    Fact dom_binds: forall (E : list (atom * A)) (x : atom),
        x \in dom E -> exists v:A, binds x v E.
    Fact binds_In : forall a x E,
        binds x a E -> x \in dom E.
    Fact dom_binds_neg: forall (E : list (atom * A)) (x : atom),
        x \notin dom E -> get x E = None.

    Fact dom_distribute_cons : forall (E : list (atom * A)) (x : atom) (a : A),
        dom ((x, a) :: E) = x :: dom E.

    Fact binds_concat_ok : forall x a E F,
      binds x a E -> ok (F ++ E) -> binds x a (F ++ E).

    Fact binds_concat_ok_2 : forall x a E F,
      binds x a F -> ok (F ++ E) -> binds x a (F ++ E).

    Fact binds_weaken : forall x a E F G,
      binds x a (G ++ E) ->
      ok (G ++ F ++ E) ->
      binds x a (G ++ F ++ E).

    Fact ok_split_app : forall E F,
        ok (F ++ E) ->
        ok F /\ ok E.
    Fact ok_disjoint_app : forall a b x y E F,
        binds x a E ->
        binds y b F ->
        ok (E ++ F) ->
        x <> y.

    Fact ok_binds_cons : forall x a F,
        ok ((x, a) :: F) ->
        binds x a ((x, a) :: F) ->
        no_binds x F.
    Fact fa_single: forall x a, P x a -> forall_env ((x,a)::nil).
    Fact fa_app: forall E F,
        forall_env E -> forall_env F -> forall_env (E++F).
    Fact fa_weaken: forall E F G,
        forall_env (E++F++G) -> forall_env (E++G).
    Fact fa_binds_elim: forall x a E,
        binds x a E -> forall_env E -> P x a.
    *)

Set Implicit Arguments.

(** [env_zip aenv bs benv] will match up environment [aenv] with the value list
    [bs] to produce the environment [benv]. *)

Inductive env_zip (A: Type) (B: Type) : list (atom * A) -> list B -> list (atom * B) -> Prop :=
| z_nil : env_zip nil nil nil
| z_cons : forall x a b aenv bs benv,
    env_zip aenv bs benv ->
    env_zip ((x,a)::aenv) (b::bs) ((x,b)::benv).

Hint Constructors env_zip.

Unset Implicit Arguments.