Section StaticScopes.
Require Import Functions.
Require Import ZArith.
Open Scope Z_scope.

(* Expressions with de Bruijn indices at p.97 and p.100 *)
(* The indices are 0-besed, unlike the definition in the text *)
Inductive DBExp : Set :=
    | DBEInt    : Z -> DBExp
    | DBEBool   : bool -> DBExp
    | DBEVar    : nat -> DBExp
    | DBEPlus   : DBExp -> DBExp -> DBExp
    | DBEMinus  : DBExp -> DBExp -> DBExp
    | DBETimes  : DBExp -> DBExp -> DBExp
    | DBELt     : DBExp -> DBExp -> DBExp
    | DBEIf     : DBExp -> DBExp -> DBExp -> DBExp
    | DBELet    : DBExp -> DBExp -> DBExp
    | DBEFun    : DBExp -> DBExp
    | DBEApp    : DBExp -> DBExp -> DBExp
    | DBELetRec : DBExp -> DBExp -> DBExp.

(* Values and environments *)
Inductive DBValue : Set :=
    | DBVInt    : Z -> DBValue
    | DBVBool   : bool -> DBValue
    | DBVFun    : DBValueList -> DBExp -> DBValue
    | DBVRecFun : DBValueList -> DBExp -> DBValue
    with DBValueList : Set :=
    | DBVLNil  : DBValueList
    | DBVLCons : DBValueList -> DBValue -> DBValueList.

(* Variable list at p.97 *)
Inductive VarList : Set :=
    | VLNil  : VarList
    | VLCons : VarList -> Var -> VarList.

(* Fig 6.1, 6.2 *)
Inductive TransTo : VarList -> Exp -> DBExp -> Prop :=
    | Tr_Int    : forall (X : VarList) (i : Z),
                  TransTo X (EInt i) (DBEInt i)
    | Tr_Bool   : forall (X : VarList) (b : bool),
                  TransTo X (EBool b) (DBEBool b)
    | Tr_If     : forall (X : VarList) (e1 e2 e3 : Exp) (d1 d2 d3 : DBExp),
                  TransTo X e1 d1 -> TransTo X e2 d2 -> TransTo X e3 d3 ->
                  TransTo X (EIf e1 e2 e3) (DBEIf d1 d2 d3)
    | Tr_Plus   : forall (X : VarList) (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo X e1 d1 -> TransTo X e2 d2 ->
                  TransTo X (EPlus e1 e2) (DBEPlus d1 d2)
    | Tr_Minus  : forall (X : VarList) (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo X e1 d1 -> TransTo X e2 d2 ->
                  TransTo X (EMinus e1 e2) (DBEMinus d1 d2)
    | Tr_Times  : forall (X : VarList) (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo X e1 d1 -> TransTo X e2 d2 ->
                  TransTo X (ETimes e1 e2) (DBETimes d1 d2)
    | Tr_Lt     : forall (X : VarList) (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo X e1 d1 -> TransTo X e2 d2 ->
                  TransTo X (ELt e1 e2) (DBELt d1 d2)
    | Tr_Var1   : forall (X : VarList) (x : Var),
                  TransTo (VLCons X x) (EVar x) (DBEVar O)
    | Tr_Var2   : forall (X : VarList) (x y : Var) (n1 : nat),
                  y <> x -> TransTo X (EVar x) (DBEVar n1) ->
                  TransTo (VLCons X y) (EVar x) (DBEVar (S n1))
    | Tr_Let    : forall (X : VarList) (x : Var) (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo X e1 d1 -> TransTo (VLCons X x) e2 d2 ->
                  TransTo X (ELet x e1 e2) (DBELet d1 d2)
    | Tr_Fun    : forall (X : VarList) (x : Var) (e : Exp) (d : DBExp),
                  TransTo (VLCons X x) e d ->
                  TransTo X (EFun x e) (DBEFun d)
    | Tr_App    : forall (X : VarList) (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo X e1 d1 -> TransTo X e2 d2 ->
                  TransTo X (EApp e1 e2) (DBEApp d1 d2)
    | Tr_LetRec : forall (X : VarList) (x y : Var)
                         (e1 e2 : Exp) (d1 d2 : DBExp),
                  TransTo (VLCons (VLCons X x) y) e1 d1 ->
                  TransTo (VLCons X x) e2 d2 ->
                  TransTo X (ELetRec x y e1 e2) (DBELetRec d1 d2).

(* V[n] = w of at p.100 *)
Inductive nth_val : DBValueList -> nat -> DBValue -> Prop :=
    | NV_O : forall (V : DBValueList) (w : DBValue),
             nth_val (DBVLCons V w) O w
    | NV_S : forall (V : DBValueList) (n : nat) (w w0 : DBValue),
             nth_val V n w ->
             nth_val (DBVLCons V w0) (S n) w.

(* Fig 6.3, 6.4 *)
Inductive DBEvalTo : DBValueList -> DBExp -> DBValue -> Prop :=
    | DBE_Int    : forall (V : DBValueList) (i : Z),
                   DBEvalTo V (DBEInt i) (DBVInt i)
    | DBE_Bool   : forall (V : DBValueList) (b : bool),
                   DBEvalTo V (DBEBool b) (DBVBool b)
    | DBE_IfT    : forall (V : DBValueList) (d1 d2 d3 : DBExp) (w : DBValue),
                   DBEvalTo V d1 (DBVBool true) -> DBEvalTo V d2 w ->
                   DBEvalTo V (DBEIf d1 d2 d3) w
    | DBE_IfF    : forall (V : DBValueList) (d1 d2 d3 : DBExp) (w : DBValue),
                   DBEvalTo V d1 (DBVBool false) -> DBEvalTo V d3 w ->
                   DBEvalTo V (DBEIf d1 d2 d3) w
    | DBE_Plus   : forall (V : DBValueList) (d1 d2 : DBExp) (i1 i2 i3 : Z),
                   DBEvalTo V d1 (DBVInt i1) -> DBEvalTo V d2 (DBVInt i2) ->
                   Plus i1 i2 i3 ->
                   DBEvalTo V (DBEPlus d1 d2) (DBVInt i3)
    | DBE_Minus  : forall (V : DBValueList) (d1 d2 : DBExp) (i1 i2 i3 : Z),
                   DBEvalTo V d1 (DBVInt i1) -> DBEvalTo V d2 (DBVInt i2) ->
                   Minus i1 i2 i3 ->
                   DBEvalTo V (DBEMinus d1 d2) (DBVInt i3)
    | DBE_Times  : forall (V : DBValueList) (d1 d2 : DBExp) (i1 i2 i3 : Z),
                   DBEvalTo V d1 (DBVInt i1) -> DBEvalTo V d2 (DBVInt i2) ->
                   Times i1 i2 i3 ->
                   DBEvalTo V (DBETimes d1 d2) (DBVInt i3)
    | DBE_Lt     : forall (V : DBValueList) (d1 d2 : DBExp)
                          (i1 i2 : Z) (b3 : bool),
                   DBEvalTo V d1 (DBVInt i1) -> DBEvalTo V d2 (DBVInt i2) ->
                   Lt i1 i2 b3 ->
                   DBEvalTo V (DBELt d1 d2) (DBVBool b3)
    | DBE_Var    : forall (V : DBValueList) (n : nat) (w : DBValue),
                   nth_val V n w ->
                   DBEvalTo V (DBEVar n) w
    | DBE_Let    : forall (V : DBValueList) (d1 d2 : DBExp) (w w1 : DBValue),
                   DBEvalTo V d1 w1 -> DBEvalTo (DBVLCons V w1) d2 w ->
                   DBEvalTo V (DBELet d1 d2) w
    | DBE_Fun    : forall (V : DBValueList) (d : DBExp),
                   DBEvalTo V (DBEFun d) (DBVFun V d)
    | DBE_App    : forall (V V2 : DBValueList) (d1 d2 d0 : DBExp)
                          (w w2 : DBValue),
                   DBEvalTo V d1 (DBVFun V2 d0) -> DBEvalTo V d2 w2 ->
                   DBEvalTo (DBVLCons V2 w2) d0 w ->
                   DBEvalTo V (DBEApp d1 d2) w
    | DBE_LetRec : forall (V : DBValueList) (d1 d2 : DBExp) (w : DBValue),
                   DBEvalTo (DBVLCons V (DBVRecFun V d1)) d2 w ->
                   DBEvalTo V (DBELetRec d1 d2) w
    | DBE_AppRec : forall (V V2 : DBValueList) (d1 d2 d0 : DBExp)
                          (w w2 : DBValue),
                   DBEvalTo V d1 (DBVRecFun V2 d0) -> DBEvalTo V d2 w2 ->
                   DBEvalTo (DBVLCons (DBVLCons V2 (DBVRecFun V2 d0)) w2) d0 w ->
                   DBEvalTo V (DBEApp d1 d2) w.

(* Fig 6.5 *)
Inductive TransValTo : Value -> DBValue -> Prop :=
    | Trv_Int  : forall i : Z, TransValTo (VInt i) (DBVInt i)
    | Trv_Bool : forall b : bool, TransValTo (VBool b) (DBVBool b)
    | Trv_Fun  : forall (E : Env) (X : VarList) (V : DBValueList) (x : Var)
                        (e : Exp) (d : DBExp),
                 TransEnvTo E X V -> TransTo (VLCons X x) e d ->
                 TransValTo (VFun E x e) (DBVFun V d)
    | Trv_Rec  : forall (E : Env) (X : VarList) (V : DBValueList) (x y : Var)
                        (e : Exp) (d : DBExp),
                 TransEnvTo E X V -> TransTo (VLCons (VLCons X x) y) e d ->
                 TransValTo (VRecFun E x y e) (DBVRecFun V d)
    with TransEnvTo : Env -> VarList -> DBValueList -> Prop :=
    | Tre_Empty : TransEnvTo ENil VLNil DBVLNil
    | Tre_Bind  : forall (E : Env) (X : VarList) (V : DBValueList)
                         (x : Var) (v : Value) (w : DBValue),
                  TransEnvTo E X V -> TransValTo v w ->
                  TransEnvTo (ECons E x v) (VLCons X x) (DBVLCons V w).

(* Theorem 6.1 (1) *)
Theorem EvalTo_DBEvalTo_compat :
    forall (E : Env) (X : VarList) (V : DBValueList)
           (e : Exp) (d : DBExp) (v : Value),
    TransEnvTo E X V -> TransTo X e d -> EvalTo E e v ->
    exists w : DBValue, (DBEvalTo V d w /\ TransValTo v w).
Proof.
    intros E X V e d v Htre Htr He.
    generalize dependent d.
    generalize dependent V.
    generalize dependent X.
    induction He as [ E i | E b | E x v | E x y v1 v2 Hneq Hv2 Hx |
                      E e1 e2 e3 i1 i2 i3 He1 He1' He2 He2' Hp |
                      E e1 e2 e3 i1 i2 i3 He1 He1' He2 He2' Hm |
                      E e1 e2 e3 i1 i2 i3 He1 He1' He2 He2' Ht |
                      E e1 e2 i1 i2 b3 He1 He1' He2 He2' Hl |
                      E e1 e2 e3 v2 He1 He1' He2 He2' |
                      E e1 e2 e3 v2 He1 He1' He3 He3' |
                      E e1 e2 x v1 v He1 He1' He2 He2' | E x e |
                      E E2 e1 e2 e0 x v v' He1 He1' He2 He2' He0 He0' |
                      E x y e1 e2 v He2 He2' |
                      E E2 e1 e2 e0 x y v v' He1 He1' He2 He2' He0 He0' ].

        (* Case : He is from E_Int *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        exists (DBVInt i).
        apply (conj (DBE_Int _ _) (Trv_Int _)).

        (* Case : He is from E_Bool *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        exists (DBVBool b).
        apply (conj (DBE_Bool _ _) (Trv_Bool _)).

        (* Case : He if from E_Var1 *)
        intros X V Htre d Htr.
        inversion Htr; subst.

            (* Case : Htr is from Tr_Var1 *)
            inversion Htre; subst.
            exists w.
            apply (conj (DBE_Var _ _ _ (NV_O _ _)) H5).

            (* Case : Htr is from Tr_Var2 *)
            inversion Htre; subst.
            contradict H0.
            reflexivity.

        (* Case : He is from E_Var2 *)
        intros X V Htre d Htr.
        inversion Htr; subst.

            (* Case : Htr is from Tr_Var1 *)
            inversion Htre; subst.
            contradict Hneq.
            reflexivity.

            (* Case : Htr is from Tr_Var2 *)
            inversion Htre; subst.
            specialize (Hx _ _ H7 _ H2).
            destruct Hx as [w' [Hw' Hx]].
            exists w'.
            inversion Hw'; subst.
            apply (conj (DBE_Var _ _ _ (NV_S _ _ _ _ H3)) Hx).

        (* Case : He is from E_Plus *)
        intros X V Htre d Htr.
        exists (DBVInt i3).
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H2).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre d2 H4).
        destruct He2' as [w2 [Hw2 He2']].
        inversion He2'; subst.
        apply (conj (DBE_Plus _ _ _ _ _ _ Hw1 Hw2 Hp)
                    (Trv_Int _)).

        (* Case : He is from E_Minus *)
        intros X V Htre d Htr.
        exists (DBVInt i3).
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H2).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre d2 H4).
        destruct He2' as [w2 [Hw2 He2']].
        inversion He2'; subst.
        apply (conj (DBE_Minus _ _ _ _ _ _ Hw1 Hw2 Hm)
                    (Trv_Int _)).

        (* Case : He is from E_Times *)
        intros X V Htre d Htr.
        exists (DBVInt i3).
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H2).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre d2 H4).
        destruct He2' as [w2 [Hw2 He2']].
        inversion He2'; subst.
        apply (conj (DBE_Times _ _ _ _ _ _ Hw1 Hw2 Ht)
                    (Trv_Int _)).

        (* Case : He is from E_Lt *)
        intros X V Htre d Htr.
        exists (DBVBool b3).
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H2).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre d2 H4).
        destruct He2' as [w2 [Hw2 He2']].
        inversion He2'; subst.
        apply (conj (DBE_Lt _ _ _ _ _ _ Hw1 Hw2 Hl)
                    (Trv_Bool _)).

        (* Case : He is from E_IfT *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H3).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre d2 H5).
        destruct He2' as [w2 [Hw2 He2']].
        exists w2.
        apply (conj (DBE_IfT _ _ _ _ _ Hw1 Hw2) He2').

        (* Case : He is from E_IfF *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H3).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He3' _ _ Htre d3 H6).
        destruct He3' as [w3 [Hw3 He3']].
        exists w3.
        apply (conj (DBE_IfF _ _ _ _ _ Hw1 Hw3) He3').

        (* Case : He is from E_Let *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H4).
        destruct He1' as [w1 [Hw1 He1']].
        specialize (He2' _ _ (Tre_Bind _ _ _ _ _ _ Htre He1') d2 H5).
        destruct He2' as [w2 [Hw2 He2']].
        exists w2.
        apply (conj (DBE_Let _ _ _ _ _ Hw1 Hw2) He2').

        (* Case : He is from E_Fun *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        exists (DBVFun V d0).
        apply (conj (DBE_Fun _ _) ((Trv_Fun _ _ _ _ _ _ Htre H3))).

        (* Case : He is from E_App *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        specialize (He1' _ _ Htre d1 H2).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre d2 H4).
        destruct He2' as [w2 [Hw2 He2']].
        specialize (He0' _ _ (Tre_Bind _ _ _ _ _ _ H5 He2') d H6).
        destruct He0' as [w0 [Hw0 He0']].
        exists w0.
        apply (conj (DBE_App _ V0 _ _ d _ w2 Hw1 Hw2 Hw0) He0').

        (* Case : He is from E_LetRec *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        assert (TransEnvTo (ECons E x (VRecFun E x y e1))
                           (VLCons X x) (DBVLCons V (DBVRecFun V d1))) as Hd1
            by apply (Tre_Bind _ _ _ _ _ _
                               Htre (Trv_Rec _ X _ _ _ _ _ Htre H5)).
        specialize (He2' _ _ Hd1 _ H6).
        destruct He2' as [w2 [Hw2 He2']].
        exists w2.
        apply (conj (DBE_LetRec _ _ _ _ Hw2) He2').

        (* Case : He is from E_AppRec *)
        intros X V Htre d Htr.
        inversion Htr; subst.
        specialize (He1' _ _ Htre _ H2).
        destruct He1' as [w1 [Hw1 He1']].
        inversion He1'; subst.
        specialize (He2' _ _ Htre _ H4).
        destruct He2' as [w2 [Hw2 He2']].
        assert (TransEnvTo (ECons (ECons E2 x (VRecFun E2 x y e0)) y v')
                           (VLCons (VLCons X0 x) y)
                           (DBVLCons (DBVLCons V0 (DBVRecFun V0 d)) w2)) as Hd.

            (* Proof of the assertion *)
            refine (Tre_Bind _ _ _ _ _ _ _ He2').
            apply (Tre_Bind _ _ _ _ _ _ H6 (Trv_Rec _ _ _ _ _ _ _ H6 H7)).

        specialize (He0' _ _ Hd _ H7).
        destruct He0' as [w0 [Hw0 He0']].
        exists w0.
        apply (conj (DBE_AppRec _ _ _ _ _ _ _ Hw1 Hw2 Hw0) He0').
Qed.

(* Theorem 6.1 (2) *)
Theorem DBEvalTo_EvalTo_compat :
    forall (E : Env) (X : VarList) (V : DBValueList)
           (e : Exp) (d : DBExp) (w : DBValue),
    TransEnvTo E X V -> TransTo X e d -> DBEvalTo V d w ->
    exists v : Value, (EvalTo E e v /\ TransValTo v w).
Proof.
    intros E X V e d w Htre Htr Hd.
    generalize dependent e.
    generalize dependent X.
    generalize dependent E.
    induction Hd as [ V i | V b |
                      V d1 d2 d3 w Hd1 Hd1' Hd2 Hd2' |
                      V d1 d2 d3 w Hd1 Hd1' Hd3 Hd3' |
                      V d1 d2 i1 i2 i3 Hd1 Hd1' Hd2 Hd2' Hp |
                      V d1 d2 i1 i2 i3 Hd1 Hd1' Hd2 Hd2' Hm |
                      V d1 d2 i1 i2 i3 Hd1 Hd1' Hd2 Hd2' Ht |
                      V d1 d2 i1 i2 b3 Hd1 Hd1' Hd2 Hd2' Hl |
                      V n w Hw | V d1 d2 w w1 Hd1 Hd1' Hd2 Hd2' | V d |
                      V V2 d1 d2 d0 w w2 Hd1 Hd1' Hd2 Hd2' Hd0 Hd0' |
                      V d1 d2 w Hd2 Hd2' |
                      V V2 d1 d2 d0 w w2 Hd1 Hd1' Hd2 Hd2' Hd0 Hd0' ].

        (* Case : Hd is from DBE_Int *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        exists (VInt i).
        apply (conj (E_Int _ _) (Trv_Int _)).

        (* Case : Hd is from DBE_Bool *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        exists (VBool b).
        apply (conj (E_Bool _ _) (Trv_Bool _)).

        (* Case : Hd is from DBE_IfT *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H4).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H5).
        destruct Hd2' as [v2 [Hv2 Hd2']].
        exists v2.
        apply (conj (E_IfT _ _ _ _ _ Hv1 Hv2) Hd2').

        (* Case : Hd is from DBE_IfF *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H4).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd3' _ _ Htre _ H6).
        destruct Hd3' as [v3 [Hv3 Hd3']].
        exists v3.
        apply (conj (E_IfF _ _ _ _ _ Hv1 Hv3) Hd3').

        (* Case : Hd is from DBE_Plus *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H4).
        destruct Hd2' as [v1 [Hv2 Hd2']].
        inversion Hd2'; subst.
        exists (VInt i3).
        apply (conj (E_Plus _ _ _ (EInt i3) _ _ _ Hv1 Hv2 Hp)
                    (Trv_Int _)).

        (* Case : Hd is from DBE_Minus *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H4).
        destruct Hd2' as [v1 [Hv2 Hd2']].
        inversion Hd2'; subst.
        exists (VInt i3).
        apply (conj (E_Minus _ _ _ (EInt i3) _ _ _ Hv1 Hv2 Hm)
                    (Trv_Int _)).

        (* Case : Hd is from DBE_Times *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H4).
        destruct Hd2' as [v1 [Hv2 Hd2']].
        inversion Hd2'; subst.
        exists (VInt i3).
        apply (conj (E_Times _ _ _ (EInt i3) _ _ _ Hv1 Hv2 Ht)
                    (Trv_Int _)).

        (* Case : Hd is from DBE_Lt *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H4).
        destruct Hd2' as [v1 [Hv2 Hd2']].
        inversion Hd2'; subst.
        exists (VBool b3).
        apply (conj (E_Lt _ _ _ _ _ b3 Hv1 Hv2 Hl)
                    (Trv_Bool _)).

        (* Case : Hd is from DBE_Var *)
        induction Hw as [V0 w | V0 n0 w0 w Hw Hn0'].

            (* Case : Hw is from NV_O *)
            intros E X Htre e Htr.
            inversion Htr; subst.
            inversion Htre; subst.
            exists v.
            apply (conj (E_Var1 _ _ _) H5).

            (* Case : Hw is from NV_S *)
            intros E X Htre e Htr.
            inversion Htr; subst.
            inversion Htre; subst.
            specialize (Hn0' _ _ H5 _ H3).
            destruct Hn0' as [v0 [Hv0 Hn0']].
            exists v0.
            apply (conj (E_Var2 _ _ _ _ _ (not_eq_sym H0) Hv0) Hn0').

        (* Case : Hd is from DBE_Let *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        specialize (Hd2' _ _ (Tre_Bind _ _ _ _ _ _ Htre Hd1') _ H4).
        destruct Hd2' as [v2 [Hv2 Hd2']].
        exists v2.
        apply (conj (E_Let _ _ _ _ _ _ Hv1 Hv2) Hd2').

        (* Case : Hd is from DBE_Fun *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        exists (VFun E x e0).
        apply (conj (E_Fun _ _ _) (Trv_Fun _ _ _ _ _ _ Htre H2)).

        (* Case : Hd is from DBE_App *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H4).
        destruct Hd2' as [v2 [Hv2 Hd2']].
        specialize (Hd0' _ _ (Tre_Bind _ _ _ _ _ _ H2 Hd2') _ H5).
        destruct Hd0' as [v0 [Hv0 Hd0']].
        exists v0.
        apply (conj (E_App _ _ _ _ _ _ _ _ Hv1 Hv2 Hv0) Hd0').

        (* Case : Hd is from DBE_LetRec *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd2' _ _ (Tre_Bind _ _ _ _ _ _ Htre
                              (Trv_Rec _ _ _ _ _ _ _ Htre H3))
                         _ H4).
        destruct Hd2' as [v2 [Hv2 Hd2']].
        exists v2.
        apply (conj (E_LetRec _ _ _ _ _ _ Hv2) Hd2').

        (* Case : Hd is from DBE_AppRec *)
        intros E X Htre e Htr.
        inversion Htr; subst.
        specialize (Hd1' _ _ Htre _ H3).
        destruct Hd1' as [v1 [Hv1 Hd1']].
        inversion Hd1'; subst.
        specialize (Hd2' _ _ Htre _ H4).
        destruct Hd2' as [v2 [Hv2 Hd2']].
        assert (TransEnvTo (ECons (ECons E0 x (VRecFun E0 x y e)) y v2)
                           (VLCons (VLCons X0 x) y)
                           (DBVLCons (DBVLCons V2 (DBVRecFun V2 d0)) w2)) as He.

            (* Proof of the assertion *)
            refine (Tre_Bind _ _ _ _ _ _ _ Hd2').
            apply (Tre_Bind _ _ _ _ _ _ H2 Hd1').

        specialize (Hd0' _ _ He _ H5).
        destruct Hd0' as [v0 [Hv0 Hd0']].
        exists v0.
        apply (conj (E_AppRec _ _ _ _ _ _ _ _ _ Hv1 Hv2 Hv0) Hd0').
Qed.

(* Free variables (omitted in the text) *)
Inductive is_FV : Exp -> Var -> Prop :=
    | FV_Var     : forall x : Var, is_FV (EVar x) x
    | FV_Plus_l  : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EPlus e1 e2) x
    | FV_Plus_r  : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EPlus e1 e2) x
    | FV_Minus_l : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EMinus e1 e2) x
    | FV_Minus_r : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EMinus e1 e2) x
    | FV_Times_l : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (ETimes e1 e2) x
    | FV_Times_r : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (ETimes e1 e2) x
    | FV_Lt_l    : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (ELt e1 e2) x
    | FV_Lt_r    : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (ELt e1 e2) x
    | FV_If      : forall (e1 e2 e3 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EIf e1 e2 e3) x
    | FV_IfT     : forall (e1 e2 e3 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EIf e1 e2 e3) x
    | FV_IfF     : forall (e1 e2 e3 : Exp) (x : Var),
                   is_FV e3 x -> is_FV (EIf e1 e2 e3) x
    | FV_Let1    : forall (e1 e2 : Exp) (x y : Var),
                   is_FV e1 x -> is_FV (ELet y e1 e2) x
    | FV_Let2    : forall (e1 e2 : Exp) (x y : Var),
                   is_FV e2 x -> x <> y -> is_FV (ELet y e1 e2) x
    | FV_Fun     : forall (e : Exp) (x y : Var),
                   is_FV e x -> x <> y -> is_FV (EFun y e) x
    | FV_App_l   : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EApp e1 e2) x
    | FV_App_r   : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EApp e1 e2) x
    | FV_LetRec1 : forall (e1 e2 : Exp) (x y z : Var),
                   is_FV e1 x -> is_FV (ELetRec y z e1 e2) x
    | FV_LetRec2 : forall (e1 e2 : Exp) (x y z : Var),
                   is_FV e2 x -> x <> y ->
                   is_FV (ELetRec y z e1 e2) x.

(* Contents of ValueList *)
Inductive in_VL : VarList -> Var -> Prop :=
    | VL_Cons1 : forall (X : VarList) (x : Var), in_VL (VLCons X x) x
    | VL_Cons2 : forall (X : VarList) (x y : Var),
                 in_VL X x -> in_VL (VLCons X y) x.

Lemma Var_eq_dec :
    forall x y : Var, {x = y} + {x <> y}.
Proof.
    intros x y.
    destruct x as [n1].
    destruct y as [n2].
    destruct (eq_nat_dec n1 n2).

        (* Case : n1 = n2 *)
        left.
        subst; reflexivity.

        (* Case : n1 <> n2 *)
        right.
        intro F.
        inversion F.
        contradiction.
Qed.

(* Theorem 6.2 *)
Theorem TransTo_total :
    forall (X : VarList) (e : Exp),
    (forall x : Var, is_FV e x -> in_VL X x) ->
    exists d : DBExp, TransTo X e d.
Proof.
    intros X e.
    generalize dependent X.
    induction e as [ i | b | x |
                     e1 He1 e2 He2 | e1 He1 e2 He2 | e1 He1 e2 He2 |
                     e1 He1 e2 He2 | e1 He1 e2 He2 e3 He3 | x e1 He1 e2 He2 |
                     x e0 He0 | e1 He1 e2 He2 | x y e1 He1 e2 He2 ].

        (* Case : e = EInt i *)
        intros X HFV.
        exists (DBEInt i).
        apply Tr_Int.

        (* Case : e = EBool b *)
        intros X HFV.
        exists (DBEBool b).
        apply Tr_Bool.

        (* Case : e = EVar x *)
        induction X as [| X0 HX0 x0 ].

            (* Case : X = VLNil *)
            intro HFV.
            specialize (HFV x (FV_Var _)).
            inversion HFV.

            (* Case : X = VLCons X0 x0 *)
            intro HFV.
            specialize (HFV x (FV_Var _)).
            destruct (Var_eq_dec x0 x) as [Heq | Hneq].

                (* Case : x0 = x *)
                subst.
                exists (DBEVar 0).
                apply Tr_Var1.

                (* Case : x0 <> x *)
                assert (exists d : DBExp, TransTo X0 (EVar x) d) as Hd.

                    (* Proof of the assertion *)
                    apply HX0.
                    intros x1 Hx1.
                    inversion HFV; subst.

                        (* Case : HFV is from VL_Cons1 *)
                        contradict Hneq.
                        reflexivity.

                        (* Case : HFV is from VL_Cons2 *)
                        inversion Hx1; subst.
                        apply H2.

                destruct Hd as [d Hd].
                inversion Hd; subst.

                    (* Case : Hd is from Tr_Var1 *)
                    exists (DBEVar 1).
                    apply (Tr_Var2 _ _ _ _ Hneq Hd).

                    (* Case : Hd is from Tr_Var2 *)
                    exists (DBEVar (S (S n1))).
                    apply (Tr_Var2 _ _ _ _ Hneq Hd).

        (* Case : e = EPlus e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_Plus_l _ _ _ H1)).

        assert (exists d : DBExp, TransTo X e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            apply (HFV _ (FV_Plus_r _ _ _ H2)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBEPlus d1 d2).
        apply (Tr_Plus _ _ _ _ _ Hd1 Hd2).

        (* Case : e = EMinus e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_Minus_l _ _ _ H1)).

        assert (exists d : DBExp, TransTo X e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            apply (HFV _ (FV_Minus_r _ _ _ H2)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBEMinus d1 d2).
        apply (Tr_Minus _ _ _ _ _ Hd1 Hd2).

        (* Case : e = ETimes e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_Times_l _ _ _ H1)).

        assert (exists d : DBExp, TransTo X e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            apply (HFV _ (FV_Times_r _ _ _ H2)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBETimes d1 d2).
        apply (Tr_Times _ _ _ _ _ Hd1 Hd2).

        (* Case : e = ELt e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_Lt_l _ _ _ H1)).

        assert (exists d : DBExp, TransTo X e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            apply (HFV _ (FV_Lt_r _ _ _ H2)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBELt d1 d2).
        apply (Tr_Lt _ _ _ _ _ Hd1 Hd2).

        (* Case : e = EIf e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_If _ _ _ _ H1)).

        assert (exists d : DBExp, TransTo X e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            apply (HFV _ (FV_IfT _ _ _ _ H2)).

        assert (exists d : DBExp, TransTo X e3 d) as Hd3.

            (* Proof of the assertion *)
            apply He3.
            intros x0 H3.
            apply (HFV _ (FV_IfF _ _ _ _ H3)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        destruct Hd3 as [d3 Hd3].
        exists (DBEIf d1 d2 d3).
        apply (Tr_If _ _ _ _ _ _ _ Hd1 Hd2 Hd3).

        (* Case : e = ELet e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_Let1 _ _ _ _ H1)).

        assert (exists d : DBExp, TransTo (VLCons X x) e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            destruct (Var_eq_dec x0 x) as [Heq | Hneq].

                (* Case : x0 = x *)
                subst.
                apply VL_Cons1.

                (* Case : x0 <> x *)
                apply VL_Cons2.
                apply (HFV _ (FV_Let2 _ _ _ _ H2 Hneq)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBELet d1 d2).
        apply (Tr_Let _ _ _ _ _ _ Hd1 Hd2).

        (* Case : e = EFun x e0 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo (VLCons X x) e0 d) as Hd0.

            (* Proof of the assertion *)
            apply He0.
            intros x0 H0.
            destruct (Var_eq_dec x0 x) as [Heq | Hneq].

                (* Case : x0 = x *)
                subst.
                apply VL_Cons1.

                (* Case : x0 <> x *)
                apply VL_Cons2.
                apply (HFV _ (FV_Fun _ _ _ H0 Hneq)).

        destruct Hd0 as [d0 Hd0].
        exists (DBEFun d0).
        apply (Tr_Fun _ _ _ _ Hd0).

        (* Case : e = EApp e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo X e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            apply (HFV _ (FV_App_l _ _ _ H1)).

        assert (exists d : DBExp, TransTo X e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            apply (HFV _ (FV_App_r _ _ _ H2)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBEApp d1 d2).
        apply (Tr_App _ _ _ _ _ Hd1 Hd2).

        (* Case : e = ELetRec x y e1 e2 *)
        intros X HFV.
        assert (exists d : DBExp, TransTo (VLCons (VLCons X x) y) e1 d) as Hd1.

            (* Proof of the assertion *)
            apply He1.
            intros x0 H1.
            repeat apply VL_Cons2.
            apply (HFV _ (FV_LetRec1 _ _ _ _ _ H1)).

        assert (exists d : DBExp, TransTo (VLCons X x) e2 d) as Hd2.

            (* Proof of the assertion *)
            apply He2.
            intros x0 H2.
            destruct (Var_eq_dec x0 x) as [Heq | Hneq].

                (* Case : x0 = x *)
                subst.
                apply VL_Cons1.

                (* Case : x0 <> x *)
                apply VL_Cons2.
                apply (HFV _ (FV_LetRec2 _ _ _ _ _ H2 Hneq)).

        destruct Hd1 as [d1 Hd1].
        destruct Hd2 as [d2 Hd2].
        exists (DBELetRec d1 d2).
        apply (Tr_LetRec _ _ _ _ _ _ _ Hd1 Hd2).
Qed.

(* Theorem 6.3 *)
Theorem TransTo_uniq :
    forall (X : VarList) (e : Exp) (d1 d2 : DBExp),
    TransTo X e d1 -> TransTo X e d2 -> d1 = d2.
Proof.
    intros X e.
    generalize dependent X.
    induction e as [ i | b | x |
                     e1 He1 e2 He2 | e1 He1 e2 He2 | e1 He1 e2 He2 |
                     e1 He1 e2 He2 | e1 He1 e2 He2 e3 He3 | x e1 He1 e2 He2 |
                     x e0 He0 | e1 He1 e2 He2 | x y e1 He1 e2 He2 ].

        (* Case : e = EInt i *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        reflexivity.

        (* Case : e = EBool b *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        reflexivity.

        (* Case : e = EVar x *)
        induction X as [| X0 HX0 x0].

            (* Case : X = VLNil *)
            intros d1 d2 Hd1 Hd2.
            inversion Hd1.

            (* Case : X = VLCons X0 x0 *)
            intros d1 d2 Hd1 Hd2.
            inversion Hd1; subst.

                (* Case : Hd1 is from Tr_Var1 *)
                inversion Hd2; subst.

                    (* Case : Hd2 is from Tr_Var1 *)
                    reflexivity.

                    (* Case : Hd2 is from Tr_Var2 *)
                    contradict H2.
                    reflexivity.

                (* Case : Hd2 is from Tr_Var2 *)
                inversion Hd2; subst.

                    (* Case : Hd2 is from Tr_Var1 *)
                    contradict H2.
                    reflexivity.

                    (* Case : Hd2 is from Tr_Var2 *)
                    specialize (HX0 _ _ H4 H6).
                    inversion HX0; subst.
                    reflexivity.

        (* Case : e = EPlus e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H2 H3); subst.
        specialize (He2 _ _ _ H4 H6); subst.
        reflexivity.

        (* Case : e = EMinus e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H2 H3); subst.
        specialize (He2 _ _ _ H4 H6); subst.
        reflexivity.

        (* Case : e = ETimes e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H2 H3); subst.
        specialize (He2 _ _ _ H4 H6); subst.
        reflexivity.

        (* Case : e = ELt e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H2 H3); subst.
        specialize (He2 _ _ _ H4 H6); subst.
        reflexivity.

        (* Case : e = EIf e1 e2 e3 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H3 H4); subst.
        specialize (He2 _ _ _ H5 H8); subst.
        specialize (He3 _ _ _ H6 H9); subst.
        reflexivity.

        (* Case : e = ELet x e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H4 H6); subst.
        specialize (He2 _ _ _ H5 H7); subst.
        reflexivity.

        (* Case : e = EFun x e0 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He0 _ _ _ H3 H4); subst.
        reflexivity.

        (* Case : e = EApp e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H2 H3); subst.
        specialize (He2 _ _ _ H4 H6); subst.
        reflexivity.

        (* Case : e = ELetRec x y e1 e2 *)
        intros X d1 d2 Hd1 Hd2.
        inversion Hd1; subst.
        inversion Hd2; subst.
        specialize (He1 _ _ _ H5 H7); subst.
        specialize (He2 _ _ _ H6 H8); subst.
        reflexivity.
Qed.

End StaticScopes.


Require Import syntax.
Require Import substitution.
From stdpp Require Import gmap.

(* pg. 140-141 *)

Inductive WellTTyped : gset type -> type -> Prop :=
  | TypT th t : WellTTyped (th ∪ {[Typ t]}) (Typ t)
  | ArrT th tau1 tau2 : WellTTyped th tau1 -> WellTTyped th tau2 -> WellTTyped th (Arr tau1 tau2)
  | AllT th t tau : WellTTyped (th ∪ {[Typ t]}) tau -> WellTTyped th (All t tau)
  .

Inductive WellTyped : gset type -> gmap var type -> expr -> type -> Prop :=
  | VarT th g x tau : WellTyped th (<[x:=tau]>g) (Var x) tau
  | LamT th c e x tau tau' : WellTyped th (<[x:=tau]>c) e tau' -> WellTyped th c (Lam x tau e) (Arr tau tau')
  | AppT th c e1 e2 t t2 : WellTyped th c e1 (Arr t2 t) -> WellTyped th c e2 t2 -> WellTyped th c (App e1 e2) t
  | Lam2T g th e t tau : WellTyped (th ∪ {[Typ t]}) g e tau -> WellTyped th g (Lam2 t e) (All t tau)
  | App2T th g e t tau tau' : WellTyped th g e (All t tau') -> WellTTyped th tau -> WellTyped th g (App2 e tau) (subst_t_t tau' tau t)
  .


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_29.
Require Export GeoCoq.Elements.OriginalProofs.proposition_28A.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_30B :
   forall A B C D E F G H K,
   Par A B E F -> Par C D E F -> BetS G K H -> BetS A G B -> BetS E H F -> BetS C K D -> TS A G H F -> TS C K H F ->
   Par A B C D.
Proof.
intros.
assert (neq G H) by (forward_using lemma_betweennotequal).
assert (neq H G) by (conclude lemma_inequalitysymmetric).
assert (neq K H) by (forward_using lemma_betweennotequal).
assert (neq H K) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists P, (BetS H G P /\ Cong G P G H)) by (conclude lemma_extension);destruct Tf as [P];spliter.
assert (BetS P G H) by (conclude axiom_betweennesssymmetry).
assert (CongA A G H G H F)
 by (apply (proposition_29 A B E F P G H);auto).
assert (BetS P K H) by (conclude lemma_3_5b).
assert (CongA C K H K H F) by (conclude (proposition_29 C D E F P  )).
assert (BetS H K G) by (conclude axiom_betweennesssymmetry).
assert (Out H K G) by (conclude lemma_ray4).
assert (Out H G K) by (conclude lemma_ray5).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (neq H F) by (forward_using lemma_betweennotequal).
assert (Out H F F) by (conclude lemma_ray4).
assert (CongA A G H K H F) by (conclude lemma_equalangleshelper).
assert (CongA K H F A G H) by (conclude lemma_equalanglessymmetric).
assert (CongA C K H A G H) by (conclude lemma_equalanglestransitive).
assert (neq G H) by (forward_using lemma_betweennotequal).
assert (Out G H K) by (conclude lemma_ray4).
assert (neq A G) by (forward_using lemma_betweennotequal).
assert (neq G A) by (conclude lemma_inequalitysymmetric).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Out G A A) by (conclude lemma_ray4).
assert (CongA C K H A G K) by (conclude lemma_equalangleshelper).
assert (CongA H K C K G A) by (conclude lemma_equalanglesflip).
let Tf:=fresh in
assert (Tf:exists M, (BetS A M F /\ Col G H M /\ nCol G H A)) by (conclude_def TS );destruct Tf as [M];spliter.
let Tf:=fresh in
assert (Tf:exists m, (BetS C m F /\ Col K H m /\ nCol K H C)) by (conclude_def TS );destruct Tf as [m];spliter.
assert (Col G K H) by (conclude_def Col ).
assert (Col H G K) by (forward_using lemma_collinearorder).
assert (Col H G M) by (forward_using lemma_collinearorder).
assert (neq H G) by (forward_using lemma_betweennotequal).
assert (Col G K M) by (conclude lemma_collinear4).
assert (Col K G M) by (forward_using lemma_collinearorder).
assert (Col H K m) by (forward_using lemma_collinearorder).
assert (Col H K G) by (forward_using lemma_collinearorder).
assert (neq H K) by (forward_using lemma_betweennotequal).
assert (Col K m G) by (conclude lemma_collinear4).
assert (Col K G m) by (forward_using lemma_collinearorder).
assert (Col G H K) by (forward_using lemma_collinearorder).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (Col G H G) by (conclude_def Col ).
assert (neq G K) by (forward_using lemma_betweennotequal).
assert (nCol G K A) by (conclude lemma_NChelper).
assert (nCol K G A) by (forward_using lemma_NCorder).
assert (Col K H G) by (forward_using lemma_collinearorder).
assert (eq K K) by (conclude cn_equalityreflexive).
assert (Col K H K) by (conclude_def Col ).
assert (neq G K) by (forward_using lemma_betweennotequal).
assert (neq K G) by (conclude lemma_inequalitysymmetric).
assert (nCol K G C) by (conclude lemma_NChelper).
assert (OS A C K G) by (conclude_def OS ).
assert (OS C A K G) by (forward_using lemma_samesidesymmetric).
assert (BetS D K C) by (conclude axiom_betweennesssymmetry).
assert (BetS B G A) by (conclude axiom_betweennesssymmetry).
assert (Par D C B A) by (conclude proposition_28A).
assert (Par C D A B) by (forward_using lemma_parallelflip).
assert (Par A B C D) by (conclude lemma_parallelsymmetric).
close.
Qed.

End Euclid.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, Collège de France and Inria Paris            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Additional operations and proofs about binary integers,
    on top of the ZArith standard library. *)

Require Import Psatz Zquot.
From lib Require Import Coqlib.

(** ** Modulo arithmetic *)

(** We define and state properties of equality and arithmetic modulo a
  positive integer. *)

Section EQ_MODULO.

Variable modul: Z.
Hypothesis modul_pos: modul > 0.

Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y.

Lemma eqmod_refl: forall x, eqmod x x.
Proof.
  intros; red. exists 0. omega.
Qed.

Lemma eqmod_refl2: forall x y, x = y -> eqmod x y.
Proof.
  intros. subst y. apply eqmod_refl.
Qed.

Lemma eqmod_sym: forall x y, eqmod x y -> eqmod y x.
Proof.
  intros x y [k EQ]; red. exists (-k). subst x. ring.
Qed.

Lemma eqmod_trans: forall x y z, eqmod x y -> eqmod y z -> eqmod x z.
Proof.
  intros x y z [k1 EQ1] [k2 EQ2]; red.
  exists (k1 + k2). subst x; subst y. ring.
Qed.

Lemma eqmod_small_eq:
  forall x y, eqmod x y -> 0 <= x < modul -> 0 <= y < modul -> x = y.
Proof.
  intros x y [k EQ] I1 I2.
  generalize (Zdiv_unique _ _ _ _ EQ I2). intro.
  rewrite (Z.div_small x modul I1) in H. subst k. omega.
Qed.

Lemma eqmod_mod_eq:
  forall x y, eqmod x y -> x mod modul = y mod modul.
Proof.
  intros x y [k EQ]. subst x.
  rewrite Z.add_comm. apply Z_mod_plus. auto.
Qed.

Lemma eqmod_mod:
  forall x, eqmod x (x mod modul).
Proof.
  intros; red. exists (x / modul).
  rewrite Z.mul_comm. apply Z_div_mod_eq. auto.
Qed.

Lemma eqmod_add:
  forall a b c d, eqmod a b -> eqmod c d -> eqmod (a + c) (b + d).
Proof.
  intros a b c d [k1 EQ1] [k2 EQ2]; red.
  subst a; subst c. exists (k1 + k2). ring.
Qed.

Lemma eqmod_neg:
  forall x y, eqmod x y -> eqmod (-x) (-y).
Proof.
  intros x y [k EQ]; red. exists (-k). rewrite EQ. ring.
Qed.

Lemma eqmod_sub:
  forall a b c d, eqmod a b -> eqmod c d -> eqmod (a - c) (b - d).
Proof.
  intros a b c d [k1 EQ1] [k2 EQ2]; red.
  subst a; subst c. exists (k1 - k2). ring.
Qed.

Lemma eqmod_mult:
  forall a b c d, eqmod a c -> eqmod b d -> eqmod (a * b) (c * d).
Proof.
  intros a b c d [k1 EQ1] [k2 EQ2]; red.
  subst a; subst b.
  exists (k1 * k2 * modul + c * k2 + k1 * d).
  ring.
Qed.

End EQ_MODULO.

Lemma eqmod_divides:
  forall n m x y, eqmod n x y -> Z.divide m n -> eqmod m x y.
Proof.
  intros. destruct H as [k1 EQ1]. destruct H0 as [k2 EQ2].
  exists (k1*k2). rewrite <- Z.mul_assoc. rewrite <- EQ2. auto.
Qed.

(** ** Fast normalization modulo [2^n] *)

Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z :=
  match n with
  | O => 0
  | S m =>
      match p with
      | xH => 1
      | xO q => Z.double (P_mod_two_p q m)
      | xI q => Z.succ_double (P_mod_two_p q m)
      end
  end.

Definition Z_mod_two_p (x: Z) (n: nat) : Z :=
  match x with
  | Z0 => 0
  | Zpos p => P_mod_two_p p n
  | Zneg p => let r := P_mod_two_p p n in if zeq r 0 then 0 else two_power_nat n - r
  end.

Lemma P_mod_two_p_range:
  forall n p, 0 <= P_mod_two_p p n < two_power_nat n.
Proof.
  induction n; simpl; intros.
  - rewrite two_power_nat_O. omega.
  - rewrite two_power_nat_S. destruct p.
    + generalize (IHn p). rewrite Z.succ_double_spec. omega.
    + generalize (IHn p). rewrite Z.double_spec. omega.
    + generalize (two_power_nat_pos n). omega.
Qed.

Lemma P_mod_two_p_eq:
  forall n p, P_mod_two_p p n = (Zpos p) mod (two_power_nat n).
Proof.
  assert (forall n p, exists y, Zpos p = y * two_power_nat n + P_mod_two_p p n).
  {
    induction n; simpl; intros.
    - rewrite two_power_nat_O. exists (Zpos p). ring.
    - rewrite two_power_nat_S. destruct p.
      + destruct (IHn p) as [y EQ]. exists y.
        change (Zpos p~1) with (2 * Zpos p + 1). rewrite EQ.
        rewrite Z.succ_double_spec. ring.
      + destruct (IHn p) as [y EQ]. exists y.
        change (Zpos p~0) with (2 * Zpos p). rewrite EQ.
        rewrite (Z.double_spec (P_mod_two_p p n)). ring.
      + exists 0; omega.
  }
  intros.
  destruct (H n p) as [y EQ].
  symmetry. apply Zmod_unique with y. auto. apply P_mod_two_p_range.
Qed.

Lemma Z_mod_two_p_range:
  forall n x, 0 <= Z_mod_two_p x n < two_power_nat n.
Proof.
  intros; unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros.
  destruct x.
  - intuition.
  - apply P_mod_two_p_range.
  - set (r := P_mod_two_p p n).
    assert (0 <= r < two_power_nat n) by apply P_mod_two_p_range.
    destruct (zeq r 0).
    + intuition.
    + Psatz.lia.
Qed.

Lemma Z_mod_two_p_eq:
  forall n x, Z_mod_two_p x n = x mod (two_power_nat n).
Proof.
  intros. unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros.
  destruct x.
  - rewrite Zmod_0_l. auto.
  - apply P_mod_two_p_eq.
  - generalize (P_mod_two_p_range n p) (P_mod_two_p_eq n p). intros A B.
    exploit (Z_div_mod_eq (Zpos p) (two_power_nat n)); auto. intros C.
    set (q := Zpos p / two_power_nat n) in *.
    set (r := P_mod_two_p p n) in *.
    rewrite <- B in C.
    change (Z.neg p) with (- (Z.pos p)). destruct (zeq r 0).
    + symmetry. apply Zmod_unique with (-q). rewrite C; rewrite e. Psatz.lia.
      intuition.
    + symmetry. apply Zmod_unique with (-q - 1). rewrite C. Psatz.lia.
      intuition.
Qed.

(** ** Bit-level operations and properties *)

(** Shift [x] left by one and insert [b] as the low bit of the result. *)

Definition Zshiftin (b: bool) (x: Z) : Z :=
  if b then Z.succ_double x else Z.double x.

Remark Ztestbit_0: forall n, Z.testbit 0 n = false.
Proof Z.testbit_0_l.

Remark Ztestbit_1: forall n, Z.testbit 1 n = zeq n 0.
Proof.
  intros. destruct n; simpl; auto.
Qed.

Remark Ztestbit_m1: forall n, 0 <= n -> Z.testbit (-1) n = true.
Proof.
  intros. destruct n; simpl; auto.
Qed.

Remark Zshiftin_spec:
  forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0).
Proof.
  unfold Zshiftin; intros. destruct b.
  - rewrite Z.succ_double_spec. omega.
  - rewrite Z.double_spec. omega.
Qed.

Remark Zshiftin_inj:
  forall b1 x1 b2 x2,
  Zshiftin b1 x1 = Zshiftin b2 x2 -> b1 = b2 /\ x1 = x2.
Proof.
  intros. rewrite !Zshiftin_spec in H.
  destruct b1; destruct b2.
  split; [auto|omega].
  omegaContradiction.
  omegaContradiction.
  split; [auto|omega].
Qed.

Remark Zdecomp:
  forall x, x = Zshiftin (Z.odd x) (Z.div2 x).
Proof.
  intros. destruct x; simpl.
  - auto.
  - destruct p; auto.
  - destruct p; auto. simpl. rewrite Pos.pred_double_succ. auto.
Qed.

Remark Ztestbit_shiftin:
  forall b x n,
  0 <= n ->
  Z.testbit (Zshiftin b x) n = if zeq n 0 then b else Z.testbit x (Z.pred n).
Proof.
  intros. rewrite Zshiftin_spec. destruct (zeq n 0).
  - subst n. destruct b.
    + apply Z.testbit_odd_0.
    + rewrite Z.add_0_r. apply Z.testbit_even_0.
  - assert (0 <= Z.pred n) by omega.
    set (n' := Z.pred n) in *.
    replace n with (Z.succ n') by (unfold n'; omega).
    destruct b.
    + apply Z.testbit_odd_succ; auto.
    + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto.
Qed.

Remark Ztestbit_shiftin_base:
  forall b x, Z.testbit (Zshiftin b x) 0 = b.
Proof.
  intros. rewrite Ztestbit_shiftin. apply zeq_true. omega.
Qed.

Remark Ztestbit_shiftin_succ:
  forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n.
Proof.
  intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto.
  omega. omega.
Qed.

Lemma Zshiftin_ind:
  forall (P: Z -> Prop),
  P 0 ->
  (forall b x, 0 <= x -> P x -> P (Zshiftin b x)) ->
  forall x, 0 <= x -> P x.
Proof.
  intros. destruct x.
  - auto.
  - induction p.
    + change (P (Zshiftin true (Z.pos p))). auto.
    + change (P (Zshiftin false (Z.pos p))). auto.
    + change (P (Zshiftin true 0)). apply H0. omega. auto.
  - compute in H1. intuition congruence.
Qed.

Lemma Zshiftin_pos_ind:
  forall (P: Z -> Prop),
  P 1 ->
  (forall b x, 0 < x -> P x -> P (Zshiftin b x)) ->
  forall x, 0 < x -> P x.
Proof.
  intros. destruct x; simpl in H1; try discriminate.
  induction p.
    + change (P (Zshiftin true (Z.pos p))). auto.
    + change (P (Zshiftin false (Z.pos p))). auto.
    + auto.
Qed.

(** ** Bit-wise decomposition ([Z.testbit]) *)

Remark Ztestbit_eq:
  forall n x, 0 <= n ->
  Z.testbit x n = if zeq n 0 then Z.odd x else Z.testbit (Z.div2 x) (Z.pred n).
Proof.
  intros. rewrite (Zdecomp x) at 1. apply Ztestbit_shiftin; auto.
Qed.

Remark Ztestbit_base:
  forall x, Z.testbit x 0 = Z.odd x.
Proof.
  intros. rewrite Ztestbit_eq. apply zeq_true. omega.
Qed.

Remark Ztestbit_succ:
  forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n.
Proof.
  intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto.
  omega. omega.
Qed.

Lemma eqmod_same_bits:
  forall n x y,
  (forall i, 0 <= i < Z.of_nat n -> Z.testbit x i = Z.testbit y i) ->
  eqmod (two_power_nat n) x y.
Proof.
  induction n; intros.
  - change (two_power_nat 0) with 1. exists (x-y); ring.
  - rewrite two_power_nat_S.
    assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)).
      apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; omega.
      omega. omega.
  destruct H0 as [k EQ].
  exists k. rewrite (Zdecomp x). rewrite (Zdecomp y).
  replace (Z.odd y) with (Z.odd x).
  rewrite EQ. rewrite !Zshiftin_spec. ring.
  exploit (H 0). rewrite Nat2Z.inj_succ; omega.
  rewrite !Ztestbit_base. auto.
Qed.

Lemma same_bits_eqmod:
  forall n x y i,
  eqmod (two_power_nat n) x y -> 0 <= i < Z.of_nat n ->
  Z.testbit x i = Z.testbit y i.
Proof.
  induction n; intros.
  - simpl in H0. omegaContradiction.
  - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H.
    rewrite !(Ztestbit_eq i); intuition.
    destruct H as [k EQ].
    assert (EQ': Zshiftin (Z.odd x) (Z.div2 x) =
                 Zshiftin (Z.odd y) (k * two_power_nat n + Z.div2 y)).
    {
      rewrite (Zdecomp x) in EQ. rewrite (Zdecomp y) in EQ.
      rewrite EQ. rewrite !Zshiftin_spec. ring.
    }
    exploit Zshiftin_inj; eauto. intros [A B].
    destruct (zeq i 0).
    + auto.
    + apply IHn. exists k; auto. omega.
Qed.

Lemma equal_same_bits:
  forall x y,
  (forall i, 0 <= i -> Z.testbit x i = Z.testbit y i) ->
  x = y.
Proof Z.bits_inj'.

Lemma Z_one_complement:
  forall i, 0 <= i ->
  forall x, Z.testbit (-x-1) i = negb (Z.testbit x i).
Proof.
  intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
  intros i IND POS x.
  rewrite (Zdecomp x). set (y := Z.div2 x).
  replace (- Zshiftin (Z.odd x) y - 1)
     with (Zshiftin (negb (Z.odd x)) (- y - 1)).
  rewrite !Ztestbit_shiftin; auto.
  destruct (zeq i 0). auto. apply IND. omega.
  rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring.
Qed.

Lemma Ztestbit_above:
  forall n x i,
  0 <= x < two_power_nat n ->
  i >= Z.of_nat n ->
  Z.testbit x i = false.
Proof.
  induction n; intros.
  - change (two_power_nat 0) with 1 in H.
    replace x with 0 by omega.
    apply Z.testbit_0_l.
  - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false.
    apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H.
    rewrite Zshiftin_spec in H. destruct (Z.odd x); omega.
    omega. omega. omega.
Qed.

Lemma Ztestbit_above_neg:
  forall n x i,
  -two_power_nat n <= x < 0 ->
  i >= Z.of_nat n ->
  Z.testbit x i = true.
Proof.
  intros. set (y := -x-1).
  assert (Z.testbit y i = false).
    apply Ztestbit_above with n.
    unfold y; omega. auto.
  unfold y in H1. rewrite Z_one_complement in H1.
  change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto.
  omega.
Qed.

Lemma Zsign_bit:
  forall n x,
  0 <= x < two_power_nat (S n) ->
  Z.testbit x (Z.of_nat n) = if zlt x (two_power_nat n) then false else true.
Proof.
  induction n; intros.
  - change (two_power_nat 1) with 2 in H.
    assert (x = 0 \/ x = 1) by omega.
    destruct H0; subst x; reflexivity.
  - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ.
    rewrite IHn. rewrite two_power_nat_S.
    destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec.
    rewrite zlt_true. auto. destruct (Z.odd x); omega.
    rewrite zlt_false. auto. destruct (Z.odd x); omega.
    rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H.
    rewrite two_power_nat_S in H. destruct (Z.odd x); omega.
    omega. omega.
Qed.

Lemma Ztestbit_le:
  forall x y,
  0 <= y ->
  (forall i, 0 <= i -> Z.testbit x i = true -> Z.testbit y i = true) ->
  x <= y.
Proof.
  intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros.
  - replace x with 0. omega. apply equal_same_bits; intros.
    rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto.
    exploit H; eauto. rewrite Ztestbit_0. auto.
  - assert (Z.div2 x0 <= x).
    { apply H0. intros. exploit (H1 (Z.succ i)).
        omega. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto.
    }
    rewrite (Zdecomp x0). rewrite !Zshiftin_spec.
    destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try omega.
    exploit (H1 0). omega. rewrite Ztestbit_base; auto.
    rewrite Ztestbit_shiftin_base. congruence.
Qed.

Lemma Ztestbit_mod_two_p:
  forall n x i,
  0 <= n -> 0 <= i ->
  Z.testbit (x mod (two_p n)) i = if zlt i n then Z.testbit x i else false.
Proof.
  intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto.
  - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l.
    rewrite zlt_false; auto. omega.
  - intros. rewrite two_p_S; auto.
    replace (x0 mod (2 * two_p x))
       with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)).
    rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0).
    + rewrite zlt_true; auto. omega.
    + rewrite H0. destruct (zlt (Z.pred i) x).
      * rewrite zlt_true; auto. omega.
      * rewrite zlt_false; auto. omega.
      * omega.
    + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry.
      apply Zmod_unique with (x1 / two_p x).
      rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal.
      transitivity (2 * (two_p x * (x1 / two_p x) + x1 mod two_p x)).
      f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto.
      ring.
      rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto.
      destruct (Z.odd x0); omega.
Qed.

Corollary Ztestbit_two_p_m1:
  forall n i, 0 <= n -> 0 <= i ->
  Z.testbit (two_p n - 1) i = if zlt i n then true else false.
Proof.
  intros. replace (two_p n - 1) with ((-1) mod (two_p n)).
  rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto.
  apply Zmod_unique with (-1). ring.
  exploit (two_p_gt_ZERO n). auto. omega.
Qed.

Corollary Ztestbit_neg_two_p:
  forall n i, 0 <= n -> 0 <= i ->
  Z.testbit (- (two_p n)) i = if zlt i n then false else true.
Proof.
  intros.
  replace (- two_p n) with (- (two_p n - 1) - 1) by omega.
  rewrite Z_one_complement by auto.
  rewrite Ztestbit_two_p_m1 by auto.
  destruct (zlt i n); auto.
Qed.

Lemma Z_add_is_or:
  forall i, 0 <= i ->
  forall x y,
  (forall j, 0 <= j <= i -> Z.testbit x j && Z.testbit y j = false) ->
  Z.testbit (x + y) i = Z.testbit x i || Z.testbit y i.
Proof.
  intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
  intros i IND POS x y EXCL.
  rewrite (Zdecomp x) in *. rewrite (Zdecomp y) in *.
  transitivity (Z.testbit (Zshiftin (Z.odd x || Z.odd y) (Z.div2 x + Z.div2 y)) i).
  - f_equal. rewrite !Zshiftin_spec.
    exploit (EXCL 0). omega. rewrite !Ztestbit_shiftin_base. intros.
Opaque Z.mul.
    destruct (Z.odd x); destruct (Z.odd y); simpl in *; discriminate || ring.
  - rewrite !Ztestbit_shiftin; auto.
    destruct (zeq i 0).
    + auto.
    + apply IND. omega. intros.
      exploit (EXCL (Z.succ j)). omega.
      rewrite !Ztestbit_shiftin_succ. auto.
      omega. omega.
Qed.

(** ** Zero and sign extensions *)

(** In pseudo-code:
<<
    Fixpoint Zzero_ext (n: Z) (x: Z) : Z :=
      if zle n 0 then
        0
      else
        Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
    Fixpoint Zsign_ext (n: Z) (x: Z) : Z :=
      if zle n 1 then
        if Z.odd x then -1 else 0
      else
        Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
>>
  We encode this [nat]-like recursion using the [Z.iter] iteration
  function, in order to make the [Zzero_ext] and [Zsign_ext]
  functions efficiently executable within Coq.
*)

Definition Zzero_ext (n: Z) (x: Z) : Z :=
  Z.iter n
    (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
    (fun x => 0)
    x.

Definition Zsign_ext (n: Z) (x: Z) : Z :=
  Z.iter (Z.pred n)
    (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
    (fun x => if Z.odd x && zlt 0 n then -1 else 0)
    x.

Lemma Ziter_base:
  forall (A: Type) n (f: A -> A) x, n <= 0 -> Z.iter n f x = x.
Proof.
  intros. unfold Z.iter. destruct n; auto. compute in H. elim H; auto.
Qed.

Lemma Ziter_succ:
  forall (A: Type) n (f: A -> A) x,
  0 <= n -> Z.iter (Z.succ n) f x = f (Z.iter n f x).
Proof.
  intros. destruct n; simpl.
  - auto.
  - rewrite Pos.add_1_r. apply Pos.iter_succ.
  - compute in H. elim H; auto.
Qed.

Lemma Znatlike_ind:
  forall (P: Z -> Prop),
  (forall n, n <= 0 -> P n) ->
  (forall n, 0 <= n -> P n -> P (Z.succ n)) ->
  forall n, P n.
Proof.
  intros. destruct (zle 0 n).
  apply natlike_ind; auto. apply H; omega.
  apply H. omega.
Qed.

Lemma Zzero_ext_spec:
  forall n x i, 0 <= i ->
  Z.testbit (Zzero_ext n x) i = if zlt i n then Z.testbit x i else false.
Proof.
  unfold Zzero_ext. induction n using Znatlike_ind.
  - intros. rewrite Ziter_base; auto.
    rewrite zlt_false. rewrite Ztestbit_0; auto. omega.
  - intros. rewrite Ziter_succ; auto.
    rewrite Ztestbit_shiftin; auto.
    rewrite (Ztestbit_eq i x); auto.
    destruct (zeq i 0).
    + subst i. rewrite zlt_true; auto. omega.
    + rewrite IHn. destruct (zlt (Z.pred i) n).
      rewrite zlt_true; auto. omega.
      rewrite zlt_false; auto. omega.
      omega.
Qed.

Lemma Zsign_ext_spec:
  forall n x i, 0 <= i ->
  Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1).
Proof.
  intros n0 x i I0. unfold Zsign_ext.
  unfold proj_sumbool; destruct (zlt 0 n0) as [N0|N0]; simpl.
- revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1); [ | omega ].
  unfold Zsign_ext. intros.
  destruct (zeq x 1).
  + subst x; simpl.
    replace (if zlt i 1 then i else 0) with 0.
    rewrite Ztestbit_base.
    destruct (Z.odd x0); [ apply Ztestbit_m1; auto | apply Ztestbit_0 ].
    destruct (zlt i 1); omega.
  + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)) by omega.
    rewrite Ziter_succ by (unfold x1; omega). rewrite Ztestbit_shiftin by auto.
    destruct (zeq i 0).
    * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega.
    * rewrite H by (unfold x1; omega).
      unfold x1; destruct (zlt (Z.pred i) (Z.pred x)).
      ** rewrite zlt_true by omega.
         rewrite (Ztestbit_eq i x0) by omega.
         rewrite zeq_false by omega. auto.
      ** rewrite zlt_false by omega.
         rewrite (Ztestbit_eq (x - 1) x0) by omega.
         rewrite zeq_false by omega. auto.
- rewrite Ziter_base by omega. rewrite andb_false_r.
  rewrite Z.testbit_0_l, Z.testbit_neg_r. auto.
  destruct (zlt i n0); omega.
Qed.

(** [Zzero_ext n x] is [x modulo 2^n] *)

Lemma Zzero_ext_mod:
  forall n x, 0 <= n -> Zzero_ext n x = x mod (two_p n).
Proof.
  intros. apply equal_same_bits; intros.
  rewrite Zzero_ext_spec, Ztestbit_mod_two_p by auto. auto.
Qed.

(** [Zzero_ext n x] is the unique integer congruent to [x] modulo [2^n] in the range [0...2^n-1]. *)

Lemma Zzero_ext_range:
  forall n x, 0 <= n -> 0 <= Zzero_ext n x < two_p n.
Proof.
  intros. rewrite Zzero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. omega.
Qed.

Lemma eqmod_Zzero_ext:
  forall n x, 0 <= n -> eqmod (two_p n) (Zzero_ext n x) x.
Proof.
  intros. rewrite Zzero_ext_mod; auto. apply eqmod_sym. apply eqmod_mod.
  apply two_p_gt_ZERO. omega.
Qed.

(** Relation between [Zsign_ext n x] and (Zzero_ext n x] *)

Lemma Zsign_ext_zero_ext:
  forall n, 0 <= n -> forall x,
  Zsign_ext n x = Zzero_ext n x - (if Z.testbit x (n - 1) then two_p n else 0).
Proof.
  intros. apply equal_same_bits; intros.
  rewrite Zsign_ext_spec by auto.
  destruct (Z.testbit x (n - 1)) eqn:SIGNBIT.
- set (n' := - two_p n).
  replace (Zzero_ext n x - two_p n) with (Zzero_ext n x + n') by (unfold n'; omega).
  rewrite Z_add_is_or; auto.
  rewrite Zzero_ext_spec by auto. unfold n'; rewrite Ztestbit_neg_two_p by omega.
  destruct (zlt i n). rewrite orb_false_r; auto. auto.
  intros. rewrite Zzero_ext_spec by omega. unfold n'; rewrite Ztestbit_neg_two_p by omega.
  destruct (zlt j n); auto using andb_false_r.
- replace (Zzero_ext n x - 0) with (Zzero_ext n x) by omega.
  rewrite Zzero_ext_spec by auto.
  destruct (zlt i n); auto.
Qed.

(** [Zsign_ext n x] is the unique integer congruent to [x] modulo [2^n]
    in the range [-2^(n-1)...2^(n-1) - 1]. *)

Lemma Zsign_ext_range:
  forall n x, 0 < n -> -two_p (n-1) <= Zsign_ext n x < two_p (n-1).
Proof.
  intros.
  assert (A: 0 <= Zzero_ext n x < two_p n) by (apply Zzero_ext_range; omega).
  assert (B: Z.testbit (Zzero_ext n x) (n - 1) =
             if zlt (Zzero_ext n x) (two_p (n - 1)) then false else true).
  { set (N := Z.to_nat (n - 1)).
    generalize (Zsign_bit N (Zzero_ext n x)).
    rewrite ! two_power_nat_two_p.
    rewrite inj_S.  unfold N; rewrite Z2Nat.id by omega.
    intros X; apply X.  replace (Z.succ (n - 1)) with n by omega. exact A.
  }
  assert (C: two_p n = 2 * two_p (n - 1)).
  { rewrite <- two_p_S by omega. f_equal; omega. }
  rewrite Zzero_ext_spec, zlt_true in B by omega.
  rewrite Zsign_ext_zero_ext by omega. rewrite B.
  destruct (zlt (Zzero_ext n x) (two_p (n - 1))); omega.
Qed.

Lemma eqmod_Zsign_ext:
  forall n x, 0 <= n ->
  eqmod (two_p n) (Zsign_ext n x) x.
Proof.
  intros. rewrite Zsign_ext_zero_ext by auto.
  apply eqmod_trans with (x - 0).
  apply eqmod_sub.
  apply eqmod_Zzero_ext; omega.
  exists (if Z.testbit x (n - 1) then 1 else 0). destruct (Z.testbit x (n - 1)); ring.
  apply eqmod_refl2; omega.
Qed.

(** ** Decomposition of a number as a sum of powers of two. *)

Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z :=
  match n with
  | O => nil
  | S m =>
      if Z.odd x
      then i :: Z_one_bits m (Z.div2 x) (i+1)
      else Z_one_bits m (Z.div2 x) (i+1)
  end.

Fixpoint powerserie (l: list Z): Z :=
  match l with
  | nil => 0
  | x :: xs => two_p x + powerserie xs
  end.

Lemma Z_one_bits_powerserie:
  forall n x, 0 <= x < two_power_nat n -> x = powerserie (Z_one_bits n x 0).
Proof.
  assert (forall n x i,
    0 <= i ->
    0 <= x < two_power_nat n ->
    x * two_p i = powerserie (Z_one_bits n x i)).
  {
  induction n; intros.
  simpl. rewrite two_power_nat_O in H0.
  assert (x = 0) by omega. subst x. omega.
  rewrite two_power_nat_S in H0. simpl Z_one_bits.
  rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0.
  assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))).
    apply IHn. omega.
    destruct (Z.odd x); omega.
  rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ.
  rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec.
  destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring.
  omega. omega.
  }
  intros. rewrite <- H. change (two_p 0) with 1. omega.
  omega. exact H0.
Qed.

Lemma Z_one_bits_range:
  forall n x i, In i (Z_one_bits n x 0) -> 0 <= i < Z.of_nat n.
Proof.
  assert (forall n x i j,
    In j (Z_one_bits n x i) -> i <= j < i + Z.of_nat n).
  {
  induction n; simpl In.
  tauto.
  intros x i j. rewrite Nat2Z.inj_succ.
  assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)).
    intros. exploit IHn; eauto. omega.
  destruct (Z.odd x); simpl.
  intros [A|B]. subst j. omega. auto.
  auto.
  }
  intros. generalize (H n x 0 i H0). omega.
Qed.

Remark Z_one_bits_zero:
  forall n i, Z_one_bits n 0 i = nil.
Proof.
  induction n; intros; simpl; auto.
Qed.

Remark Z_one_bits_two_p:
  forall n x i,
  0 <= x < Z.of_nat n ->
  Z_one_bits n (two_p x) i = (i + x) :: nil.
Proof.
  induction n; intros; simpl. simpl in H. omegaContradiction.
  rewrite Nat2Z.inj_succ in H.
  assert (x = 0 \/ 0 < x) by omega. destruct H0.
  subst x; simpl. decEq. omega. apply Z_one_bits_zero.
  assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)).
    apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec.
    rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; omega. omega.
  destruct H1 as [A B]; rewrite A; rewrite B.
  rewrite IHn. f_equal; omega. omega.
Qed.

(** ** Recognition of powers of two *)

Fixpoint P_is_power2 (p: positive) : bool :=
  match p with
  | xH => true
  | xO q => P_is_power2 q
  | xI q => false
  end.

Definition Z_is_power2 (x: Z) : option Z :=
  match x with
  | Z0 => None
  | Zpos p => if P_is_power2 p then Some (Z.log2 x) else None
  | Zneg _ => None
  end.

Remark P_is_power2_sound:
  forall p, P_is_power2 p = true -> Z.pos p = two_p (Z.log2 (Z.pos p)).
Proof.
  induction p; simpl P_is_power2; intros.
- discriminate.
- change (Z.pos p~0) with (2 * Z.pos p).  apply IHp in H.
  rewrite Z.log2_double by xomega. rewrite two_p_S.  congruence.
  apply Z.log2_nonneg.
- reflexivity.
Qed.

Lemma Z_is_power2_nonneg:
  forall x i, Z_is_power2 x = Some i -> 0 <= i.
Proof.
  unfold Z_is_power2; intros. destruct x; try discriminate.
  destruct (P_is_power2 p) eqn:P; try discriminate.
  replace i with (Z.log2 (Z.pos p)) by congruence. apply Z.log2_nonneg.
Qed.

Lemma Z_is_power2_sound:
  forall x i, Z_is_power2 x = Some i -> x = two_p i /\ i = Z.log2 x.
Proof.
  unfold Z_is_power2; intros. destruct x; try discriminate.
  destruct (P_is_power2 p) eqn:P; try discriminate.
  apply P_is_power2_sound in P. rewrite P; split; congruence.
Qed.

Corollary Z_is_power2_range:
  forall n x i,
  0 <= n -> 0 <= x < two_p n -> Z_is_power2 x = Some i -> 0 <= i < n.
Proof.
  intros.
  assert (x <> 0) by (red; intros; subst x; discriminate).
  apply Z_is_power2_sound in H1. destruct H1 as [P Q]. subst i.
  split. apply Z.log2_nonneg. apply Z.log2_lt_pow2. omega. rewrite <- two_p_equiv; tauto.
Qed.

Lemma Z_is_power2_complete:
  forall i, 0 <= i -> Z_is_power2 (two_p i) = Some i.
Proof.
Opaque Z.log2.
  assert (A: forall x i, Z_is_power2 x = Some i -> Z_is_power2 (2 * x) = Some (Z.succ i)).
  { destruct x; simpl; intros; try discriminate.
    change (2 * Z.pos p) with (Z.pos (xO p)); simpl.
    destruct (P_is_power2 p); inv H. rewrite <- Z.log2_double by xomega. auto.
  }
  induction i using Znatlike_ind; intros.
- replace i with 0 by omega. reflexivity.
- rewrite two_p_S by omega. apply A. apply IHi; omega.
Qed.

Definition Z_is_power2m1 (x: Z) : option Z := Z_is_power2 (Z.succ x).

Lemma Z_is_power2m1_nonneg:
  forall x i, Z_is_power2m1 x = Some i -> 0 <= i.
Proof.
  unfold Z_is_power2m1; intros. eapply Z_is_power2_nonneg; eauto.
Qed.

Lemma Z_is_power2m1_sound:
  forall x i, Z_is_power2m1 x = Some i -> x = two_p i - 1.
Proof.
  unfold Z_is_power2m1; intros. apply Z_is_power2_sound in H. omega.
Qed.

Lemma Z_is_power2m1_complete:
  forall i, 0 <= i -> Z_is_power2m1 (two_p i - 1) = Some i.
Proof.
  intros. unfold Z_is_power2m1. replace (Z.succ (two_p i - 1)) with (two_p i) by omega.
  apply Z_is_power2_complete; auto.
Qed.

Lemma Z_is_power2m1_range:
  forall n x i,
  0 <= n -> 0 <= x < two_p n -> Z_is_power2m1 x = Some i -> 0 <= i <= n.
Proof.
  intros. destruct (zeq x (two_p n - 1)).
- subst x. rewrite Z_is_power2m1_complete in H1 by auto. inv H1; omega.
- unfold Z_is_power2m1 in H1. apply (Z_is_power2_range n (Z.succ x) i) in H1; omega.
Qed.

(** ** Relation between bitwise operations and multiplications / divisions by powers of 2 *)

(** Left shifts and multiplications by powers of 2. *)

Lemma Zshiftl_mul_two_p:
  forall x n, 0 <= n -> Z.shiftl x n = x * two_p n.
Proof.
  intros. destruct n; simpl.
  - omega.
  - pattern p. apply Pos.peano_ind.
    + change (two_power_pos 1) with 2. simpl. ring.
    + intros. rewrite Pos.iter_succ. rewrite H0.
      rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
      change (two_power_pos 1) with 2. ring.
  - compute in H. congruence.
Qed.

(** Right shifts and divisions by powers of 2. *)

Lemma Zshiftr_div_two_p:
  forall x n, 0 <= n -> Z.shiftr x n = x / two_p n.
Proof.
  intros. destruct n; unfold Z.shiftr; simpl.
  - rewrite Zdiv_1_r. auto.
  - pattern p. apply Pos.peano_ind.
    + change (two_power_pos 1) with 2. simpl. apply Zdiv2_div.
    + intros. rewrite Pos.iter_succ. rewrite H0.
      rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
      change (two_power_pos 1) with 2.
      rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv.
      rewrite two_power_pos_nat. apply two_power_nat_pos. omega.
  - compute in H. congruence.
Qed.

(** ** Properties of [shrx] (signed division by a power of 2) *)

Lemma Zquot_Zdiv:
  forall x y,
  y > 0 ->
  Z.quot x y = if zlt x 0 then (x + y - 1) / y else x / y.
Proof.
  intros. destruct (zlt x 0).
  - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)).
     + red. right; split. omega.
       exploit (Z_mod_lt (x + y - 1) y); auto.
       rewrite Z.abs_eq. omega. omega.
     + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)).
       rewrite <- Z_div_mod_eq. ring. auto. ring.
  - apply Zquot_Zdiv_pos; omega.
Qed.

Lemma Zdiv_shift:
  forall x y, y > 0 ->
  (x + (y - 1)) / y = x / y + if zeq (Z.modulo x y) 0 then 0 else 1.
Proof.
  intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H).
  set (q := x / y). set (r := x mod y). intros.
  destruct (zeq r 0).
  apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega.
  apply Zdiv_unique with (r - 1). rewrite H1. ring. omega.
Qed.

(** ** Size of integers, in bits. *)

Definition Zsize (x: Z) : Z :=
  match x with
  | Zpos p => Zpos (Pos.size p)
  | _ => 0
  end.

Remark Zsize_pos: forall x, 0 <= Zsize x.
Proof.
  destruct x; simpl. omega. compute; intuition congruence. omega.
Qed.

Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x.
Proof.
  destruct x; simpl; intros; try discriminate. compute; auto.
Qed.

Lemma Zsize_shiftin:
  forall b x, 0 < x -> Zsize (Zshiftin b x) = Z.succ (Zsize x).
Proof.
  intros. destruct x; compute in H; try discriminate.
  destruct b.
  change (Zshiftin true (Zpos p)) with (Zpos (p~1)).
  simpl. f_equal. rewrite Pos.add_1_r; auto.
  change (Zshiftin false (Zpos p)) with (Zpos (p~0)).
  simpl. f_equal. rewrite Pos.add_1_r; auto.
Qed.

Lemma Ztestbit_size_1:
  forall x, 0 < x -> Z.testbit x (Z.pred (Zsize x)) = true.
Proof.
  intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto.
  intros. rewrite Zsize_shiftin; auto.
  replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by omega.
  rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); omega.
Qed.

Lemma Ztestbit_size_2:
  forall x, 0 <= x -> forall i, i >= Zsize x -> Z.testbit x i = false.
Proof.
  intros x0 POS0. destruct (zeq x0 0).
  - subst x0; intros. apply Ztestbit_0.
  - pattern x0; apply Zshiftin_pos_ind.
    + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin.
      rewrite zeq_false. apply Ztestbit_0. omega. omega.
    + intros. rewrite Zsize_shiftin in H1; auto.
      generalize (Zsize_pos' _ H); intros.
      rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. omega.
      omega. omega.
    + omega.
Qed.

Lemma Zsize_interval_1:
  forall x, 0 <= x -> 0 <= x < two_p (Zsize x).
Proof.
  intros.
  assert (x = x mod (two_p (Zsize x))).
    apply equal_same_bits; intros.
    rewrite Ztestbit_mod_two_p; auto.
    destruct (zlt i (Zsize x)). auto. apply Ztestbit_size_2; auto.
    apply Zsize_pos; auto.
  rewrite H0 at 1. rewrite H0 at 3. apply Z_mod_lt. apply two_p_gt_ZERO. apply Zsize_pos; auto.
Qed.

Lemma Zsize_interval_2:
  forall x n, 0 <= n -> 0 <= x < two_p n -> n >= Zsize x.
Proof.
  intros. set (N := Z.to_nat n).
  assert (Z.of_nat N = n) by (apply Z2Nat.id; auto).
  rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0.
  destruct (zeq x 0).
  subst x; simpl; omega.
  destruct (zlt n (Zsize x)); auto.
  exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. omega.
  rewrite Ztestbit_size_1. congruence. omega.
Qed.

Lemma Zsize_monotone:
  forall x y, 0 <= x <= y -> Zsize x <= Zsize y.
Proof.
  intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos.
  exploit (Zsize_interval_1 y). omega.
  omega.
Qed.

(** ** Bit insertion, bit extraction *)

(** Extract and optionally sign-extend bits [from...from+len-1] of [x] *)
Definition Zextract_u (x: Z) (from: Z) (len: Z) : Z :=
  Zzero_ext len (Z.shiftr x from).

Definition Zextract_s (x: Z) (from: Z) (len: Z) : Z :=
  Zsign_ext len (Z.shiftr x from).

Lemma Zextract_u_spec:
  forall x from len i,
  0 <= from -> 0 <= len -> 0 <= i ->
  Z.testbit (Zextract_u x from len) i =
  if zlt i len then Z.testbit x (from + i) else false.
Proof.
  unfold Zextract_u; intros. rewrite Zzero_ext_spec, Z.shiftr_spec by auto.
  rewrite Z.add_comm. auto.
Qed.

Lemma Zextract_s_spec:
  forall x from len i,
  0 <= from -> 0 < len -> 0 <= i ->
  Z.testbit (Zextract_s x from len) i =
  Z.testbit x (from + (if zlt i len then i else len - 1)).
Proof.
  unfold Zextract_s; intros. rewrite Zsign_ext_spec by auto. rewrite Z.shiftr_spec.
  rewrite Z.add_comm. auto.
  destruct (zlt i len); omega.
Qed.

(** Insert bits [0...len-1] of [y] into bits [to...to+len-1] of [x] *)

Definition Zinsert (x y: Z) (to: Z) (len: Z) : Z :=
  let mask := Z.shiftl (two_p len - 1) to in
  Z.lor (Z.land (Z.shiftl y to) mask) (Z.ldiff x mask).

Lemma Zinsert_spec:
  forall x y to len i,
  0 <= to -> 0 <= len -> 0 <= i ->
  Z.testbit (Zinsert x y to len) i =
    if zle to i && zlt i (to + len)
    then Z.testbit y (i - to)
    else Z.testbit x i.
Proof.
  unfold Zinsert; intros. set (mask := two_p len - 1).
  assert (M: forall j, 0 <= j -> Z.testbit mask j = if zlt j len then true else false).
  { intros; apply Ztestbit_two_p_m1; auto. }
  rewrite Z.lor_spec, Z.land_spec, Z.ldiff_spec by auto.
  destruct (zle to i).
- rewrite ! Z.shiftl_spec by auto. rewrite ! M by omega.
  unfold proj_sumbool; destruct (zlt (i - to) len); simpl;
  rewrite andb_true_r, andb_false_r.
+ rewrite zlt_true by omega. apply orb_false_r.
+ rewrite zlt_false by omega; auto.
- rewrite ! Z.shiftl_spec_low by omega. simpl. apply andb_true_r.
Qed.


Welcome to Coq 8.4pl4 (November 2015)

Coq < Theorem plus_n_0 : forall n : nat, n = n + 0.
1 subgoal

  ============================
   forall n : nat, n = n + 0

plus_n_0 < Proof.
1 subgoal

  ============================
   forall n : nat, n = n + 0

plus_n_0 < intros n.
1 subgoal

  n : nat
  ============================
   n = n + 0

plus_n_0 < induction n as [| n' IHn'].
2 subgoals

  ============================
   0 = 0 + 0

subgoal 2 is:
 S n' = S n' + 0

plus_n_0 < reflexivity.
1 subgoal

  n' : nat
  IHn' : n' = n' + 0
  ============================
   S n' = S n' + 0

plus_n_0 < simpl.
1 subgoal

  n' : nat
  IHn' : n' = n' + 0
  ============================
   S n' = S (n' + 0)

plus_n_0 < rewrite <- IHn'.
1 subgoal

  n' : nat
  IHn' : n' = n' + 0
  ============================
   S n' = S n'

plus_n_0 < reflexivity.
No more subgoals.

plus_n_0 < Qed.
intros n.
induction n as [| n' IHn'].
 reflexivity.

 simpl.
 rewrite <- IHn'.
 reflexivity.

plus_n_0 is defined


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

(*i $Id: Between.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Le.
Require Import Lt.

Open Local Scope nat_scope.

Implicit Types k l p q r : nat.

Section Between.
  Variables P Q : nat -> Prop.

  Inductive between k : nat -> Prop :=
    | bet_emp : between k k
    | bet_S : forall l, between k l -> P l -> between k (S l).

  Hint Constructors between: arith v62.

  Lemma bet_eq : forall k l, l = k -> between k l.
  Proof.
    induction 1; auto with arith.
  Qed.

  Hint Resolve bet_eq: arith v62.

  Lemma between_le : forall k l, between k l -> k <= l.
  Proof.
    induction 1; auto with arith.
  Qed.
  Hint Immediate between_le: arith v62.

  Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
  Proof.
    intros k l H; induction H as [|l H].
    intros; absurd (S k <= k); auto with arith.
    destruct H; auto with arith.
  Qed.
  Hint Resolve between_Sk_l: arith v62.

  Lemma between_restr :
    forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m.
  Proof.
    induction 1; auto with arith.
  Qed.

  Inductive exists_between k : nat -> Prop :=
    | exists_S : forall l, exists_between k l -> exists_between k (S l)
    | exists_le : forall l, k <= l -> Q l -> exists_between k (S l).

  Hint Constructors exists_between: arith v62.

  Lemma exists_le_S : forall k l, exists_between k l -> S k <= l.
  Proof.
    induction 1; auto with arith.
  Qed.

  Lemma exists_lt : forall k l, exists_between k l -> k < l.
  Proof exists_le_S.
  Hint Immediate exists_le_S exists_lt: arith v62.

  Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l.
  Proof.
    intros; apply le_S_n; auto with arith.
  Qed.
  Hint Immediate exists_S_le: arith v62.

  Definition in_int p q r := p <= r /\ r < q.

  Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
  Proof.
    red in |- *; auto with arith.
  Qed.
  Hint Resolve in_int_intro: arith v62.

  Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
  Proof.
    induction 1; intros.
    apply le_lt_trans with r; auto with arith.
  Qed.

  Lemma in_int_p_Sq :
    forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat.
  Proof.
    induction 1; intros.
    elim (le_lt_or_eq r q); auto with arith.
  Qed.

  Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r.
  Proof.
    induction 1; auto with arith.
  Qed.
  Hint Resolve in_int_S: arith v62.

  Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
  Proof.
    induction 1; auto with arith.
  Qed.
  Hint Immediate in_int_Sp_q: arith v62.

  Lemma between_in_int :
    forall k l, between k l -> forall r, in_int k l r -> P r.
  Proof.
    induction 1; intros.
    absurd (k < k); auto with arith.
    apply in_int_lt with r; auto with arith.
    elim (in_int_p_Sq k l r); intros; auto with arith.
    rewrite H2; trivial with arith.
  Qed.

  Lemma in_int_between :
    forall k l, k <= l -> (forall r, in_int k l r -> P r) -> between k l.
  Proof.
    induction 1; auto with arith.
  Qed.

  Lemma exists_in_int :
    forall k l, exists_between k l ->  exists2 m : nat, in_int k l m & Q m.
  Proof.
    induction 1.
    case IHexists_between; intros p inp Qp; exists p; auto with arith.
    exists l; auto with arith.
  Qed.

  Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l.
  Proof.
    destruct 1; intros.
    elim H0; auto with arith.
  Qed.

  Lemma between_or_exists :
    forall k l,
      k <= l ->
      (forall n:nat, in_int k l n -> P n \/ Q n) ->
      between k l \/ exists_between k l.
  Proof.
    induction 1; intros; auto with arith.
    elim IHle; intro; auto with arith.
    elim (H0 m); auto with arith.
  Qed.

  Lemma between_not_exists :
    forall k l,
      between k l ->
      (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
  Proof.
    induction 1; red in |- *; intros.
    absurd (k < k); auto with arith.
    absurd (Q l); auto with arith.
    elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
    replace l with l'; auto with arith.
    elim inl'; intros.
    elim (le_lt_or_eq l' l); auto with arith; intros.
    absurd (exists_between k l); auto with arith.
    apply in_int_exists with l'; auto with arith.
  Qed.

  Inductive P_nth (init:nat) : nat -> nat -> Prop :=
    | nth_O : P_nth init init 0
    | nth_S :
      forall k l (n:nat),
	P_nth init k n -> between (S k) l -> Q l -> P_nth init l (S n).

  Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l.
  Proof.
    induction 1; intros; auto with arith.
    apply le_trans with (S k); auto with arith.
  Qed.

  Definition eventually (n:nat) :=  exists2 k : nat, k <= n & Q k.

  Lemma event_O : eventually 0 -> Q 0.
  Proof.
    induction 1; intros.
    replace 0 with x; auto with arith.
  Qed.

End Between.

Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le
  in_int_S in_int_intro: arith v62.
Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.


Set Implicit Arguments.
Require Import List Arith Lia Morphisms Init.Wf.
Import ListNotations.

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

Notation "f >> g" := (funcomp g f) (at level 50).

Fixpoint it (n: nat) {X: Type} (f: X -> X) (s: X) :=
  match n with
  | 0 => s
  | S n => f (it n f s)
  end.

Lemma it_plus n m X f (s: X):
  it (n + m) f s = it n f (it m f s).
Proof.
  induction n; cbn; congruence.
Qed.

Lemma it_commute n X f (s: X):
  f (it n f s) = it n f (f s).
Proof.
  induction n; cbn; congruence.
Qed.

(* step up the <= game *)

#[global]
Instance max_proper: Proper (le ++> le ++> le) max.
Proof.
  intros a b ? c d ?; transitivity (max a d);
  eauto using Nat.max_le_compat_l, Nat.max_le_compat_r.
Qed.

#[global]
Instance plus_proper: Proper (le ++> le ++> le) plus.
Proof.
  intros a b ? c d ?; transitivity (a + d);
  eauto using plus_le_compat_l, plus_le_compat_r.
Qed.

#[global]
Instance lt_le_subrel: subrelation lt le.
Proof.
  intros ?? H; unfold lt in *; transitivity (S x); eauto.
Qed.

Fixpoint Sum (N: list nat) :=
  match N with
  | nil => 0
  | n :: N => n + Sum N
  end.

Lemma Sum_in x N:
  In x N -> x <= Sum N.
Proof.
  induction N; cbn; intuition; lia.
Qed.

Lemma Sum_app N1 N2:
  Sum (N1 ++ N2) = Sum N1 + Sum N2.
Proof.
  induction N1; cbn; lia.
Qed.

Global Hint Rewrite Sum_app : listdb.

Definition cast {X: Type} {P: X -> Type} {x y: X} (A: P x) (H: x = y): P y :=
  @eq_rect X x P A y H.


Require Import
  CoRN.stdlib_omissions.List Coq.Numbers.Natural.Peano.NPeano
  Coq.QArith.QArith Coq.QArith.Qabs
  CoRN.model.totalorder.QposMinMax
  CoRN.model.metric2.Qmetric
  Coq.Program.Program
  CoRN.stdlib_omissions.N
  CoRN.stdlib_omissions.Z
  CoRN.stdlib_omissions.Q.

Set Automatic Introduction.
Set Automatic Introduction.

Open Scope Q_scope.

Definition Qsum := fold_right Qplus 0.

Definition Σ (n: nat) (f: nat -> Q) := Qsum (map f (enum n)).

(** Properties of Σ: *)

Lemma Σ_sub f g n: Σ n f - Σ n g == Σ n (fun x => f x - g x).
Proof.
 unfold Σ. induction n. reflexivity.
 simpl. rewrite <- IHn. ring.
Qed.

Lemma Σ_mult n f k: Σ n f * k == Σ n (Qmult k ∘ f).
Proof.
 unfold Σ, Basics.compose.
 induction n. reflexivity.
 intros. simpl. rewrite <- IHn. ring.
Qed.

Lemma Σ_constant x n f: (forall i, (i < n)%nat -> f i == x) -> Σ n f == inject_Z (Z.of_nat n) * x.
Proof with auto.
 unfold Σ. induction n. reflexivity.
 simpl. intro E.
 rewrite IHn...
 rewrite E...
 rewrite P_of_succ_nat_Zplus.
 rewrite Q.Zplus_Qplus.
 ring.
Qed.

Lemma Σ_const x n: Σ n (fun _ => x) == inject_Z (Z.of_nat n) * x.
Proof. apply Σ_constant. reflexivity. Qed.

Lemma Σ_S_bound_back f n: Σ (S n) f == Σ n f + f n.
Proof. unfold Σ. simpl. ring. Qed.

Lemma Σ_S_bound_front n f: Σ (S n) f == Σ n (f ∘ S) + f O.
Proof.
 unfold Σ, Basics.compose.
 induction n; intros; simpl in *. ring.
 rewrite IHn. ring.
Qed.

Lemma Σ_S_bound_rev n f: Σ n (f ∘ S) == Σ (S n) f - f O.
Proof. rewrite Σ_S_bound_front. ring. Qed.

Lemma Σ_le f n (b: Q):
  (forall x, (x < n)%nat -> f x <= b) -> Σ n f <= inject_Z (Z.of_nat n) * b.
Proof.
 induction n. discriminate.
 intro.
 rewrite Q.S_Qplus.
 change (f n + Σ n f <= (inject_Z (Z.of_nat n) + 1) * b)%Q.
 assert ((inject_Z (Z.of_nat n) + 1) * b == b + inject_Z (Z.of_nat n) * b)%Q as E. ring.
 rewrite E.
 apply Qplus_le_compat; auto.
Qed.

Lemma Σ_abs_le f n (b: Q):
  (forall x, (x < n)%nat -> Qabs (f x) <= b) -> Qabs (Σ n f) <= inject_Z (Z.of_nat n) * b.
Proof.
 induction n.
  discriminate.
 intros.
 rewrite S_Zplus.
 rewrite Q.Zplus_Qplus.
 change (Qabs (f n + Σ n f) <= (inject_Z (Z.of_nat n) + 1) * b)%Q.
 assert ((inject_Z (Z.of_nat n) + 1) * b == b + inject_Z (Z.of_nat n) * b)%Q. ring.
 rewrite H0. clear H0.
 apply Qle_trans with (Qabs (f n) + Qabs (Σ n f))%Q.
  apply Qabs_triangle.
 apply Qplus_le_compat; auto.
Qed.

Lemma Σ_wd f g n (H: forall x, (x < n)%nat -> f x == g x):
  Σ n f == Σ n g.
Proof with auto with *.
 unfold Σ. induction n; simpl...
 rewrite IHn... rewrite H...
Qed.

Lemma Σ_plus_bound m n f: Σ (m + n) f == Σ n f + Σ m (f ∘ plus n).
Proof with try reflexivity.
 induction m; simpl; intros.
  unfold Σ. simpl. ring.
 do 2 rewrite Σ_S_bound_back.
 rewrite Qplus_assoc.
 rewrite <- IHm.
 unfold Basics.compose.
 replace (f (m + n)%nat) with (f (n + m)%nat)...
 rewrite plus_comm...
Qed.

Lemma Σ_mult_bound n m f:
  Σ (n * m) f == Σ n (fun i => Σ m (fun j => f (i * m + j)%nat)).
Proof.
 induction n; intros.
  reflexivity.
 unfold Σ in *.
 simpl.
 rewrite <- IHn.
 change (Σ (m + n * m) f == Σ m (fun j => f (n * m + j)%nat) + Σ (n * m) f).
 rewrite Σ_plus_bound.
 unfold Basics.compose.
 ring.
Qed.

Lemma Σ_Qball (f g: nat -> Q) (e: Q) (n: nat):
  0 <= e ->
  (forall i: nat, (i < n)%nat -> Qabs (f i - g i) <= e / inject_Z (Z.of_nat n)) ->
  Qball e (Σ n f) (Σ n g).
Proof with auto.
 intros epos H.
 apply Qball_Qabs.
 destruct n. simpl. exact epos.
 rewrite Σ_sub.
 setoid_replace e
   with (inject_Z (Z.of_nat (S n)) * (/ inject_Z (Z.of_nat (S n)) * e)).
  apply Σ_abs_le.
  intros ? E.
  specialize (H x E).
  rewrite Qmult_comm.
  assumption.
  unfold canonical_names.equiv, stdlib_rationals.Q_eq.
 field. discriminate.
Qed.

Lemma Σ_Qball_pos_bounds (f g: nat -> Q) (e: Q) (n: positive):
  (forall i: nat, (i < Pos.to_nat n)%nat -> Qball (e * (1#n)) (f i) (g i)) ->
  Qball e (Σ (Pos.to_nat n) f) (Σ (Pos.to_nat n) g).
Proof with intuition.
  intros.
  assert (0 <= e).
  { specialize (H O (Pos2Nat.is_pos n)).
    apply (msp_nonneg (msp (Q_as_MetricSpace))) in H.
    rewrite <- (Qmult_0_l (1#n)) in H.
    apply Qmult_le_r in H. exact H. reflexivity. }
  apply Σ_Qball. exact H0. intros.
 setoid_replace (e / inject_Z (Z.of_nat (nat_of_P n)))
   with (e * (1#n)).
  apply Qball_Qabs...
  unfold canonical_names.equiv, stdlib_rationals.Q_eq.
 rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P...
Qed.

Lemma Qmult_Σ (f: nat -> Q) n (k: nat):
  Σ n f * inject_Z (Z.of_nat k) == Σ (k * n) (f ∘ flip Nat.div k).
Proof with auto with *.
 unfold Basics.compose.
 rewrite mult_comm.
 rewrite Σ_mult_bound.
 unfold Qdiv.
 rewrite Σ_mult.
 apply Σ_wd.
 intros.
 unfold Basics.compose.
 rewrite (Σ_constant (f x))...
 intros.
 unfold flip.
 replace ((x * k + i) / k)%nat with x...
 apply (Nat.div_unique (x * k + i)%nat k x i)...
Qed.

Lemma Σ_multiply_bound (n:nat) (k: positive) (f: nat -> Q):
  Σ n f == Σ (Pos.to_nat k * n) (f ∘ flip Nat.div (Pos.to_nat k)) / inject_Z (Zpos k).
Proof.
 rewrite <- Qmult_Σ.
 rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P.
 field. discriminate.
Qed.

Lemma Qball_hetero_Σ (n m: positive) f g (e:Q):
 (forall i: nat, (i < Pos.to_nat (n * m)%positive)%nat ->
   Qball (e * (1# (n * m)%positive))
     (/ inject_Z (Zpos m) * f (i / Pos.to_nat m)%nat)
     (/ inject_Z (Zpos n) * g (i / Pos.to_nat n)%nat)) ->
   Qball e (Σ (Pos.to_nat n) f) (Σ (Pos.to_nat m) g).
Proof.
 intros.
 rewrite (Σ_multiply_bound (Pos.to_nat n) m).
 rewrite (Σ_multiply_bound (nat_of_P m) n).
 rewrite mult_comm.
 rewrite <- nat_of_P_mult_morphism.
 unfold Qdiv.
 rewrite Σ_mult.
 rewrite Σ_mult.
 apply Σ_Qball_pos_bounds.
 intros.
 unfold Basics.compose.
 unfold flip.
 auto.
Qed.

(** Σ was defined above straightforwardly in terms of ordinary lists and without
 any efficiency consideration. In practice, building up a list with enum only to
 break it down immediately with Qsum is wasteful, and I strongly doubt Coq
 does list deforestation/fusion. Also, summing many Q's quickly yields large
 numerators and denominators. Hence, we now define a faster version
 which avoids the intermediate lists and uses Qred. The idea is to use
 fastΣ in the actual definition of operations, and to immediately rewrite it to Σ
 (using the correctness property) when doing proofs about said operations. *)

Section fastΣ.

  Fixpoint fast (f: nat -> Q) (left: nat) (sofar: Q): Q :=
    match left with
    | O => sofar
    | S n => fast f n (Qred (sofar + f n))
    end.

  Definition fastΣ (n: nat) (f: nat -> Q): Q := fast f n 0.

  Lemma fastΣ_correct n f: fastΣ n f == Σ n f.
  Proof.
   intros.
   rewrite <- (Qplus_0_r (Σ n f)).
   unfold Σ, fastΣ.
   generalize 0.
   induction n; intros.
    simpl. ring.
   change (fast f n (Qred (q + f n)) == Qsum (map f (enum (S n))) + q).
   rewrite IHn.
   rewrite Qred_correct.
   simpl.
   ring.
  Qed.

End fastΣ.


Require Import Spaces.Pos Spaces.Int.
Require Import Algebra.AbGroups.AbelianGroup.

(** * The group of integers *)

(** See also Cyclic.v for a definition of the integers as the free group on one generator. *)

Local Open Scope int_scope.

Definition abgroup_Z : AbGroup.
Proof.
  snrapply Build_AbGroup.
  - refine (Build_Group Int int_add 0 int_negation _); repeat split.
    + exact _.
    + exact int_add_assoc.
    + exact int_add_0_r.
    + exact int_add_negation_l.
    + exact int_add_negation_r.
  - exact int_add_comm.
Defined.

(** We can multiply by [n : Int] in any abelian group. *)
Definition ab_mul (n : Int) {A : AbGroup} : GroupHomomorphism A A.
Proof.
  induction n.
  - exact (grp_homo_compose ab_homo_negation (ab_mul_nat (pos_to_nat p))).
  - exact grp_homo_const.
  - exact (ab_mul_nat (pos_to_nat p)).
Defined.

(** Homomorphisms respect multiplication. *)
Lemma ab_mul_homo {A B : AbGroup} (n : Int) (f : GroupHomomorphism A B)
  : grp_homo_compose f (ab_mul n) == grp_homo_compose (ab_mul n) f.
Proof.
  intro x.
  induction n.
  - cbn. refine (grp_homo_inv _ _ @ _).
    refine (ap negate _).
    apply grp_pow_homo.
  - cbn. apply grp_homo_unit.
  - cbn. apply grp_pow_homo.
Defined.


Require Import Common.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section path.
  Variable V : Type.
  Variable E : V -> V -> Type.

  Inductive path (s : V) : V -> Type :=
  | NoEdges : path s s
  | AddEdge : forall d d', path s d -> E d d' -> path s d'.

  Fixpoint prepend s d (p : path s d) : forall s', E s' s -> path s' d :=
    match p with
      | NoEdges => fun _ E' => AddEdge (NoEdges _) E'
      | AddEdge _ _ p' E => fun _ E' => AddEdge (prepend p' E') E
    end.

  Fixpoint concatenate s d d' (p : path s d) (p' : path d d') : path s d' :=
    match p' with
      | NoEdges => p
      | AddEdge _ _ p' E => AddEdge (concatenate p p') E
    end.

  Fixpoint concatenate' s d (p : path s d) : forall d', path d d' -> path s d' :=
    match p with
      | NoEdges => fun _ p' => p'
      | AddEdge _ _ p E => fun _ p' => concatenate' p (prepend p' E)
    end.

  Variable typeOf : V -> Type.
  Variable functionOf : forall s d, E s d -> typeOf s -> typeOf d.

  Fixpoint compose_path s d (p : path s d) : typeOf s -> typeOf d :=
    match p with
      | NoEdges => fun x => x
      | AddEdge _ _ p' E => fun x => functionOf E (compose_path p' x)
    end.
End path.

Arguments NoEdges [V E s].
Arguments AddEdge [V E s d d'] _ _.
Arguments prepend [V E s d] p [s'] p'.

Section path_Theorems.
  Variable V : Type.
  Variable E : V -> V -> Type.

  Lemma concatenate_noedges_p : forall s d (p : path E s d), concatenate NoEdges p = p.
  Proof.
    induction p; t.
  Qed.

  Lemma concatenate_p_noedges : forall s d (p : path E s d), concatenate p NoEdges = p.
  Proof.
    t.
  Qed.

  Lemma concatenate'_p_addedge : forall s d d' d'' (p : path E s d) (p' : path E d d') (e : E d' d''),
    concatenate' p (AddEdge p' e) = AddEdge (concatenate' p p') e.
  Proof.
    induction p; t.
  Qed.

  Hint Rewrite concatenate'_p_addedge.

  Lemma concatenate'_p_noedges : forall s d (p : path E s d), concatenate' p NoEdges = p.
  Proof.
    induction p; t.
  Qed.

  Lemma concatenate'_noedges_p : forall s d (p : path E s d), concatenate' NoEdges p = p.
  Proof.
    t.
  Qed.

  Hint Rewrite concatenate'_p_noedges.

  Lemma concatenate_addedge_concatenate'_prepend : forall s d d'0 d' (p : path E s d) (e : E d d'0) (p' : path E d'0 d'),
    concatenate (AddEdge p e) p' = concatenate' p (prepend p' e).
  Proof.
    induction p'; t.
  Qed.

  Hint Resolve concatenate_noedges_p concatenate_addedge_concatenate'_prepend.

  Lemma concatenate_concatenate'_equivalent : forall s d d' (p : path E s d) (p' : path E d d'), concatenate p p' = concatenate' p p'.
  Proof.
    induction p; t.
  Qed.

  Hint Rewrite concatenate_noedges_p concatenate_addedge_concatenate'_prepend.
  Hint Rewrite <- concatenate_concatenate'_equivalent.

  Lemma concatenate_p_addedge : forall s d d' d'' (p : path E s d) (p' : path E d d') (e : E d' d''),
    concatenate p (AddEdge p' e) = AddEdge (concatenate p p') e.
  Proof.
    induction p; t.
  Qed.

  Lemma concatenate_prepend_p : forall s s' d d' (p1 : path E s' d) (p2 : path E d d') (e : E s s'),
    (prepend (concatenate p1 p2) e) = (concatenate (prepend p1 e) p2).
  Proof.
    induction p1; t.
  Qed.

  Hint Rewrite concatenate_prepend_p.

  Lemma concatenate_associative o1 o2 o3 o4 : forall (p1 : path E o1 o2) (p2 : path E o2 o3) (p3 : path E o3 o4),
    (concatenate (concatenate p1 p2) p3) = (concatenate p1 (concatenate p2 p3)).
  Proof.
    induction p1; t.
  Qed.

  Lemma compose_path_addedge s d d' (p : path E s d) (e : E _ d') typeOf functionOf : forall x, compose_path typeOf functionOf (AddEdge p e) x = functionOf _ _ e (compose_path typeOf functionOf p x).
  Proof.
    induction p; t_with t'.
  Qed.

  Lemma compose_path_prepend s' s d (p : path E s d) (e : E s' _) typeOf functionOf : forall x, compose_path typeOf functionOf (prepend p e) x = (compose_path typeOf functionOf p (functionOf _ _ e x)).
  Proof.
    induction p; t_with t'.
  Qed.
End path_Theorems.

Hint Rewrite compose_path_prepend compose_path_addedge.
Hint Rewrite concatenate_p_noedges concatenate_noedges_p.
Hint Resolve concatenate_p_noedges concatenate_noedges_p.


(* A classical library of facts about functions *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp.

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

Section surjective.
  Definition surjective rT aT (f : aT -> rT) :=
    forall y : rT, exists x : aT, f x = y.
  Arguments surjective [rT aT] f.
End surjective.

Section surjections_theory.
  Variables (A B C : Type) (f g : B -> A) (h : C -> B).

  Lemma sur_id : surjective (@id A).
  Proof.
    move=> y. by exists y.
  Qed.

  Lemma sur_comp : surjective f -> surjective h -> surjective (f \o h).
  Proof.
    move=> sur_f sur_h y.
    move: (@sur_f y) => [z f_z]. move: (@sur_h z) => [x f_x].
    exists x => //=. by rewrite f_x.
  Qed.

  Lemma sur_compl : surjective (f \o h) -> surjective f.
  Proof.
    move=> sur_comp y.
    move: (@sur_comp y) => [x f_x]. by exists (h x).
  Qed.

  Lemma bij_sur : bijective f -> surjective f.
  Proof.
    move=> [f' cancel_ff' cancel_f'f] y. by exists (f' y).
  Qed.
End surjections_theory.