From mathcomp.ssreflect Require Import ssreflect ssrnat seq eqtype ssrbool.
From mathcomp.algebra Require Import ssrint.
Require Import Common.

Fixpoint In {A:Type} (a:A) (l: seq A) : Prop :=
match l with
  | [::] => False
  | b :: m => b = a \/ In a m
end.

Inductive numeric := | S8 | U8 | S16 | U16 | S32 | U32 | S64 | U64 .
Scheme Equality for numeric.

Inductive ctype :=
| Int (_:numeric)
| Pointer : ctype -> ctype
| Struct: seq ctype -> ctype
| ErrorType | AnyType.

Definition Int8 := Int S8.
Definition UInt8 := Int U8.
Definition Int16 := Int S16.
Definition UInt16 := Int U16.
Definition Int32 := Int S32.
Definition UInt32 := Int U32.
Definition Int64 := Int S64.
Definition UInt64 := Int U64.

Fixpoint size_of (t:ctype) :=
    match t with
    | Pointer _ => 8
    | Struct els => sumn (map size_of els)
    | Int S8 | Int U8 => 1
    | Int S16 | Int U16 => 2
    | Int S32 | Int U32 => 4
    | Int S64 | Int U64 => 8
    | _ => 0
    end.

Theorem ctype_better_ind (P: ctype -> Prop):
(forall nt, (P (Int nt)))->
(forall p: ctype, P p -> P (Pointer p) ) ->
(forall l, (forall e, In e l -> P e) -> P (Struct l)) ->
(P ErrorType) ->
(P AnyType) ->
(forall t:ctype, P t).
Proof.
  move=> Hnt Hptr Hstr Herr HAny.
  fix 1.
  have StructProof: forall l : seq ctype, P (Struct l). {
    move=> l. apply Hstr. elim: l.
    - by move=> _ [].
    - move=> a l Hin e /= [].
      + by move=><-; exact (ctype_better_ind a).
      + apply Hin.
  }
  move=>[]; try by [clear ctype_better_ind].
  - elim; try by [ clear ctype_better_ind; try move=> c; apply Hptr].
Qed.

Fixpoint ctype_beq (x y: ctype) {struct x} : bool  :=
let fix process (xs ys: seq ctype) := match xs,ys with
                                        | nil, nil => true
                                        | x::xs, y::ys => ctype_beq x y && process xs ys
                                        | _, nil
                                        | nil, _ => false
                                      end in
match x, y with
  | Int x, Int y => numeric_beq x y
  | ErrorType, ErrorType => true
  | Pointer px, Pointer py => ctype_beq px py
  | Struct xs, Struct ys => process xs ys
  | AnyType, AnyType => true
  | _, _ => false
end.

Local Lemma Struct_cons: forall x xs y ys, Struct xs = Struct ys /\ x = y <-> Struct (x::xs) = Struct (y::ys).
Proof. by move=> x xs y ys; split; [move=> [[]] => -> -> | move=> [] -> ->]. Defined.

Theorem ctype_eqP: Equality.axiom ctype_beq.
Proof.
rewrite /Equality.axiom.
fix 1.
move=> x.
elim x; try do [ by case; constructor ].
(* Pointer *)
- move=>[];  move=> y; elim y; try do [try case; by constructor].
  move => z H2 //=.
  elim; try by constructor.
  move=> c H.
  move: (H2 c).
  move: (ctype_beq z c) => [] [].
    by move=> ->; constructor.
    by move=> *;  constructor; case.
    by move=> ->; constructor.
    by move=> *;  constructor; case.
(* Struct *)
- move =>l.
  elim ; try by constructor.

  clear x.
  elim: l.
  + case; by [apply ReflectT | move=> a l; apply ReflectF].
  + move=> a l H []; first by apply ReflectF.
    move=> b m.
    move: (H m) => Hm.
    inversion  Hm as [Hstructs Hstreq| Hstructs Hstreq].
    * destruct (ctype_beq (Struct (a :: l)) (Struct (b :: m))) eqn: Heq_str_big.
      ** apply ReflectT. apply Struct_cons.
      simpl in Heq_str_big.
      split; first by exact Hstructs.
      destruct (ctype_eqP a b) as [Hab|Hab]; [ by exact Hab| by exfalso].
    * apply ReflectF => H_str_big. move: (H m) => Hrefl_eqlm.
      move: (ctype_eqP a b) => Hrefl_ab.
      inversion Hrefl_ab as [Hab Heq_ab|Hab Heq_ab].
      simpl in Heq_str_big. rewrite <- Heq_ab in Heq_str_big.
      simpl in Heq_str_big. rewrite <-Hstreq in Heq_str_big.
        by inversion Heq_str_big.
    * inversion H_str_big. by exact (Hab H1).
      destruct  (ctype_beq (Struct (a :: l)) (Struct (b :: m))) eqn: Hsab; [apply ReflectT| apply ReflectF].
      ** simpl in Hsab.
      rewrite <-Hstreq in Hsab.
      rewrite Bool.andb_false_r in Hsab. by inversion Hsab.
      **  move=> Heq.
      rewrite Heq in Hsab.
      inversion Heq.
      by rewrite H2 in Hstructs.
Qed.

Canonical ctype_eqMixin := EqMixin ctype_eqP.
Canonical ctype_eqType := EqType ctype ctype_eqMixin.

Definition ctype_eq_dec := dec_from_reflect ctype_eqP.
Canonical Structure ctype_dec_eq_mixin := mk_dec_eq ctype ctype_eq_dec.

Theorem numeric_eqP: Equality.axiom numeric_beq.
Proof. by case; case; constructor. Defined.

Canonical numeric_eqMixin := EqMixin numeric_eqP.
Canonical numeric_eqType := EqType numeric numeric_eqMixin.

Canonical Structure numeric_dec_eq_mixin := mk_dec_eq numeric numeric_eq_dec.
(*Definition int_union (x y: numeric) : numeric := match x,y with *)

(* Pointer value *)
Inductive ptr (t: ctype) := | Goodptr (at_block: nat) (offset: nat) | Nullptr.

Definition ptr_eq_dec t : eq_dec (ptr t).  by rewrite /eq_dec; repeat decide equality. Defined.

Definition ptr_eqP t := reflect_from_dec (ptr_eq_dec t).
Canonical ptr_eqMixin t := EqMixin (ptr_eqP t).
Canonical ptr_eqType t := EqType (ptr t) (ptr_eqMixin t).
Canonical Structure ptr_dec_eq_mixin {t} := mk_dec_eq (ptr t) (ptr_eq_dec t).

(* Holders for different value types *)
(*Definition coq_type_eq_dec : forall t:ctype, eq_dec (coq_type t).
  rewrite /eq_dec;case; try by apply unit_eq_dec.
  - move=> *; apply int_eq_dec.
  - apply ptr_eq_dec.
  - move=>*; apply (seq_eq_dec _ nat_eq_dec).
Defined.*)

Inductive anyptr := |AnyPtr t : ptr t-> anyptr.

      Theorem anyptr_eq_dec: eq_dec anyptr.
         rewrite /eq_dec.
         move=> x y.
         case x; case y.
         move=> t p t0 p0.
         eq_compi t0 t.
         eq_compi p0 p.
      Defined.

      Canonical anyptr_eqMixin := EqMixin ( reflect_from_dec anyptr_eq_dec ).
      Canonical anyptr_eqType := EqType anyptr anyptr_eqMixin.
      Canonical Structure anyptr_dec_eq_mixin := mk_dec_eq anyptr anyptr_eq_dec.

Inductive value : Set := | Garbage | Deallocated | Error
                      | ValueI64 (_:int)
                      | ValueI32 (_:int)
                      | ValueI16 (_:int)
                      | ValueI8 (_:int)

                      | ValueU64 (_:int)
                      | ValueU32 (_:int)
                      | ValueU16 (_:int)
                      | ValueU8 (_:int)
                      | ValuePtr (_:anyptr)
                      | ValueStruct (_:seq (ctype*nat)).

Fixpoint type_of_val v : ctype :=
  match v with
    | Garbage => AnyType
    | Deallocated => ErrorType
    | Error => ErrorType
    | ValueI64 x => Int64
    | ValueI32 x => Int32
    | ValueI16 x => Int16
    | ValueI8 x => Int8
    | ValueU64 x => UInt64
    | ValueU32 x =>  UInt32
    | ValueU16 x =>  UInt16
    | ValueU8 x =>  UInt8
    | ValuePtr (AnyPtr p _) => p
    | ValueStruct x => Struct (map fst x)
  end

.
(*  Lemma value_inj t x y: Value t x = Value t y -> x = y.
    move=> [] H. by depcomp H.
  Qed.

  Lemma value_surj t x y: x = y -> Value t x = Value t y. by move =>->. Qed.
 *)

Definition value_beq (x y: value) : bool :=
  match x,y with
    | Garbage, Garbage
    | Deallocated, Deallocated
    | Error, Error => true
    | ValueI64 x, ValueI64 y
    | ValueI32 x, ValueI32 y
    | ValueI16 x, ValueI16 y
    | ValueI8 x, ValueI8 y
    | ValueU64 x, ValueU64 y
    | ValueU32 x, ValueU32 y
    | ValueU16 x, ValueU16 y
    | ValueU8 x, ValueU8 y
                         => x == y
    | ValuePtr x, ValuePtr y => x == y
    | ValueStruct x, ValueStruct y => x == y
    | _,_ => false
  end.

   Theorem value_eqP: Equality.axiom value_beq.
     move=> x y.
     case (value_beq x y) eqn:Heq; [left|right];
     destruct x, y =>//=; move /eqP in Heq; try by subst; try by case.
   Defined.

  Canonical value_eqMixin := EqMixin value_eqP.
  Canonical value_eqType := EqType value value_eqMixin.
  Definition value_eq_dec := @dec_from_reflect value_eqType value_eqP: eq_dec value.
  Canonical Structure value_dec_eq_mixin := mk_dec_eq value value_eq_dec.

  Definition coq_type (t: ctype) : Set :=
    match t with
      | Int _ => int
      | Pointer t => ptr t
      | Struct ls => seq nat
      | ErrorType => unit
      | AnyType => unit
    end.

Definition eq_value_or_error_arith {A:Type} (tl tr: ctype) (v: ctype -> ctype -> A) (err: A):A :=
 match tl, tr  with
    |Int S8, Int S8
    |Int U8, Int U8
    |Int S16, Int S16
    |Int U16, Int U16
    |Int S32, Int S32
    |Int U32, Int U32
    |Int S64, Int S64
    |Int U64, Int U64 => v tl tr
    | _, _=> err
  end
.

Definition eq_value_or_error_proved {A:Type} (tl tr: ctype) (v: tl = tr-> ctype -> ctype -> A) (err: A):A.
  refine(
    match tl == tr as t return tl==tr=t -> A with
   | true => fun Ht =>  v _ tl tr
    | false => fun Ht => err
    end _).
  exact: eqP Ht.
  reflexivity.
Defined.

Definition eq_value_or_error_proved_arith {A:Type} (tl tr: ctype) (v: tl = tr-> ctype -> ctype -> A) (err: A):A.
refine( match tl as tl_, tr as tr_ return tl = tl_-> tr = tr_ -> A with
    |Int S8, Int S8
    |Int U8, Int U8
    |Int S16, Int S16
    |Int U16, Int U16
    |Int S32, Int S32
    |Int U32, Int U32
    |Int S64, Int S64
    |Int U64, Int U64 => fun Hl Hr =>  v _ tl tr
    | _, _=> fun _ _ => err
  end _ _)
; try by [rewrite Hl;rewrite Hr].
reflexivity.
reflexivity.
Defined.

Definition is_goodptr {T} (p:ptr T) := match p with | Goodptr _ _  => true | _ => false end.

Definition for_eq_carriers {R} (x y: ctype) (def:R)
            (fint: int->int->R)
            (fptr: forall T, ptr T -> ptr T -> R)
            (fstruct: seq nat -> seq nat -> R)
            (fbot: unit->R)
            (ferror: unit->R)
            (xv: coq_type x)
            (yv: coq_type y)
 : R. refine (
   match x as x' , y as y' return x = x' -> y = y' -> R with
     | Int S8 as x', Int S8 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int U8  as x', Int U8  as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int S16 as x', Int S16 as y' =>
              fun Hx: x = x' => fun Hy: y = y' =>
                                  fint (cast xv _) (cast yv _)
     | Int U16 as x', Int U16 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int S32 as x', Int S32 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int U32 as x', Int U32 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int S64 as x', Int S64 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Int U64 as x', Int U64 as y' =>
       fun Hx: x = x' => fun Hy: y = y' =>
                           fint (cast xv _) (cast yv _)
     | Pointer tx as x', Pointer ty as y'=>
       fun Hx: x = x' => fun Hy: y=y' =>
                           match tx == ty as r return r = (tx == ty) -> R with
                             | true => fun Heq : true = (tx == ty) => fptr tx (cast xv _) (cast yv _)
                             | false => fun Heq : false = (tx == ty) => def
                           end _
     | _, _=> fun _ _ => def
   end Logic.eq_refl Logic.eq_refl); try by subst.
      subst.
      by rewrite (eqP (Logic.eq_sym Heq)).
Defined.

Definition num_value (num:numeric) : int->value :=
  match num with
    | S8 => ValueI8
    | U8 => ValueU8
    | S16 => ValueI16
    | U16 => ValueU16
    | S32 => ValueI32
    | U32 => ValueU32
    | S64 => ValueI64
    | U64 => ValueU64
  end.

Definition aptr_type p := match p with
                            | AnyPtr t _ => t
                          end.

Definition ptr_add {t} (p: ptr t) (z:int) : ptr t ? :=
  match p with
    | Nullptr => None
    | Goodptr b o => @Some _ $ Goodptr t b $ add_n_z o (intRing.mulz z ( size_of t))
  end.

Definition int_from_value v : int ? :=
    match v with
    | ValueI64 x
    | ValueI32 x
    | ValueI16 x
    | ValueI8 x
    | ValueU64 x
    | ValueU32 x
    | ValueU16 x
    | ValueU8 x => Some x
    | _ => None
    end.

Definition ptr_add_val p v : value :=
  match int_from_value v, p with
    | Some i, AnyPtr t (Goodptr b o) => Error
    | _, _ => Error
  end.


Require Import generic_soundness.

Require Import reduction.

Require Import proofsystem.
Set Implicit Arguments.

Require Import Setoid.
Require Import Relation_Definitions.

Axiom cfg : Set.
Axiom S : cfg -> cfg -> Prop.

(* Showing one-path soundness.
  The final notion of one-path soundness considers a reachability rule
  satisfied if the initial configuration admits a diverging execution, so
  in the non-vacuous case we might as well assume the initial configuration
  terminates on all execution paths, and then this termination is itself
  a well-ordering we can use to justify circularity.
  (see "holds" for the unconditional definition)
 *)

(* Lemmas *)
Lemma clos_lift (A B : Type) (R1 : relation A) (R2 : relation B)
  (f : B -> A) :
  (forall x y, R1 x y -> forall x', x = f x' -> exists y', R2 x' y' /\ y = f y') ->
  forall strict x y,
  clos R1 strict x y ->
  forall x', x = f x' ->
  exists y', clos R2 strict x' y' /\ y = f y'.
induction 2;intros;
repeat match goal with
         | [H : _ -> _ -> ?R _ _ -> _, H1 : ?R _ _ |- _] => specialize (H _ _ H1)
         | [H : forall x, ?a = f x -> _, H1 : ?a = f _ |- _] => specialize (H _ H1)
         | [H : exists y', _ /\ _ = f y' |-_] =>
           destruct H as [? []]
       end;
eauto using clos.
Qed.

Lemma terminates_next : forall {A : Set} {R : relation A} (a : A),
  terminates a R -> forall b, R a b -> terminates b R.
destruct 1.
assumption.
Qed.

Lemma under_terminates : forall {A : Set} {R : relation A} (a : A),
  terminates a R -> forall (P : A -> Prop),
  (forall a0, clos R false a a0 ->
              (forall a', R a0 a' -> P a') ->
              P a0)
  -> P a.
intros A R a term P.
move term after P.
induction term as [a HAcc IH].
intro Hlater.
apply Hlater.
constructor.
intros a' Raa.
apply IH.
assumption.
intros a0 Ha'a0 Hnext.
apply Hlater.
clear -Raa Ha'a0. eauto using clos.
assumption.
Qed.

Lemma clos_cat'
     : forall (A : Type) (R : relation A) (a : A) (s1 : bool)
         (b : A) (s2 s3 : bool) (c : A),
       clos R s1 a b -> clos R s2 b c -> implb s3 (s1 || s2) = true -> clos R s3 a c.
intros.
pose proof (clos_cat H H0) as H2; clear -H1 H2.
destruct s3. simpl in H1; rewrite H1 in H2;assumption.
destruct (orb s1 s2);auto using clos_unstrict.
Qed.

Module ExReachability <: StateBasedReachability.

Definition cfg := cfg.
Definition S := S.

Definition index : Set := {gamma : cfg | terminates gamma S}.
Definition ix_rel (i1 i2 : index) : Prop :=
  S (proj1_sig i1) (proj1_sig i2).

Definition state_reaches strict (i : index) gamma P :=
  clos S false (proj1_sig i) gamma ->
  exists gamma', clos S strict gamma gamma' /\ P gamma'.

Definition holds strict env (phi phi' : formula cfg env) i :=
  forall rho gamma,
    phi rho gamma ->
    state_reaches strict i gamma (phi' rho).

(* Nontrivial proofs *)
(** Circularity **)
Lemma ix_rel_ind : forall env (phi phi' : formula cfg env),
      forall i0,
      (forall i, clos ix_rel false i0 i ->
                   (forall i', ix_rel i i' -> holds true phi phi' i') ->
                   holds true phi phi' i)
       -> holds true phi phi' i0.
unfold holds, state_reaches; intros env phi phi' i Hix_later.
destruct i as [a Hterm].
simpl.
apply (under_terminates Hterm).
intros a0 Haa0 Hnext.

assert (exists i', clos ix_rel false (exist _ a Hterm) i' /\ a0 = proj1_sig i').
  clear -Haa0. apply clos_lift with (R1:=S) (x:=a);[|assumption|reflexivity].
  intros.
  destruct x';simpl in *|- *;subst.
  assert (terminates y S) by (destruct t as [H0]; apply H0; assumption).
  exists (exist _ y H0). split;[|reflexivity].
  unfold ix_rel;simpl. assumption.
destruct H as [i' [Hreach Hend]].
specialize (Hix_later i' Hreach).
rewrite Hend.
apply Hix_later.
intros.
subst a0.
eauto.
Qed.

Ltac clear_except_path :=
repeat match goal with
  | [H : ?Hyp |- _] =>
    match Hyp with
      | terminates _ _ => fail 1
      | clos _ _ _ _ => fail 1
      | S ?x ?y => apply (clos_step _ true) in H
      | _ => clear H
    end
  end.
Ltac clos_solve :=
  clear_except_path;
match goal with
  | [|- clos _ false ?x ?x] => apply clos_refl
  | [|- clos _ false _ _] =>
    repeat match goal with
             | [H : clos _ true _ _ |- _] => apply clos_unstrict in H
           end;
    repeat match goal with
             | [H : clos ?S _ ?x ?y |- clos ?S _ ?x ?y ] => assumption
             | [H : clos ?S _ ?x ?y, H2 : clos ?S _ ?y _ |- clos ?S _ ?x _ ] =>
               pose proof (clos_trans H H2); clear H2
           end
  | [|- clos _ _ _ _] =>
    repeat match goal with
         | [H : clos ?S ?f ?x ?y |- clos ?S ?f ?x ?y ] => assumption
         | [H : clos ?S true ?x ?y, H2 : clos ?S _ ?y _ |- clos ?S _ ?x _ ] =>
           pose proof (clos_cons_lt H H2); clear H H2
         | [H : clos ?S _ ?x ?y, H2 : clos ?S true ?y _ |- clos ?S _ ?x _ ] =>
           pose proof (clos_cons_rt H H2); clear H H2
      end
end.

Hint Extern 0 (clos _ _ _ _) => clos_solve : holds_solve.

Ltac holds_start := intros;
  repeat match goal with
  (* open unnecessary uses of holds/indices *)
  | [i : index |- _] => destruct i
  | [H : ix_rel (exist _ _ _) _ |- _] => unfold ix_rel in H; simpl proj1_sig in H
  | [H : ix_rel _ (exist _ _ _) |- _] => unfold ix_rel in H; simpl proj1_sig in H
  | [H : state_reaches _ (exist _ _ _) _ _ |- _] =>
    unfold state_reaches in H;simpl proj1_sig in H
  | [|- state_reaches  _ (exist _ _ _) _ _] =>
    unfold state_reaches;simpl proj1_sig;intros
  (* Use hypotheses *)
  | [H : (clos S ?f ?x ?y) -> _ |- _] =>
    match goal with
      | [H' : clos S f x y |- _] =>
        specialize (H H')
      | _ =>
        let Hpath := fresh "Hpath" in
        assert (clos S f x y) as Hpath by clos_solve;
          specialize (H Hpath)
    end
  (* Open results *)
  | [H : exists gamma : _, _ |- _] =>
    destruct H
  | [H : _ /\ _ |- _] =>
    destruct H
  end.

Lemma reach_later : forall i i', ix_rel i i' ->
    forall gamma P,
      state_reaches true i gamma P ->
      state_reaches true i' gamma P.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.
  Lemma reach_unstrict : forall i gamma P,
    state_reaches true i gamma P -> state_reaches false i gamma P.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.

  Lemma reach_refl : forall i gamma (P : cfg -> Prop),
                           P gamma -> state_reaches false i gamma P.
  Proof.
    holds_start; firstorder with holds_solve.
  Qed.

  Lemma reach_step : forall i gamma (P : cfg -> Prop),
    (exists gamma', S gamma gamma') ->
    (forall gamma', S gamma gamma' -> P gamma') ->
      state_reaches true i gamma P.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.

  Lemma reach_impl : forall (P Q : cfg -> Prop),
                           (forall c, P c -> Q c) ->
                           forall strict i gamma,
                             state_reaches strict i gamma P ->
                             state_reaches strict i gamma Q.
  Proof.
    holds_start; eauto with holds_solve.
  Qed.

  Lemma reach_join : forall i gamma P,
    state_reaches false i gamma
     (fun gamma' => state_reaches false i gamma' P) ->
    state_reaches false i gamma P.
  Proof.
    holds_start;eauto with holds_solve.
  Qed.

  Lemma reach_join_strict : forall i gamma P,
    state_reaches true i gamma
     (fun gamma' => forall i', ix_rel i i' -> state_reaches false i' gamma' P) ->
    state_reaches true i gamma P.
  Proof.
    holds_start.
    unfold ix_rel in H1; simpl proj1_sig in H1.
    assert (clos S true x x0) by clos_solve;clear H0.
    destruct (clos_true_step H2) as [x' [Hxx' Hx'x0]].
    specialize (H1 (exist _ x' (terminates_next t _ Hxx')) Hxx' Hx'x0).
    firstorder with holds_solve.
  Qed.

End ExReachability.

Module ExPathSemantics := StateBasedSemantics ExReachability.
Module ExPathSoundness := Soundness ExPathSemantics.

Definition holds strict env (phi phi' : formula cfg env) :=
  forall rho gamma, terminates gamma S ->
    phi rho gamma -> exists gamma', phi' rho gamma' /\ clos S strict gamma gamma'.

Lemma approx_holds env (phi phi' : formula cfg env) strict :
  (forall i, ExPathSemantics.holds strict phi phi' i) ->
  holds strict phi phi'.
intro H. unfold holds.
intros.
specialize (H (exist _ gamma H0) _ _ H1 (clos_refl _ _)).
firstorder.
Qed.

Lemma holds_approx env (phi phi' : formula cfg env) strict :
  holds strict phi phi' ->
  (forall i, ExPathSemantics.holds strict phi phi' i).
intros Hstrong i.
destruct i as [gamma term].
unfold ExPathSemantics.holds, ExReachability.holds.
intros rho gamma1 Hphi Hreach.
specialize (Hstrong _ gamma1 (terminates_fwd term Hreach) Hphi).
firstorder.
Qed.

Definition system_holds (A : system cfg) :=
  forall env phi1 phi2, @A env phi1 phi2 -> holds true phi1 phi2.

Theorem soundness (A : system cfg) env (phi1 phi2 : formula cfg env) :
  IS cfg S None A env phi1 phi2 ->
  system_holds A ->
  holds false phi1 phi2.
Proof.
intros pf HA.
apply approx_holds.
intro i.
apply (ExPathSoundness.soundness pf);trivial.
clear -HA i.
pose proof holds_approx.
unfold ExPathSoundness.system_holds;intros.
eauto.
Qed.

(* Print Assumptions soundness. *)


Require Import HoTT HoTT.hit.Truncations Connectedness Utf8_core.
Require Import colimit.

Set Universe Polymorphism.
Global Set Primitive Projections.
Set Implicit Arguments.

Local Open Scope path_scope.
(* Local Open Scope equiv_scope. *)
Local Open Scope type_scope.

Section Gpd.

  Definition Gpd_graph : graph.
  Proof.
    refine (Build_graph _ _).
    exact nat.
    intros n m. exact (S n = m).
  Defined.

  Definition Gpd_aux {X Y:Type} (f: X -> Y) (n:nat) : {T:Type & T -> Y}.
  Proof.
    induction n.
    - exists X. exact f.
    - exists (Coeq (@pullback_pr1 Y IHn.1 IHn.1 IHn.2 IHn.2) (@pullback_pr2 Y IHn.1 IHn.1 IHn.2 IHn.2)).
      refine (Coeq_rec _ _ _).
      exact IHn.2. intro b. apply pullback_commsq.
  Defined.

  Definition Gpd {X Y:Type} (f: X -> Y) : diagram Gpd_graph.
  Proof.
    refine (Build_diagram _ _ _).
    - intros i. exact (Gpd_aux f i).1.
    - intros i j q; destruct q; simpl.
      exact coeq.
  Defined.

End Gpd.

Section Colimit_truncation.

  Require Import VD_truncation.
  Variable X:Type.
  Let D := @Gpd X Unit (λ x, tt).
  Let Q := colimit D.
  Let D' := @Gpd_ X.

  Lemma PB_unit_is_prod (A B: Type)
    : Pullback (λ x:A, tt) (λ x:B, tt) <~> A*B.
  Proof.
    refine (equiv_adjointify _ _ _ _).
    - intros [a [b p]]; exact (a,b).
    - intros [a b]; exact (a;(b;path_ishprop _ _)).
    - intros [a b]; reflexivity.
    - intros [a [b p]]; apply path_sigma' with 1; apply path_sigma' with 1.
      apply path_ishprop.
  Defined.

  Lemma Gpd_aux_is_tt : forall i, (Gpd_aux (λ _ : X, tt) i).2 = λ x, tt.
  Proof.
    intro i. apply path_forall; intro x.
    apply path_ishprop.
  Defined.

  Lemma Gpd_aux_is_Gpd_aux_ : forall i, (Gpd_aux (λ _ : X, tt) i).1 = Gpd_aux_ X i.
  Proof.
    induction i.
    reflexivity.
    simpl.
    apply path_universe_uncurried.
    refine (equiv_functor_coeq' _ _ _ _).
    refine (equiv_adjointify _ _ _ _).
    intro x; cbn in *.
    apply (transport (λ U:Type, U*U) IHi).
    exact (pullback_pr1 x, pullback_pr2 x).

    intro x.
    exists (transport (λ U, U) IHi^ (fst x)).
    exists (transport (λ U, U) IHi^ (snd x)).
    apply path_ishprop.

    abstract (
        intro x;
        rewrite transport_prod; cbn; repeat rewrite transport_pV; reflexivity
      ).

    abstract (
        intro x; refine (path_sigma' _ _ _);
        [rewrite transport_prod; simpl; rewrite transport_Vp; reflexivity |
         rewrite transport_sigma; simpl;
         refine (path_sigma' _ _ _);
         [rewrite transport_const; rewrite transport_prod; simpl;
          rewrite transport_Vp; reflexivity |
          apply path_ishprop] ]
      ).

    apply equiv_path; exact IHi.
    abstract (intro x; simpl; rewrite transport_prod; reflexivity ).
    abstract (intro x; simpl; rewrite transport_prod; reflexivity ).
  Defined.

  Theorem Gpd_is_Gpd_ : Q <~> (Trunc (-1) X).
  Proof.
    assert (H : D = D').
    {
      apply path_diagram.
      refine (exist _ _ _).

      apply path_forall; intro i. apply Gpd_aux_is_Gpd_aux_.
      intros i j x. destruct x. simpl.
      intro x.
      unfold ap10, path_forall. repeat rewrite eisretr.
      apply (moveL_transport_V idmap).
      simpl.
      rewrite transport_path_universe_uncurried.
      reflexivity. }
    unfold Q.

    etransitivity; try exact (VD_truncation X). unfold D' in H; destruct H.
    exact equiv_idmap.
  Defined.

End Colimit_truncation.

Section Colimit_Gpd.

  Definition Gpd_cocone (X Y:Type) (f:X -> Y)
  : cocone (Gpd f) Y.
  Proof.
    refine (exist _ _ _).
    - intro i. simpl. exact (Gpd_aux f i).2.
    - intros i j f0 x. destruct f0. reflexivity.
  Defined.

  Axiom VD_Giraud : forall (X Y:Type), forall (f:X -> Y), IsSurjection f -> (is_colimit (Gpd_cocone f)).

End Colimit_Gpd.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e450m2e225m1_20limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.ProductCategory.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory.
Require Import UniMath.Bicategories.WkCatEnrichment.internal_equivalence.
Require Import UniMath.Bicategories.WkCatEnrichment.Notations.

(******************************************************************************)
(* Definition of bicategory *)

Definition is_bicategory (C : prebicategory) : UU
  := (has_homcats C) × (∏ (a b : C), isweq (path_to_adj_int_equivalence a b)).

Definition bicategory : UU := ∑ C : prebicategory, is_bicategory C.

(******************************************************************************)
(* Being a bicategory is a prop *)

Definition isaprop_has_homcats { C : prebicategory }
  : isaprop (has_homcats C).
Proof.
  apply impred.
  intro a.
  apply impred.
  intro b.
  apply isaprop_is_univalent.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m481_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^256 - 2^224 + 2^192 + 2^96 - 1
Base: 23 + 3/11
***)

Definition curve : CurveParameters :=
  {|
    sz := 11%nat;
    base := 23 + 3/11;
    bitwidth := 32;
    s := 2^256;
    c := [(1, 1); (2^96, -1); (2^192, -1); (2^224, 1)];
    carry_chains := Some [[8; 7; 3; 10]; [9; 8; 4; 0; 10; 5; 1; 6; 2; 7; 3]; [9; 8; 4; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.
Require Import HMAC_spec.
Require Import PRF.
Require Import hF.

Section GNMAC_PRF.

  Variable c p : nat.
  Definition b := @HMAC_spec.b c p.
  Variable h : Bvector c -> Bvector b -> Bvector c.

  Variable fpad : Bvector c -> Bvector p.
  Definition app_fpad := @app_fpad c p fpad.
  Definition h_star := h_star p h.
  Definition h_star_pad := fun k x => app_fpad (h_star k x).

  Variable A : OracleComp (list (Bvector b)) (Bvector c) bool.
  Hypothesis A_wf : well_formed_oc A.

  Definition GNMAC := GNMAC h fpad.

  Theorem GNMAC_PRF :
     PRF_Advantage (Rnd (c + c)) (Rnd c) GNMAC _ _ A <=
     PRF_Advantage ({ 0 , 1 }^c) ({ 0 , 1 }^c) h (Bvector_EqDec b)
     _
     (PRF_h_A (h_star_pad) A) +
     cAU.Adv_WCR _ _ (h_star_pad)  ({ 0 , 1 }^c) (au_F_A A).

    specialize (hF_PRF h h_star_pad A_wf); intuition.

  Qed.

End GNMAC_PRF.


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

 Mixed distributive laws distributive laws in bicategories

 Monads in the bicategory of comonads are the same as mixed distributive laws

 ******************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Examples.OpCellBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp2Bicat.

Local Open Scope cat.

Section MixedDistributiveLaw.
  Context {B : bicat}
          (m₁ : comnd B)
          (m₂ : disp_mnd B (ob_of_comnd m₁)).

  Let x : B := ob_of_comnd m₁.
  Let e : x --> x := endo_of_comnd m₁.
  Let ε : e ==> id₁ _ := counit_of_comnd m₁.
  Let δ : e ==> e · e := comult_of_comnd m₁.

  Let f : x --> x := pr11 m₂.
  Let η : id₁ _ ==> f := pr121 m₂.
  Let μ : f · f ==> f := pr221 m₂.

  Definition mixed_distr_law_data
    : UU
    := e · f ==> f · e.

  Definition mixed_distr_law_laws
             (τ : mixed_distr_law_data)
    : UU
    := ((ε ▹ f)
        • lunitor f
        =
        τ
        • (f ◃ ε)
        • runitor f)
       ×
       ((δ ▹ f)
        • rassociator e e f
        • (e ◃ τ)
        • lassociator e f e
        • (τ ▹ e)
        • rassociator f e e
        =
        τ
        • (f ◃ δ))
       ×
       ((e ◃ η)
        • τ
        =
        runitor e
        • linvunitor e
        • (η ▹ e))
       ×
       ((e ◃ μ)
        • τ
        =
        lassociator e f f
        • (τ ▹ f)
        • rassociator f e f
        • (f ◃ τ)
        • lassociator f f e
        • (μ ▹ e)).

  Definition mixed_distr_law
    : UU
    := ∑ (τ : mixed_distr_law_data), mixed_distr_law_laws τ.

  Definition make_mixed_distr_law
             (τ : mixed_distr_law_data)
             (Hτ : mixed_distr_law_laws τ)
    : mixed_distr_law
    := τ ,, Hτ.

  Coercion mixed_distr_law_to_cell
           (τ : mixed_distr_law)
    : e · f ==> f · e
    := pr1 τ.
End MixedDistributiveLaw.

Section FromBicatToMixedDistrLaw.
  Context {B : bicat}
          (m : mnd (op2_bicat (mnd (op2_bicat B)))).

  Let x : B := pr1 (ob_of_mnd m).
  Let e : x --> x := pr112 (ob_of_mnd m).
  Let ε : e ==> id₁ _ := pr1 (pr212 (ob_of_mnd m)).
  Let δ : e ==> e · e := pr2 (pr212 (ob_of_mnd m)).

  Let f : x --> x := pr1 (endo_of_mnd m).
  Let η : id₁ _ ==> f := pr1 (unit_of_mnd m).
  Let μ : f · f ==> f := pr1 (mult_of_mnd m).

  Definition to_comnd_data_of_mixed_distr_law
    : comnd_data B.
  Proof.
    use make_comnd_data.
    - exact x.
    - exact e.
    - exact ε.
    - exact δ.
  Defined.

  Definition to_comnd_laws_of_mixed_distr_law
    : comnd_laws to_comnd_data_of_mixed_distr_law.
  Proof.
    repeat split.
    - unfold comnd_counit_left_law.
      rewrite !vassocl.
      exact (pr122 (ob_of_mnd m)).
    - unfold comnd_counit_right_law.
      rewrite !vassocl.
      exact (pr1 (pr222 (ob_of_mnd m))).
    - unfold comnd_comult_assoc_law.
      rewrite !vassocl.
      exact (pr2 (pr222 (ob_of_mnd m))).
  Qed.

  Definition to_comnd_of_mixed_distr_law
    : comnd B.
  Proof.
    use make_comnd.
    - exact to_comnd_data_of_mixed_distr_law.
    - exact to_comnd_laws_of_mixed_distr_law.
  Defined.

  Definition to_mnd_data_of_mixed_distr_law
    : mnd_data B.
  Proof.
    use make_mnd_data.
    - exact x.
    - exact f.
    - exact η.
    - exact μ.
  Defined.

  Definition to_is_mnd_of_mixed_distr_law
    : is_mnd B to_mnd_data_of_mixed_distr_law.
  Proof.
    repeat split.
    - exact (maponpaths pr1 (mnd_unit_left m)).
    - exact (maponpaths pr1 (mnd_unit_right m)).
    - exact (maponpaths pr1 (mnd_mult_assoc m)).
  Qed.

  Definition to_mnd_of_mixed_distr_law
    : mnd B.
  Proof.
    use make_mnd.
    - exact to_mnd_data_of_mixed_distr_law.
    - exact to_is_mnd_of_mixed_distr_law.
  Defined.

  Definition to_cell_of_mixed_distr_law
    : mixed_distr_law_data
        to_comnd_of_mixed_distr_law
        (pr2 to_mnd_of_mixed_distr_law)
    := pr112 (endo_of_mnd m).

  Definition to_laws_of_mixed_distr_law
    : mixed_distr_law_laws _ _ to_cell_of_mixed_distr_law.
  Proof.
    repeat split.
    - cbn.
      rewrite !vassocl.
      exact (pr1 (pr212 (endo_of_mnd m))).
    - cbn.
      rewrite !vassocl.
      exact (pr2 (pr212 (endo_of_mnd m))).
    - exact (pr112 (unit_of_mnd m)).
    - refine (pr112 (mult_of_mnd m) @ _).
      cbn.
      rewrite !vassocl.
      apply idpath.
  Qed.

  Definition to_mixed_distr_law
    : mixed_distr_law
        to_comnd_of_mixed_distr_law
        (pr2 to_mnd_of_mixed_distr_law).
  Proof.
    use make_mixed_distr_law.
    - exact to_cell_of_mixed_distr_law.
    - exact to_laws_of_mixed_distr_law.
  Defined.
End FromBicatToMixedDistrLaw.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.micromega.Lia.
Require Import Coq.Vectors.Vector.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Core.Core.
Require Import Cava.Lib.CavaPrelude.
Require Import Cava.Lib.CombinationalProperties.
Require Import Cava.Lib.CombinatorsProperties.
Require Import Cava.Lib.VecProperties.
Require Import Cava.Semantics.Combinational.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.BitArithmeticProperties.
Require Import Cava.Util.Nat.
Require Import Cava.Util.Tactics.
Require Import Cava.Util.Vector.

Lemma zero_correct : zero = false.
Proof. reflexivity. Qed.
Hint Rewrite @zero_correct using solve [eauto] : simpl_ident.

Lemma one_correct : one = true.
Proof. reflexivity. Qed.
Hint Rewrite @one_correct using solve [eauto] : simpl_ident.

Lemma all_correct {n} v :
  all (n:=n) v = Vector.fold_left andb true v.
Proof.
  destruct n; [ eapply case0 with (v:=v); reflexivity | ].
  cbv [all]. simpl_ident.
  eapply (tree_equiv (t:=Bit));
    intros; boolsimpl; try reflexivity; try lia;
      auto using Bool.andb_assoc.
Qed.
Hint Rewrite @all_correct using solve [eauto] : simpl_ident.

Lemma any_correct {n} v :
  any (n:=n) v = Vector.fold_left orb false v.
Proof.
  destruct n; [ eapply case0 with (v:=v); reflexivity | ].
  cbv [any]. simpl_ident.
  eapply (tree_equiv (t:=Bit));
    intros; boolsimpl; try reflexivity; try lia;
      auto using Bool.orb_assoc.
Qed.
Hint Rewrite @any_correct using solve [eauto] : simpl_ident.

Lemma eqb_correct {t} (i : combType t * combType t) :
  eqb i = combType_eqb (fst i) (snd i).
Proof.
  destruct i as [x y]; revert x y.
  induction t;
    cbn [eqb and2 xnor2 one
             CombinationalSemantics] in *;
    intros; simpl_ident; repeat destruct_pair_let;
    (* handle easy cases first *)
    repeat lazymatch goal with
           | x : unit |- _ => destruct x
           | x : combType Bit |- _ => destruct x
           | |- (?x = ?x <-> ?y = ?y) => split; reflexivity
           | _ => first [ progress cbn [List.map combine fst snd xnorb xorb negb]
                       | split; (congruence || reflexivity) ]
           end.
  { (* Vector case *)
    simpl_ident. cbn [combType_eqb].
    rewrite eqb_fold. apply f_equal.
    auto using map2_ext. }
Qed.

Lemma eqb_eq {t} (x y : combType t) :
  eqb (x,y) = true <-> x = y.
Proof.
  rewrite eqb_correct. split.
  { inversion 1. apply combType_eqb_true_iff. auto. }
  { intros; subst. f_equal.
    apply combType_eqb_true_iff. reflexivity. }
Qed.

Lemma eqb_refl {t} (x : combType t) : eqb (x, x) = true.
Proof. apply eqb_eq. reflexivity. Qed.

Lemma eqb_neq {t} (x y : combType t) : x <> y ->  eqb (x, y) = false.
Proof.
  rewrite eqb_correct; intros. f_equal.
  apply Bool.not_true_is_false.
  rewrite combType_eqb_true_iff. auto.
Qed.

Lemma eqb_nat_to_bitvec_sized sz n m :
  n < 2 ^ sz -> m < 2 ^ sz ->
  eqb (t:=Vec Bit sz) (nat_to_bitvec_sized sz n, nat_to_bitvec_sized sz m)
  = if Nat.eqb n m then true else false.
Proof.
  intros; destruct_one_match; subst; [ solve [apply (eqb_refl (t:=Vec Bit sz))] | ].
  apply (eqb_neq (t:=Vec Bit sz)). cbv [nat_to_bitvec_sized].
  rewrite N2Bv_sized_eq_iff with (n:=sz) by auto using N.size_nat_le_nat.
  lia.
Qed.


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.micromega.Psatz.
Require Import CommonKnowledge.Relations.SetoidMappings.
Require Import CommonKnowledge.Relations.Mappings.
Require Import CommonKnowledge.Relations.SetoidCountable.
Require Import CommonKnowledge.Relations.Countable.
Require Import CommonKnowledge.Relations.RelationConstructors.
Require Import CommonKnowledge.Relations.Countable.

Class PropositionalVariables: Type := {
  Var: Type
}.

Inductive expr {Sigma: PropositionalVariables}: Type :=
  | andp : expr -> expr -> expr
  | orp : expr -> expr -> expr
  | impp : expr -> expr -> expr
  | falsep : expr
  | varp : Var -> expr.

Arguments expr Sigma: clear implicits.

Definition rank {Sigma: PropositionalVariables}: expr Sigma -> nat :=
  fix rank (x: expr Sigma): nat :=
    match x with
    | andp y z => 1 + rank y + rank z
    | orp y z => 1 + rank y + rank z
    | impp y z => 1 + rank y + rank z
    | falsep => 0
    | varp p => 0
    end.

Definition formula_countable: forall {Sigma}, Countable Var -> Countable (expr Sigma).
  intros.
  assert (forall n, Countable (sig (fun x: expr Sigma => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ (Var + unit)%type); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun x =>
               match x with
               | inl p => exist (fun x: expr Sigma => rank x <= 0) (varp p) (le_n 0)
               | inr _ => exist (fun x: expr Sigma => rank x <= 0) falsep (le_n 0)
               end)).
      * hnf; intros.
        destruct a1 as [? | []], a2 as [? | []]; inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        1: exists (inr tt); eauto; f_equal; apply proof_irrelevance.
        1: exists (inl v); eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Sigma => rank x <= n)).
      apply (@injection_Countable _ (s * s + s * s + s * s + unit + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (inl (inl (inl (exist _ y _, exist _ z _)))) => proj1_sig x = andp y z
        | inl (inl (inl (inr (exist _ y _, exist _ z _)))) => proj1_sig x = orp y z
        | inl (inl (inr (exist _ y _, exist _ z _))) => proj1_sig x = impp y z
        | inl (inr _) => proj1_sig x = falsep
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | y z | y z | | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by lia. assert (rank z <= n) by lia.
                exists (inl (inl (inl (inl (exist _ y H0, exist _ z H1))))); auto.
        (* 2 *) simpl in H. assert (rank y <= n) by lia. assert (rank z <= n) by lia.
                exists (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))); auto.
        (* 3 *) simpl in H. assert (rank y <= n) by lia. assert (rank z <= n) by lia.
                exists (inl (inl (inr (exist _ y H0, exist _ z H1)))); auto.
        (* 4 *) exists (inl (inr tt)); auto.
        (* 5 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | y z | y z | | p] ?H];
        destruct b1 as [[[[[[y1 ?H] [z1 ?H]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] |] | p1]; try solve [inversion H];
        destruct b2 as [[[[[[y2 ?H] [z2 ?H]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] |] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) destruct u, u0; auto.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[[[[y ?H] [z ?H]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] |] | p];
        destruct a1 as [[y1 z1 | y1 z1 | y1 z1 | | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | y2 z2 | y2 z2 | | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Sigma => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed.


(** Delay monad ****************************************************************)

CoInductive Delay (t : Type) : Type :=
| Now  : t -> Delay t
| Wait : Delay t -> Delay t.
Arguments Now {t} v.
Arguments Wait {t} d.

CoFixpoint bot {X} : Delay X :=
  Wait bot.

Definition peek {A} (x : Delay A) : Delay A :=
  match x with
  | Now v => Now v
  | Wait y => Wait y
  end.

Theorem peekThm : forall A (x : Delay A), x = peek x.
Proof.
  destruct x; reflexivity.
Qed.

(* Either both terminate in the same number of steps, or both diverge *)
CoInductive sim A : Delay A -> Delay A -> Prop :=
| ENow   : forall v, sim A (Now v) (Now v)
| EWait : forall w1 w2, sim A w1 w2 -> sim A (Wait w1) (Wait w2).

Inductive eval A : Delay A -> A -> Prop :=
| eNow  : forall x, eval A (Now x) x
| eWait : forall w x, eval A w x -> eval A (Wait w) x.
Arguments eNow {_}.
Arguments eWait {_ _ _}.

Definition approxEq A (d1 d2: Delay A) : Prop :=
  forall (v : A), eval A d1 v <-> eval A d2 v.

CoFixpoint bind {A B} (x : Delay A) : (forall (v : A), eval A x v -> Delay B) -> Delay B :=
  match x return (forall (v : A), eval A x v -> Delay B) -> Delay B with
  | Now v => fun f => f v (eNow v)
  | Wait w => fun f => Wait (bind w (fun v' p' => f v' (eWait p')))
  end.
Arguments bind {_ _}.

CoFixpoint join {A} (x : Delay (Delay A)) : Delay A :=
  match x with
  | Now v => v
  | Wait w => Wait (join w)
  end.

Notation "m >>= f" := (bind m f) (at level 42, left associativity).
Notation "m1 >> m2" := (bind m1 (fun _ => m2)) (at level 42, left associativity).
Definition mret t (x : t) := Now x.
Arguments mret {t} x.

Definition fwait {A B} (w : Delay A)
           (f : forall (y : A), eval A (Wait w) y -> Delay B)
           (y : A) (w : eval A w y) : Delay B :=
  f y (eWait w).

Lemma evalBind :
  forall A B (x : A) (y : B)
    (m : Delay A) (f : forall (x : A), eval A m x -> Delay B)
    (pr0 : eval A m x) (pr1 : eval B (m >>= f) y),
    eval B (f x pr0) y.
Proof.
  fix IH 7.
  intros A B x y m f pr0 pr1.
  rewrite (peekThm _ (_ >>= _)) in pr1.
  destruct pr0.
  - rewrite (peekThm _ (f _ _)); trivial.
  - simpl in *; inversion pr1; subst.
    apply (IH _ _ _ y w (fwait w f) pr0 H0).
Qed.
Arguments evalBind {_ _ _ _ _ _}.

Lemma evalNow : forall A (x y : A), eval A (Now x) y -> y = x.
Proof.
  intros A x y pr; inversion pr; reflexivity.
Qed.
Arguments evalNow {_ _ _}.

Notation "A ~> B" := (A -> Delay B) (at level 99, right associativity).

(** Recursive types ************************************************************)

Inductive functor : Type :=
| pid    : functor
| pconst : Set -> functor
| pprod  : functor -> functor -> functor
| psum   : functor -> functor -> functor
| pexp   : Set -> functor -> functor.

Fixpoint comp (P1 : functor) (P2 : functor) : functor :=
  match P1 with
  | pid => P2
  | pconst Y => pconst Y
  | pprod P11 P12 => pprod (comp P11 P2) (comp P12 P2)
  | psum P11 P12 => psum (comp P11 P2) (comp P12 P2)
  | pexp D P1 => pexp D (comp P1 P2)
  end.
Fixpoint Exp P (n : nat) : functor :=
  match n with
  | O => pid
  | S m => comp P (Exp P m)
  end.
Notation " P ^ n " := (Exp P n) (at level 30, right associativity).

Notation " \PI " := (pid) (at level 0) : functor_scope.
Notation " \PK{ X }" := (pconst X) (at level 0) : functor_scope.
Notation " l \PP r " := (pprod l r) (at level 40, left associativity) : functor_scope.
Notation " l \PS r " := (psum l r) (at level 50, left associativity) : functor_scope.

(** Recursive types + delay ****************************************************)

Fixpoint app (P : functor) (A : Set) : Set :=
  match P with
  | pid => A
  | pconst X => X
  | pprod P1 P2 => app P1 A * app P2 A
  | psum P1 P2 => app P1 A + app P2 A
  | pexp D P1 => D ~> app P1 A
  end.

Fixpoint map {A B : Set} (P : functor) (f : A -> B) : app P A -> app P B :=
  match P return app P A -> app P B with
  | pid => fun x => f x
  | pconst _ => fun y => y
  | pprod P1 P2 => fun x => (map P1 f (fst x), map P2 f (snd x))
  | psum P1 P2 => fun x => match x with
                       | inl y => inl (map P1 f y)
                       | inr y => inr (map P2 f y)
                   end
  | pexp D P => fun g r => g r >>= fun v _ => mret (map P f v)
  end.

Fixpoint waitF {A : Set} (F : functor) : app F (Delay A) ~> app F A :=
  match F return app F (Delay A) -> Delay (app F A) with
  | pid => fun x => x
  | pconst _ => fun y => mret y
  | pprod P1 P2 => fun x => waitF P1 (fst x) >>=
                              fun l _ => waitF P2 (snd x) >>=
                                            fun r _ => mret (l, r)
  | psum P1 P2 => fun x => match x with
                       | inl y => waitF P1 y >>= fun v _ => mret (inl v)
                       | inr y => waitF P2 y >>= fun v _ => mret (inr v)
                       end
  | pexp D P => fun g => mret (fun r => g r >>= fun v _ => waitF P v)
  end.

Definition fmap {A B : Set} (P : functor) (f : A ~> B) : app P A ~> app P B :=
  fun x => waitF P (map P f x).

Definition pshape (P : functor) : Set := app P unit.

Inductive posExp (D : Set) (p : functor) (f : D ~> pshape p)
          (pos : pshape p -> Set) : Set :=
| PExp : forall (d : D) (v : pshape p),
    eval _ (f d) v -> pos v -> posExp D p f pos.
Arguments PExp {_ _ _ _}.

Definition valueOfPos {D p f pos} (x : posExp D p f pos) : D :=
  match x with
  | PExp d _ _ _ => d
  end.

Definition shapeOfPos {D p f pos} (x : posExp D p f pos) : pshape p :=
  match x with
  | PExp _ v _ _ => v
  end.

Definition evalOfPos {D p f pos} (x : posExp D p f pos)
  : eval (pshape p) (f (valueOfPos x)) (shapeOfPos x) :=
  match x with
  | PExp _ _ p _ => p
  end.

Definition nextPos {D p f pos} (x : posExp D p f pos) : pos (shapeOfPos x) :=
  match x with
  | PExp _ _ _ s => s
  end.

Definition shape {X} (P : functor) (x : app P X) : pshape P :=
  map P (fun _ => tt) x.

Fixpoint pos (p : functor) : pshape p -> Set :=
  match p return app p unit -> Set with
  | pid          => fun _ => unit
  | pconst x     => fun _ => Empty_set
  | pprod  P1 P2 => fun s => pos P1 (fst s) + pos P2 (snd s)
  | psum   P1 P2 => fun s => match s with
                         | inl s' => pos P1 s'
                         | inr s' => pos P2 s'
                         end
  | pexp  D P1   => fun s => posExp D P1 s (pos P1)
  end %type.

CoInductive App (P : functor) (X : Set) : Set :=
| AppC : forall (s : pshape P), (pos P s ~> X) -> App P X.
Arguments AppC {_ _}.

Definition pmap {X Y : Set} P (f : X -> Y) (v : App P X) : App P Y :=
  match v with
  | AppC s g => AppC s (fun s => g s >>= fun v _ => mret (f v))
  end.

Definition pshapeOf {X} P (x : App P X) : pshape P :=
  match x with
  | AppC s _ => s
  end.

Definition posOf {X} P (x : App P X) : pos P (pshapeOf P x) ~> X :=
  match x return pos P (pshapeOf P x) ~> X with
  | AppC _ p => p
  end.

Definition castShape {P1} {v0 v1 : pshape P1} (eq : v0 = v1)
  : pos P1 v0 -> pos P1 v1 :=
  match eq in (_ = v1) return pos P1 v0 -> pos P1 v1 with
  | eq_refl => fun x => x
  end.

Fixpoint fromApp_ {X : Set} P : forall (s : pshape P), (pos P s ~> X) ~> app P X :=
  match P return forall (s : pshape P), (pos P s ~> X) ~> app P X with
  | pid => fun s f => f tt
  | pconst _ => fun s f => mret s
  | pprod P1 P2 =>
    fun s f => fromApp_ P1 (fst s) (fun i => f (inl i)) >>=
                    fun lv _ => fromApp_ P2 (snd s) (fun i => f (inr i)) >>=
                                   fun rv _ => mret (lv, rv)
  | psum P1 P2 =>
    fun s => match s with
          | inl s' => fun f => fromApp_ P1 s' f >>= fun rv _ => mret (inl rv)
          | inr s' => fun f => fromApp_ P2 s' f >>= fun rv _ => mret (inr rv)
          end
  | pexp D P1 =>
    fun s f => mret (fun d => s d >>= fun r p => fromApp_ P1 r (fun i => f (PExp d r p i)))
  end.

Definition fromApp {X : Set} P (v : App P X) : Delay (app P X) :=
  fromApp_ P (pshapeOf P v) (posOf P v).

Fixpoint toApp {X : Set} P : app P X -> App P X :=
  match P return app P X -> App P X with
  | pid          => fun x => @AppC pid        X tt (fun _ => mret x)
  | pconst A     => fun x => @AppC (pconst A) X x  (fun e => match e with end)
  | pprod  P1 P2 =>
    fun x => match x with
          | (l, r) =>
            match toApp P1 l, toApp P2 r with
            | AppC xl fl, AppC xr fr =>
              @AppC (pprod P1 P2) X
                    (xl, xr)
                    (fun e => match e with
                           | inl e' => fl e'
                           | inr e' => fr e'
                           end)
            end
          end
  | psum   P1 P2 =>
    fun x => match x with
          | inl y => match toApp P1 y with
                    | AppC xy fy => @AppC (psum P1 P2) X (inl xy) fy
                    end
          | inr y => match toApp P2 y with
                    | AppC xy fy => @AppC (psum P1 P2) X (inr xy) fy
                    end
          end
  | pexp   D  P1 =>
    fun x => @AppC (pexp D P1) X
                (fun d => x d >>= fun v _ => mret (pshapeOf P1 (toApp P1 v)))
                (fun p => x (valueOfPos p)
                         >>= fun v1 pr1 =>
                               posOf P1
                                     (toApp P1 v1)
                                     (castShape
                                        (evalNow (evalBind pr1 (evalOfPos p)))
                                        (nextPos p)))
  end.

Inductive Mu (P : functor) : Set :=
| MuI : App P (Mu P) -> Mu P.
Arguments MuI {_}.

Definition MuO P (x : Mu P) : App P (Mu P) :=
  match x with
  | MuI y => y
  end.

Definition iin  P (x : app P (Mu P)) : Mu P := MuI (toApp P x).
Definition iout P (x : Mu P) : Delay (app P (Mu P)) :=
  match x with
  | MuI z => fromApp P z
  end.

CoInductive Nu (P : functor) : Set :=
| NuI : App P (Nu P) -> Nu P.
Arguments NuI {_}.

Definition NuO P (x : Mu P) : App P (Mu P) :=
  match x with
  | MuI y => y
  end.

Definition cin  P (x : app P (Nu P)) : Nu P := NuI (toApp P x).
Definition cout P (x : Nu P) : Delay (app P (Nu P)) :=
  match x with
  | NuI z => fromApp P z
  end.

Lemma app_comp : forall P1 P2 X, app (comp P1 P2) X = app P1 (app P2 X).
Proof.
  induction P1; intros P2 X; simpl;
    try rewrite IHP1_1, IHP1_2; try rewrite IHP1; auto.
Defined.

Lemma exp_S : forall X P n, app P (app (P ^ n) X) = app (P ^ (S n)) X.
Proof.
  intros X P n; revert X; induction P; intros X; simpl;
    repeat rewrite app_comp; auto.
Defined.

Definition castDelay {A B : Set} (pr : A = B) (x : Delay A) : Delay B :=
  match pr in _ = B return Delay A -> Delay B with
  | eq_refl => fun x => x
  end x.

Fixpoint unroll (n : nat) P (x : Nu P) : Delay (app (P^n) (Nu P)) :=
  match n return Delay (app (P^n) (Nu P)) with
  | O => mret x
  | S m => cout P x >>= fun v _ => castDelay
                                 (exp_S (Nu P) P m)
                                 (fmap P (unroll m P) v)
  end.

Definition take (n : nat) P (x : Nu P) : Delay (app (P^n) unit) :=
  join (unroll n P x >>= fun v _ => mret (fmap (P^n) (fun _ => mret tt) v)).

Fixpoint tryUnwrap {A} (fuel : nat) (d : Delay A) : option A :=
  match fuel with
  | O => None
  | S m => match d with
          | Now v => Some v
          | Wait w => tryUnwrap m w
          end
  end.

Definition large := 1.

Fixpoint tryTake (n : nat) P (x : Nu P) : option (app (P^n) unit) :=
  tryUnwrap large (take n P x).

Fail CoFixpoint coindToInd P (x : Nu P) : Delay (Mu P) :=
  cout P x >>= fun px _ => fmap P (fun dx => dx >>= fun x _ => coindToInd P x) px >>= fun r _ => mret (iin P r).

Fixpoint unrollI (n : nat) P (x : Mu P) : Delay (app (P^n) (Mu P)) :=
  match n return Delay (app (P^n) (Mu P)) with
  | O => Now x
  | S m => castDelay
            (exp_S _ P m)
            (iout P x >>= fun v _ => fmap P (unrollI m P) v)
  end.

Definition takeI (n : nat) P (x : Mu P) : Delay (app (P^n) unit) :=
  join (unrollI n P x >>= fun v _ => mret (fmap (P^n) (fun _ => mret tt) v)).

Fixpoint tryTakeI (n : nat) P (x : Mu P) : option (app (P^n) unit) :=
  tryUnwrap large (takeI n P x).

Fail CoFixpoint foldP {A} P (f : app P A ~> A) (x : Mu P) : Delay A :=
  iout P x >>= fun r _ => fmap P (foldP P f) r >>= fun v _ => f v.

Fail CoFixpoint unfoldP {A : Set} P (f : A -> app P A) (x : A) : Delay (Nu P) :=
  cin P ((cofix pmap P0 x : Delay (app P0 (Nu P)) :=
           match P0 as P' return app P' A ~> app P' (Nu P) with
           | pid => fun (x : A) => Wait (unfoldP P f x)
           | pconst _ => fun x => mret x
           | pprod L R => fun x => mret (pmap L (fst x), pmap R (snd x))
           | psum L R => fun x => mret match x with
                                   | inl y => inl (pmap L y)
                                   | inr y => inr (pmap R y)
                                   end
           | pexp D P => fun fx => mret (fun x => fx x >>= fun y _ => mret (pmap P y))
           end x) P (f x)).

Section ExamplesRec.
  Open Scope functor_scope.

  Definition natP : functor := \PK{unit} \PS \PI.

  Definition listP (A : Set) : functor := \PK{unit} \PS \PK{ A } \PP \PI.
  Definition CoList A := Nu (listP A).
  Definition List A := Mu (listP A).

  CoFixpoint build0 (n : nat) : CoList nat :=
    cin (listP nat) (inr (n, build0 (S n))).

  Fixpoint buildI0 (n : nat) (m : nat) : List nat :=
    match n with
    | O => iin (listP nat) (inl tt)
    | S n' => iin (listP nat) (inr (m, buildI0 n' (S m)))
    end.

  Eval compute in tryTake 20 (listP nat) (build0 3).
  Eval compute in tryTakeI 20 (listP nat) (buildI0 3 3).

  Definition ntreeP (A : Set) : functor := \PK{unit} \PS \PK{ A } \PP \PI \PP \PI.
  Definition ltreeP (A : Set) : functor := \PK{A} \PS \PI \PP \PI.
  Definition CoTree A := Nu (ntreeP A).
  Definition Tree A := Mu (ntreeP A).

  CoFixpoint build1 (n : nat) : CoTree nat :=
    cin (ntreeP nat) (inr (n, build1 (n+1), build1 (n * 2))).

  Eval compute in tryTake 8 (ntreeP nat) (build1 0).

  Close Scope functor_scope.
End ExamplesRec.

(*******************************************************************************)
(** SYNTAX & DEFNS *************************************************************)
(*******************************************************************************)

Parameter aType : Set.
Parameter aTerm : Set.

Inductive type : Set :=
| tyUnit : type
| tyPrim : aType -> type
| tyFun  : type -> type -> type
| tyProd : type -> type -> type
| tySum  : type -> type -> type
| tyApp  : pfun -> type -> type
| tyFix  : pfun -> type
with pfun : Set :=
| fnId   : pfun
| fnCnst : type -> pfun
| fnSum  : pfun -> pfun -> pfun
| fnProd : pfun -> pfun -> pfun.

Scheme type_ind_m := Induction for type Sort Prop
  with pfun_ind_m := Induction for pfun Sort Prop.

Parameter PHasType : aTerm -> type -> Prop.

Fixpoint papp (p : pfun) (t : type) {struct p} : type :=
  match p with
  | fnId         => t
  | fnCnst t'    => t'
  | fnSum  p1 p2 => tySum  (papp p1 t) (papp p2 t)
  | fnProd p1 p2 => tyProd (papp p1 t) (papp p2 t)
  end.

Inductive term : Set :=
| tmPrim  : aTerm -> term

| tmUnit  : term
| tmConst : term -> term
(* Identity and compositon *)
| tmId    : term
| tmComp  : term -> term -> term
(* Products *)
| tmFst   : term
| tmSnd   : term
| tmSplit : term -> term -> term
(* Sum *)
| tmInl   : term
| tmInr   : term
| tmCase  : term -> term -> term
(* Functors *)
| tmMap   : pfun -> term -> term
(* Recursion *)
| tmIn    : pfun -> term
| tmOut   : pfun -> term
(* Hylo *)
| tmRec   : pfun -> term -> term -> term.

Inductive HasType : term -> type -> Prop :=
| TyPrim  : forall p t, PHasType p t -> HasType (tmPrim p) t

| TyUnit  : HasType tmUnit tyUnit
| TyConst : forall e t t', HasType e t -> HasType (tmConst e) (tyFun t' t)

| TyId    : forall t, HasType tmId (tyFun t t)
| TyComp  : forall e1 e2 a b c,
    HasType e1 (tyFun b c) ->
    HasType e2 (tyFun a b) ->
    HasType (tmComp e1 e2) (tyFun a c)

| TyFst   : forall a b, HasType tmFst (tyFun (tyProd a b) a)
| TySnd   : forall a b, HasType tmSnd (tyFun (tyProd a b) b)
| TySplit : forall e1 e2 a b c,
    HasType e1 (tyFun a b) ->
    HasType e2 (tyFun a c) ->
    HasType (tmSplit e1 e2) (tyFun a (tyProd b c))

| TyInl   : forall a b, HasType tmInl (tyFun a (tySum a b))
| TyInr   : forall a b, HasType tmInr (tyFun b (tySum a b))
| TyCase  : forall e1 e2 a b c,
    HasType e1 (tyFun a c) ->
    HasType e2 (tyFun b c) ->
    HasType (tmCase e1 e2) (tyFun (tySum a b) c)

| TyMap   : forall p e a b,
    HasType e (tyFun a b) ->
    HasType (tmMap p e) (tyFun (tyApp p a) (tyApp p b))

| TyIn    : forall p, HasType (tmIn p) (tyFun (tyApp p (tyFix p)) (tyFix p))
| TyOut   : forall p, HasType (tmIn p) (tyFun (tyFix p) (tyApp p (tyFix p)))
| TyRec   : forall p e1 e2 a b,
    HasType e1 (tyFun (papp p b) b) ->
    HasType e2 (tyFun a (papp p a)) ->
    HasType (tmRec p e1 e2) (tyFun a b).

Parameter interp_aType : aType -> Set.
Fixpoint interp_type  (t : type) : Set :=
  match t with
  | tyUnit => unit
  | tyPrim k => interp_aType k
  | tyFun a b => interp_type a ~> interp_type b
  | tyProd a b => interp_type a * interp_type b
  | tySum a b => interp_type a + interp_type b
  | tyApp p a => app (interp_pfun p) (interp_type a)
  | tyFix p => Nu (interp_pfun p)
  end
with
interp_pfun (p : pfun) : functor :=
  match p with
  | fnId => pid
  | fnCnst a => pconst (interp_type a)
  | fnProd p q => pprod (interp_pfun p) (interp_pfun q)
  | fnSum p q => psum (interp_pfun p) (interp_pfun q)
  end.

Parameter interp_aTerm : forall (e : aTerm) (A : Set), A -> Prop.

(* XXX: replace "map" by relation *)
CoInductive interp_term : forall {A : Set}, term -> A -> Prop :=
| IPrim : forall A p x, interp_aTerm p A x -> interp_term (tmPrim p) x
| IUnit : interp_term tmUnit tt
| IConst : forall (A B : Set) t (x : B),
    interp_term t x ->
    interp_term (tmConst t) (fun (_ : A) => x)

| IId : forall (A : Set), interp_term tmId (fun (x : A) => x)
| IComp : forall {A B C : Set} (e1 : term) (f1 : B -> C) (e2 : term) (f2 : A -> B),
    interp_term e1 f1 ->
    interp_term e2 f2 ->
    interp_term (tmComp e1 e2) (fun x => f1 (f2 x))

| IFst : forall (A B : Set), interp_term tmFst (fun (x : A * B) => fst x)
| ISnd : forall (A B : Set), interp_term tmSnd (fun (x : A * B) => snd x)
| ISplit : forall (A B C : Set) e1 e2 (f1 : A -> B) (f2 : A -> C),
    interp_term e1 f1 ->
    interp_term e2 f2 ->
    interp_term (tmSplit e1 e2) (fun x => (f1 x, f2 x))

| IInl : forall (A B : Set), interp_term tmInl (fun (x : A) => inl B x)
| IInr : forall (A B : Set), interp_term tmInr (fun (x : B) => inr A x)
| ICase : forall (A B C : Set) e1 e2 (f1 : A -> C) (f2 : B -> C),
    interp_term e1 f1 ->
    interp_term e2 f2 ->
    interp_term (tmCase  e1 e2) (fun x => match x with
                                       | inl y => f1 y
                                       | inr y => f2 y
                                 end)

| IMap : forall (A B : Set) (e : term) (f : A -> B) P,
    interp_term e f ->
    interp_term (tmMap P e) (map (interp_pfun P) f)

| IIn  : forall P, interp_term (tmIn  P) (fun x => cin (interp_pfun P) x)
| IOut: forall P, interp_term (tmOut P) (fun x => cout (interp_pfun P) x)
| IRec: forall (A B : Set) P
          e1 (f1 : A -> app (interp_pfun P) A)
          e2 (f2 : app (interp_pfun P) B -> B)
          (f3 : A -> B),
    interp_term e1 f1 ->
    interp_term e2 f2 ->
    interp_term (tmRec P e1 e2) f3 ->
    interp_term (tmRec P e1 e2)
                (fun x => f2 (map (interp_pfun P) f3 (f1 x))).


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

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*                               Oct 1st 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                                 Group.v                                  *)
(****************************************************************************)

Require Export Monoid.

Set Implicit Arguments.
Unset Strict Implicit.

(* The Type of Groups *)

Section group_laws.

Variable A : Monoid.

Definition Inverses_rel (x y : A) := x +_M y =_S Munit A.

Variable inv : Map A A.

Definition Group_invl := forall x : A, Inverses_rel (inv x) x.

Definition Group_invr := forall x : A, Inverses_rel x (inv x).

End group_laws.

Structure Group : Type :=
  {Gmon :> Monoid;
   Ginv : Map Gmon Gmon;
   Prf_ginv_l : Group_invl Ginv;
   Prf_ginv_r : Group_invr Ginv}.


(* $Id: Refl_corr.v,v 1.4 2003/03/11 13:35:55 lcf Exp $ *)

Require Export Reflection.

Load Opaque_algebra.

Section NormCorrect.

Variable F : CField.
Variable val : varindex->F.
Variable fun : funindex->(PartFunct F).

Syntactic Definition II := (interp F val fun).

Fixpoint MI_mult [e:expr] : expr->expr := [f:expr]
let d = (expr_mult e f) in
  Cases e f of
    e (expr_int ZERO) => (expr_int ZERO)
  | (expr_mult e1 e2) f => (expr_mult e1 (MI_mult e2 f))
  | (expr_int i) (expr_int j) => (expr_int (Zmult i j))
  | _ _ => d
  end.

Opaque Zmult.
Lemma MI_mult_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (MI_mult e f) x[*]y).
Cut (x,y:F)
     (II (expr_int ZERO) y)->(II (expr_int ZERO) x[*]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (MI_mult e2 f) x[*]y))
     ->(II (expr_mult e1 e2) x)
     ->(II f y)
     ->(II (expr_mult e1 (MI_mult e2 f)) x[*]y).
Cut (i,j:Z; x,y:F)
     (II (expr_int i) x)
     ->(II (expr_int j) y)
     ->(II (expr_int (Zmult i j)) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Induction e; Induction f; Simpl; Auto.
Induction z; Simpl; Auto.
Induction z0; Induction z; Simpl; Auto.
Induction z; Simpl; Auto.
Induction z; Simpl; Auto.
Induction z; Simpl; Auto.
Induction f0; Simpl; Auto.
Induction z; Simpl; Auto.
Induction f; Simpl; Auto.
Induction f; Simpl; Auto.
Induction z; Simpl; Auto.
Intros; Apply interp_mult with x y; Algebra.
Intros; Apply interp_wd with ((zring (Zmult i j))::F).
Apply interp_int; Algebra.
Inversion H. Inversion H0.
Step_final ((zring i)[*](zring j)::F).
Intros. Inversion H0.
Apply interp_wd with x0[*](y0[*]y); Algebra .
Apply interp_mult with x0 y0[*]y; Algebra.
Step (x0[*]y0)[*]y; Algebra.
Intros. Inversion H.
Apply interp_wd with ((zring `0`)::F).
Apply interp_int; Algebra .
Step (Zero::F).
Step x[*]Zero.
Step_final x[*](zring `0`).
Qed.
Transparent Zmult.

Fixpoint eq_expr [e:expr] : expr -> bool := [f:expr]
  Cases e f of
    (expr_var n) (expr_var m) => (eq_nat n m)
  | (expr_int z) (expr_int z') => (eq_int z z')
  | (expr_plus e1 e2) (expr_plus f1 f2) => (andb (eq_expr e1 f1) (eq_expr e2 f2))
  | (expr_mult e1 e2) (expr_mult f1 f2) => (andb (eq_expr e1 f1) (eq_expr e2 f2))
  | (expr_div e1 e2) (expr_div f1 f2) => (andb (eq_expr e1 f1) (eq_expr e2 f2))
  | (expr_part n e') (expr_part m f') => (andb (eq_nat n m) (eq_expr e' f'))
  | _ _ => false
  end.

Fixpoint lt_expr [e:expr] : expr -> bool := [f:expr]
  Cases e f of
    (expr_var n) (expr_var m) => (lt_nat n m)
  | (expr_var n) _ => true
  | _ (expr_var n) => false

  | (expr_int z) (expr_int z') => (lt_int z z')
  | (expr_int _) _ => true
  | _ (expr_int _) => false

  | (expr_plus e1 e2) (expr_plus f1 f2) => (orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2)))
  | (expr_plus _ _) _ => true
  | _ (expr_plus _ _) => false

  | (expr_mult e1 e2) (expr_mult f1 f2) => (orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2)))
  | (expr_mult _ _) _ => true
  | _ (expr_mult _ _) => false

  | (expr_div e1 e2) (expr_div f1 f2) => (orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2)))
  | (expr_div _ _) _ => true
  | _ (expr_div _ _) => false

  | (expr_part n e') (expr_part m f') => (orb (lt_nat n m) (andb (eq_nat n m) (lt_expr e' f')))
  end.

Definition le_expr [e,f:expr] := (orb (eq_expr e f) (lt_expr e f)).

Lemma eq_nat_corr : (n,m:nat)((eq_nat n m)=true)->(n=m).
Induction n; Induction m; Simpl; Intros.
Trivial.
Inversion H0.
Inversion H0.
Rewrite (H n1 H1). Trivial.
Qed.

Lemma eq_int_corr : (n,m:Z)((eq_int n m)=true)->(n=m).
Induction n; Induction m; Simpl; Intros.
Trivial.
Inversion H.
Inversion H.
Inversion H.
Rewrite <- (convert_is_POS p). Rewrite <- (convert_is_POS p0).
Cut (convert p)=(convert p0). Auto. Apply eq_nat_corr. Assumption.
Inversion H.
Inversion H.
Inversion H.
Cut p=p0; Intros.
Rewrite H0; Auto.
Rewrite (anti_convert_pred_convert p). Rewrite (anti_convert_pred_convert p0).
Cut (convert p)=(convert p0). Intro. Auto. Apply eq_nat_corr. Assumption.
Qed.

Lemma eq_expr_corr : (e,e':expr)((eq_expr e e')=true)->(e=e').
Induction e; Induction e'; Simpl; Intros; Try Inversion H3; Try Inversion H2; Try Inversion H1; Try Inversion H0; Try Inversion H.
Cut v=v0. Intro. Rewrite H0; Auto. Apply eq_nat_corr; Assumption.
Cut z=z0. Intro. Rewrite H0; Auto. Apply eq_int_corr; Assumption.
Clear H1 H2. Elim (andb_prop ?? H3); Intros.
Cut e0=e2. Cut e1=e3. Intros. Rewrite H4; Rewrite H6. Auto.
Apply H0. Assumption. Apply H. Assumption.
Clear H1 H2. Elim (andb_prop ?? H3); Intros.
Cut e0=e2. Cut e1=e3. Intros. Rewrite H4; Rewrite H6. Auto.
Apply H0. Assumption. Apply H. Assumption.
Clear H1 H2. Elim (andb_prop ?? H3); Intros.
Cut e0=e2. Cut e1=e3. Intros. Rewrite H4; Rewrite H6. Auto.
Apply H0. Assumption. Apply H. Assumption.
Clear H0. Elim (andb_prop ?? H1); Intros.
Cut f=f0. Cut e0=e1. Intros. Rewrite H4. Rewrite H5. Auto.
Apply H. Assumption. Apply eq_nat_corr. Assumption.
Qed.

Fixpoint MV_mult [e:expr] : expr->expr := [f:expr]
let d = (expr_mult e f) in
  Cases e f of
    (expr_mult (expr_var n) e') (expr_var m) =>
      Cases (lt_nat n m) of
        true => (expr_mult (expr_var n) (MV_mult e' f))
      | false => (expr_mult f e)
      end
  | (expr_mult (expr_var n) e') (expr_part _ _) =>
      (expr_mult (expr_var n) (MV_mult e' f))
  | (expr_mult (expr_part _ _) e') (expr_var _) =>
      (expr_mult f e)
  | (expr_mult (expr_part n e') e0) (expr_part m f') =>
      Cases (lt_expr (expr_part n e') f) of
        true => (expr_mult (expr_part n e') (MV_mult e0 f))
      | false => (expr_mult f e)
      end
  | (expr_int i) f => (MI_mult (expr_mult f expr_one) e)
  | _ _ => d
  end.

Opaque MI_mult.
Lemma MV_mult_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (MV_mult e f) x[*]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (MV_mult e2 f) x[*]y))
     ->(II (expr_mult e1 e2) x)
     ->(II f y)
     ->(II (expr_mult e1 (MV_mult e2 f)) x[*]y).
Cut (e,f:expr; x,y:F)
     (II e x)->(II f y)->(II (MI_mult (expr_mult f expr_one) e) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult f e) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Intros H H0 H1 H2 e. Elim e.
Simpl; Auto.
Simpl; Auto.
Intros e1 H3 e2 H4.
Elim e1; Simpl; Auto.
Intros e1 H3 e2 H4.
Elim e1; Simpl; Auto.
Intros n f.
Elim f; Simpl; Auto.
Intro m.
Elim (lt_nat n m); Simpl; Auto.
Intros n f.
Intros H5 f0.
Elim f0; Simpl; Auto.
Intros f1 e0 H6.
Elim (orb (lt_nat n f1) (andb (eq_nat n f1) (lt_expr f e0))); Simpl; Auto.
Intros e1 H3 e2 H4.
Elim e1; Simpl; Auto.
Intros n f.
Elim f; Simpl; Auto.
Intros; Apply interp_mult with x y; Algebra.
Intros; Apply interp_wd with y[*]x; Algebra.
Apply interp_mult with y x; Algebra.
Intros; Apply interp_wd with (y[*]One)[*]x.
Apply MI_mult_corr; Auto.
Apply interp_mult with y (One::F); Algebra .
Unfold expr_one.
Apply interp_int; Algebra .
Step_final x[*](y[*]One).
Intros. Inversion H0.
Apply interp_wd with x0[*](y0[*]y).
Apply interp_mult with x0 y0[*]y; Algebra.
Step_final (x0[*]y0)[*]y.
Qed.
Transparent MI_mult.

Fixpoint MM_mult [e:expr] : expr->expr := [f:expr]
let d = (expr_mult e f) in
  Cases e f of
    (expr_mult e1 e2) f => (MV_mult (MM_mult e2 f) e1)
  | (expr_int i) f => (MI_mult f e)
  | _ _ => d
  end.

Opaque MV_mult MI_mult.
Lemma MM_mult_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (MM_mult e f) x[*]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (MM_mult e2 f) x[*]y))
     ->(II (expr_mult e1 e2) x)
     ->(II f y)
     ->(II (MV_mult (MM_mult e2 f) e1) x[*]y).
Cut (i:Z; f:expr; x,y:F)
     (II (expr_int i) x)->(II f y)->(II (MI_mult f (expr_int i)) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros; Apply interp_mult with x y; Algebra.
Intros; Apply interp_wd with y[*]x; Algebra.
Apply MI_mult_corr; Auto.
Intros. Inversion H0.
Apply interp_wd with (y0[*]y)[*]x0.
Apply MV_mult_corr; Auto.
Step x0[*](y0[*]y).
Step_final (x0[*]y0)[*]y.
Qed.
Transparent MV_mult MI_mult.

Fixpoint MM_plus [e:expr] : expr->expr := [f:expr]
let d = (expr_plus e f) in
  Cases e f of
    (expr_mult (expr_var n) e') (expr_mult (expr_var m) f') =>
      Cases (eq_nat n m) of
        true => (MV_mult (MM_plus e' f') (expr_var n))
      | false => d
      end
  | (expr_mult (expr_part g arg) e') (expr_mult (expr_part h arg') f') =>
      Cases (andb (eq_nat g h) (eq_expr arg arg')) of
        true => (MV_mult (MM_plus e' f') (expr_part g arg))
      | false => d
      end
  | (expr_int i) (expr_int j) => (expr_int (Zplus i j))
  | _ _ => d
  end.

Opaque MV_mult.
Lemma MM_plus_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (MM_plus e f) x[+]y).
Cut (i,j:Z; x,y:F)
     (II (expr_int i) x)
     ->(II (expr_int j) y)
     ->(II (expr_int (Zplus i j)) x[+]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_plus e f) x[+]y).
Intros H H0 e; Elim e.
Simpl; Auto.
Intros z f; Elim f; Simpl; Auto.
Simpl; Auto.
Intros e1 H1 e2 H2.
Elim e1; Simpl; Auto.
Intros n f.
Elim f; Simpl; Auto.
Intros f1 H3 f2 H4.
Elim f1; Simpl; Auto.
Intro m.
Cut (eq_nat n m)=true->n=m.
Elim (eq_nat n m); Simpl; Auto.
Intros. Inversion H6. Inversion H7.
Apply interp_wd with (y0[+]y1)[*]x0.
Apply MV_mult_corr; Auto.
Step x0[*](y0[+]y1).
Step x0[*]y0[+]x0[*]y1.
Cut x0[=]x1. Intro.
Step_final x0[*]y0[+]x1[*]y1.
Apply refl_interp with val fun (expr_var n).
Assumption.
Rewrite (H5 (refl_equal ? true)). Assumption.
Intros; Apply eq_nat_corr; Auto.
Intros f e0 H3.
Intro f0.
Elim f0; Simpl; Auto.
Intros e3 H4 e4 H5.
Elim e3; Simpl; Auto.
Intros f1 e5 H6.
Cut (andb (eq_nat f f1) (eq_expr e0 e5))=true->(f=f1).
Cut (andb (eq_nat f f1) (eq_expr e0 e5))=true->e0=e5.
Elim (andb (eq_nat f f1) (eq_expr e0 e5)); Simpl; Auto.
Intros. Inversion H9. Inversion H10. Apply interp_wd with (y0[+]y1)[*]x0.
Apply MV_mult_corr; Auto.
Stepr (x0[*]y0)[+](x1[*]y1). Step (y0[*]x0)[+](y1[*]x0).
Apply bin_op_wd_unfolded. Algebra. Stepr y1[*]x1. Apply mult_wd_rht.
Clear H6 H5 H4 H3 H2 H1.
Clear H9 H10.
Apply refl_interp with val fun (expr_part f e0).
Auto. Rewrite H7; Auto. Rewrite H8; Auto.
Intro. Elim (andb_prop ?? H7); Intros. Apply eq_expr_corr; Auto.
Intro. Elim (andb_prop ?? H7); Intros. Apply eq_nat_corr; Auto.
Simpl; Auto.
Simpl; Auto.
Intros; Apply interp_plus with x y; Algebra.
Intros. Inversion H. Inversion H0.
Apply interp_wd with ((zring `i+j`)::F).
Apply interp_int; Algebra.
Step_final ((zring i)[+](zring j)::F).
Qed.
Transparent MV_mult.

Fixpoint eq_monom [e:expr] : expr->bool := [f:expr]
  Cases e f of
    (expr_mult (expr_var n) e') (expr_mult (expr_var m) f') =>
      (andb (eq_nat n m) (eq_monom e' f'))
  | (expr_mult (expr_part n e1) e') (expr_mult (expr_part m f1) f') =>
      (andb (eq_nat n m) (andb (eq_monom e' f') (eq_expr e1 f1)))
  | (expr_int _) (expr_int _) => true
  | _ _ => false
  end.

Fixpoint lt_monom [e:expr] : expr->bool := [f:expr]
  Cases e f of
    (expr_mult (expr_var n) e') (expr_mult (expr_var m) f') =>
      (ifb (eq_nat n m) (lt_monom e' f') (lt_nat n m))
  | (expr_mult (expr_var _) _) (expr_mult (expr_part _ _) _) => true
  | (expr_mult (expr_part n e1) e') (expr_mult (expr_part m f1) f') =>
      (ifb (eq_expr (expr_part n e1) (expr_part m f1)) (lt_expr e' f') (lt_expr (expr_part n e1) (expr_part m f1)))
  | _ (expr_int _) => true
  | _ _ => false
  end.

Fixpoint PM_plus [e:expr] : expr->expr := [f:expr]
let d = (expr_plus e f) in
  Cases e f of
    (expr_plus e1 e2) (expr_int _) => (expr_plus e1 (PM_plus e2 f))
  | (expr_int i) (expr_int j) => (MM_plus e f)
  | (expr_plus e1 e2) f =>
      Cases (eq_monom e1 f) of
        true => (PM_plus e2 (MM_plus e1 f))
      | false =>
          Cases (lt_monom e1 f) of
            true => (expr_plus e1 (PM_plus e2 f))
          | false => (expr_plus f e)
          end
      end
  | (expr_int i) f => (expr_plus f e)
  | _ _ => d
  end.

Opaque MM_plus.
Lemma PM_plus_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (PM_plus e f) x[+]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (PM_plus e2 f) x[+]y))
     ->(II (expr_plus e1 e2) x)
     ->(II f y)
     ->(II (expr_plus e1 (PM_plus e2 f)) x[+]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (PM_plus e2 f) x[+]y))
     ->(II (expr_plus e1 e2) x)
     ->(II f y)
     ->(II (PM_plus e2 (MM_plus e1 f)) x[+]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (MM_plus e f) x[+]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_plus e f) x[+]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_plus f e) x[+]y).
Intros H H0 H1 H2 H3 e. Elim e.
Simpl; Auto.
Intros z f; Elim f; Intros; Simpl; Auto.
Intros e1 H4 e2 H5 f. Simpl.
Elim (lt_monom e1 f); Elim (eq_monom e1 f); Elim f; Intros; Simpl; Auto.
Simpl; Auto.
Simpl; Auto.
Simpl; Auto.
Intros; Apply interp_wd with y[+]x; Algebra.
Apply interp_plus with y x; Algebra.
Intros; Apply interp_plus with x y; Algebra.
Intros; Apply MM_plus_corr; Auto.
Intros. Inversion H0.
Apply interp_wd with y0[+](x0[+]y).
Apply H; Auto.
Apply MM_plus_corr; Auto.
Step (y0[+]x0)[+]y.
Step_final (x0[+]y0)[+]y.
Intros. Inversion H0.
Apply interp_wd with x0[+](y0[+]y).
Apply interp_plus with x0 y0[+]y; Algebra .
Step_final (x0[+]y0)[+]y.
Qed.
Transparent MM_plus.

Fixpoint PP_plus [e:expr] : expr->expr := [f:expr]
let d = (expr_plus e f) in
  Cases e f of
    (expr_plus e1 e2) f => (PM_plus (PP_plus e2 f) e1)
  | (expr_int i) f => (PM_plus f e)
  | _ _ => d
  end.

Opaque PM_plus.
Lemma PP_plus_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (PP_plus e f) x[+]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (PP_plus e2 f) x[+]y))
     ->(II (expr_plus e1 e2) x)
     ->(II f y)
     ->(II (PM_plus (PP_plus e2 f) e1) x[+]y).
Cut (i:Z; f:expr; x,y:F)
     (II (expr_int i) x)->(II f y)->(II (PM_plus f (expr_int i)) x[+]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_plus e f) x[+]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros. Apply interp_plus with x y; Algebra.
Intros. Apply interp_wd with y[+]x; Algebra.
Apply PM_plus_corr; Auto.
Intros. Inversion H0.
Apply interp_wd with (y0[+]y)[+]x0.
Apply PM_plus_corr; Auto.
Step x0[+](y0[+]y).
Step_final (x0[+]y0)[+]y.
Qed.
Transparent PM_plus.

Fixpoint PM_mult [e:expr] : expr->expr := [f:expr]
let d = (expr_mult e f) in
  Cases e f of
    (expr_plus e1 e2) f => (PM_plus (PM_mult e2 f) (MM_mult e1 f))
  | (expr_int i) _ => (PM_plus (expr_int ZERO) (MI_mult f e))
  | _ _ => d
  end.

Opaque PM_plus MM_mult MI_mult.
Lemma PM_mult_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (PM_mult e f) x[*]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (PM_mult e2 f) x[*]y))
     ->(II (expr_plus e1 e2) x)
     ->(II f y)
     ->(II (PM_plus (PM_mult e2 f) (MM_mult e1 f)) x[*]y).
Cut (i:Z; f:expr; x,y:F)
     (II (expr_int i) x)
     ->(II f y)
     ->(II (PM_plus (expr_int ZERO) (MI_mult f (expr_int i))) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros. Apply interp_mult with x y; Algebra.
Intros. Apply interp_wd with (zring `0`)[+](y[*]x).
Apply PM_plus_corr.
Apply interp_int; Algebra .
Apply MI_mult_corr; Auto.
Step Zero[+]y[*]x.
Step_final y[*]x.
Intros. Inversion H0.
Apply interp_wd with y0[*]y[+]x0[*]y.
Apply PM_plus_corr; Auto.
Apply MM_mult_corr; Auto.
Step (y0[+]x0)[*]y.
Step_final (x0[+]y0)[*]y.
Qed.
Transparent PM_plus MM_mult MI_mult.

Fixpoint PP_mult [e:expr] : expr->expr := [f:expr]
let d = (expr_mult e f) in
  Cases e f of
    (expr_plus e1 e2) f => (PP_plus (PM_mult f e1) (PP_mult e2 f))
  | (expr_int i) f => (PM_mult f e)
  | _ _ => d
  end.

Opaque PP_plus PM_mult.
Lemma PP_mult_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (PP_mult e f) x[*]y).
Cut (e1,e2,f:expr; x,y:F)
     ((f:expr; x,y:F)(II e2 x)->(II f y)->(II (PP_mult e2 f) x[*]y))
     ->(II (expr_plus e1 e2) x)
     ->(II f y)
     ->(II (PP_plus (PM_mult f e1) (PP_mult e2 f)) x[*]y).
Cut (i:Z; f:expr; x,y:F)
     (II (expr_int i) x)->(II f y)->(II (PM_mult f (expr_int i)) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros. Apply interp_mult with x y; Algebra.
Intros. Apply interp_wd with y[*]x; Algebra.
Apply PM_mult_corr; Auto.
Intros. Inversion H0.
Apply interp_wd with y[*]x0[+]y0[*]y.
Apply PP_plus_corr; Auto.
Apply PM_mult_corr; Auto.
Step x0[*]y[+]y0[*]y.
Step_final (x0[+]y0)[*]y.
Qed.
Transparent PP_plus PM_mult.

Definition FF_plus [e:expr] : expr->expr := [f:expr]
let d = (expr_plus e f) in
  Cases e f of
    (expr_div e1 e2) (expr_div f1 f2) =>
      (expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1)) (PP_mult e2 f2))
  | _ _ => d
  end.

Lemma FF_plus_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (FF_plus e f) x[+]y).
Cut (e1,e2,f1,f2:expr; x,y:F)
     (II (expr_div e1 e2) x)
     ->(II (expr_div f1 f2) y)
     ->(II
         (expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1))
           (PP_mult e2 f2)) x[+]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_plus e f) x[+]y).
Intros H H0 e f.
Elim e; Elim f; Intros; Simpl; Auto.
Intros. Apply interp_plus with x y; Algebra.
Intros. Inversion H. Inversion H0.
Cut y0[*]y1[#]Zero. Intro.
Apply interp_div with x0[*]y1[+]y0[*]x1 y0[*]y1 H13; Auto.
Step (x0[*]y1)[/](y0[*]y1)[//]H13[+](y0[*]x1)[/](y0[*]y1)[//]H13.
Step
  (x0[/]y0[//]nzy)[*](y1[/]y1[//]nzy0)[+](y0[/]y0[//]nzy)[*](x1[/]y1[//]nzy0).
Step (x0[/]y0[//]nzy)[*]One[+]One[*](x1[/]y1[//]nzy0).
Step_final x0[/]y0[//]nzy[+]x1[/]y1[//]nzy0.
Apply PP_plus_corr; Auto.
Apply PP_mult_corr; Auto.
Apply PP_mult_corr; Auto.
Apply PP_mult_corr; Auto.
Apply mult_resp_ap_zero; Auto.
Qed.

Definition FF_mult [e:expr] : expr->expr := [f:expr]
let d = (expr_mult e f) in
  Cases e f of
    (expr_div e1 e2) (expr_div f1 f2) =>
      (expr_div (PP_mult e1 f1) (PP_mult e2 f2))
  | _ _ => d
  end.

Lemma FF_mult_corr : (e,f:expr; x,y:F)
  (II e x)->(II f y)->(II (FF_mult e f) x[*]y).
Cut (e1,e2,f1,f2:expr; x,y:F)
     (II (expr_div e1 e2) x)
     ->(II (expr_div f1 f2) y)
     ->(II (expr_div (PP_mult e1 f1) (PP_mult e2 f2)) x[*]y).
Cut (e,f:expr; x,y:F)(II e x)->(II f y)->(II (expr_mult e f) x[*]y).
Intros H H0 e f.
Elim e; Elim f; Intros; Simpl; Auto.
Intros. Apply interp_mult with x y; Algebra.
Intros. Inversion H. Inversion H0.
Cut y0[*]y1[#]Zero. Intro.
Apply interp_div with x0[*]x1 y0[*]y1 H13.
Step_final (x0[/]y0[//]nzy)[*](x1[/]y1[//]nzy0).
Apply PP_mult_corr; Auto.
Apply PP_mult_corr; Auto.
Apply mult_resp_ap_zero; Auto.
Qed.

Definition FF_div [e:expr] : expr->expr := [f:expr]
let d = (expr_div e f) in
  Cases e f of
    (expr_div e1 e2) (expr_div f1 f2) =>
      (expr_div (PP_mult e1 f2) (PP_mult e2 f1))
  | _ _ => d
  end.

Lemma FF_div_corr : (e,f:expr; x,y:F; nzy:y[#]Zero)
  (II e x)->(II f y)->(II (FF_div e f) x[/]y[//]nzy).
Cut (e1,e2,f1,f2:expr; x,y:F; nzy:(y[#]Zero))
     (II (expr_div e1 e2) x)
     ->(II (expr_div f1 f2) y)
     ->(II (expr_div (PP_mult e1 f2) (PP_mult e2 f1)) x[/]y[//]nzy).
Cut (e,f:expr; x,y:F; nzy:(y[#]Zero))
     (II e x)->(II f y)->(II (expr_div e f) x[/]y[//]nzy).
Intros H H0 e f.
Elim e; Elim f; Intros; Simpl; Auto.
Intros. Apply interp_div with x y nzy; Algebra.
Intros. Inversion H. Inversion H0.
Cut x1[#]Zero. Intro nzx1.
Cut y0[*]x1[#]Zero. Intro.
Cut x1[/]y1[//]nzy1[#]Zero. Intro.
Apply interp_div with x0[*]y1 y0[*]x1 H13.
Step (y1[*]x0)[/](y0[*]x1)[//]H13.
Step ((y1[*]x0)[/]y0[//]nzy0)[/]x1[//]nzx1.
Step (y1[*](x0[/]y0[//]nzy0))[/]x1[//]nzx1.
Step ((x0[/]y0[//]nzy0)[*]y1)[/]x1[//]nzx1.
Step_final (x0[/]y0[//]nzy0)[/](x1[/]y1[//]nzy1)[//]H14.
Apply PP_mult_corr; Auto.
Apply PP_mult_corr; Auto.
Apply div_resp_ap_zero_rev; Auto.
Apply mult_resp_ap_zero; Auto.
Apply div_resp_ap_zero with y1 nzy1.
Step y.
Qed.

Fixpoint Norm [e:expr] : expr :=
  Cases e of
    (expr_var n) =>
      (expr_div (expr_plus (expr_mult e expr_one) expr_zero) expr_one)
  | (expr_int i) =>
      (expr_div e expr_one)
  | (expr_plus e1 e2) => (FF_plus (Norm e1) (Norm e2))
  | (expr_mult e1 e2) => (FF_mult (Norm e1) (Norm e2))
  | (expr_div e1 e2) => (FF_div (Norm e1) (Norm e2))
  | (expr_part f e) =>
      (expr_div (expr_plus (expr_mult (expr_part f (Norm e)) expr_one) expr_zero) expr_one)
  end.

Lemma Norm_corr : (e:expr; x:F)(II e x)->(II (Norm e) x).
Intro; Elim e; Intros; Simpl.
Apply (interp_div F val fun
        (expr_plus (expr_mult (expr_var v) expr_one) expr_zero)
        expr_one x (One::F) x (ring_non_triv F)).
Algebra.
Apply (interp_plus F val fun (expr_mult (expr_var v) expr_one) expr_zero x
        (Zero::F) x).
Algebra.
Apply (interp_mult F val fun (expr_var v) expr_one x (One::F) x); Algebra.
Apply (interp_int F val fun `1`); Algebra.
Apply (interp_int F val fun `0`); Algebra.
Apply (interp_int F val fun `1`); Algebra.
Apply (interp_div F val fun (expr_int z) expr_one x (One::F) x (ring_non_triv F)).
Algebra. Algebra. Apply (interp_int F val fun `1`); Algebra.
Inversion H1. Apply interp_wd with x0[+]y. Apply FF_plus_corr; Auto. Auto.
Inversion H1. Apply interp_wd with x0[*]y. Apply FF_mult_corr; Auto. Auto.
Inversion H1. Apply interp_wd with x0[/]y[//]nzy.
Apply FF_div_corr; Auto. Auto.
Apply (interp_div F val fun
        (expr_plus (expr_mult (expr_part f (Norm e0)) expr_one) expr_zero)
        expr_one x (One::F) x (ring_non_triv F)).
Algebra.
Apply (interp_plus F val fun (expr_mult (expr_part f (Norm e0)) expr_one) expr_zero x
        (Zero::F) x).
Algebra.
Apply (interp_mult F val fun (expr_part f (Norm e0)) expr_one x (One::F) x); Algebra.
Inversion H0.
Apply (interp_part F val fun (Norm e0) f x0 x Hx); Auto.
Apply (interp_int F val fun `1`); Algebra.
Apply (interp_int F val fun `0`); Algebra.
Apply (interp_int F val fun `1`); Algebra.
Qed.

Lemma Norm_wf : (e:expr)(wf F val fun e)->(wf F val fun (Norm e)).
Unfold wf.
Intros.
Elim H.
Intros.
Exists x.
Apply Norm_corr.
Assumption.
Qed.

Definition expr_is_zero [e:expr] : Prop :=
  Cases e of
    (expr_div (expr_int ZERO) _) => True
  | _ => False
  end.

Lemma expr_is_zero_corr : (e:expr)(wf F val fun e)->(expr_is_zero e)->(II e Zero).
Unfold wf.
Intros e H.
Elim H. Intro.
Elim e; Simpl; Try (Intros; Tauto).
Intros e0 H0 e1 H1.
Elim e0; Simpl; Try (Intros; Tauto).
Intro.
Elim z; Simpl; Try Tauto; Intros H2 H3.
Inversion H2.
Apply interp_div with (Zero::F) y nzy.
Apply div_prop.
Apply interp_int.
Algebra.
Assumption.
Qed.

Lemma Tactic_lemma_zero : (x:F)(e:(xexpr F val fun x))
  (expr_is_zero (Norm (xforget ???? e)))->(x [=] Zero).
Intros.
Apply refl_interp with val fun (Norm (xforget ???? e)).
Apply Norm_corr.
Apply xexpr2interp.
Apply expr_is_zero_corr.
Apply Norm_wf.
Apply xexpr2wf.
Assumption.
Qed.

Lemma Tactic_lemma : (x,y:F)(e:(xexpr F val fun x))(f:(xexpr F val fun y))
  (expr_is_zero (Norm (xforget ???? (xexpr_minus ????? e f))))->(x [=] y).
Intros.
Apply cg_inv_unique_2.
Apply Tactic_lemma_zero with (xexpr_minus ????? e f).
Assumption.
Qed.

End NormCorrect.


Require Import A1_Plan A2_Orientation A4_Droite A7_Tactics .
Require Import B4_RaysProp B7_Tactics .
Require Import D5_Tactics .
Require Import E1_IntersectionLinesProp E3_FourPointsIntersection E4_Tactics .
Require Import M1_SuperImposedLines M5_Tactics .
Require Import N2_DrawingParallelLine N3_ParallelOpposedLine N4_DiscreteThales.

Unset Standard Proposition Elimination Names.

Section UNICITY_OF_THE_PARALLEL.

Lemma PaschLine : forall A B C D : Point, forall l : Line,
	~Collinear A B C ->
	Between A D B ->
	OnLine l D ->
	~OnLine l A ->
	~OnLine l B ->
	~OnLine l C ->
	(exists E : Point, Between A E C /\ OnLine l E) \/
	(exists F : Point, Between B F C /\ OnLine l F).
Proof.
	intros.
	destruct l; simplLine1.
	byApartCases3 A0 B0 D.
	 by2Cases1 H.

	  destruct (PaschABC A B C D A0 H6 H0).
	   contrapose0 H2; step12 H2.
	   contrapose0 H3; step12 H3.
	   contrapose0 H4; step12 H4.
	   destruct H7 as (P, (H8, H9)).
	     left; exists P; split.
	    immediate12.
	    step12 H8.
	   destruct H7 as (P, (H8, H9)).
	     right; exists P; split.
	    immediate12.
	    step12 H8.

	  destruct (PaschABC B A C D A0 H6).
	   immediate12.
	   contrapose0 H3; step12 H3.
	   contrapose0 H2; step12 H2.
	   contrapose0 H4; step12 H4.
	   destruct H7 as (P, (H8, H9)).
	     right; exists P; split.
	    immediate12.
	    step12 H8.
	   destruct H7 as (P, (H8, H9)).
	     left; exists P; split.
	    immediate12.
	    step12 H8.

	 by2Cases1 H.
	  destruct (PaschABC A B C D B0 H6 H0).
	   contrapose0 H2; step12 H2.
	   contrapose0 H3; step12 H3.
	   contrapose0 H4; step12 H4.
	   destruct H7 as (P, (H8, H9)).
	     left; exists P; split.
	    immediate12.
	    step12 H8.
	   destruct H7 as (P, (H8, H9)).
	     right; exists P; split.
	    immediate12.
	    step12 H8.

	  destruct (PaschABC B A C D B0 H6).
	   immediate12.
	   contrapose0 H3; step12 H3.
	   contrapose0 H2; step12 H2.
	   contrapose0 H4; step12 H4.
	   destruct H7 as (P, (H8, H9)).
	     right; exists P; split.
	    immediate12.
	    step12 H8.
	   destruct H7 as (P, (H8, H9)).
	     left; exists P; split.
	    immediate12.
	    step12 H8.
Qed.

Lemma SecantParallelClockwise : forall d0 d1 : Line, forall A : Point, forall H : ~OnLine d0 A,
	OnLine d1 A ->
	~OnLine d1 (LineA d0) ->
	~OnLine d1 (LineB d0) ->
	Clockwise (LineA d0) (LineB d0) A ->
	SecantLines d1 (Parallel d0 A H) ->
	SecantLines d0 d1.
Proof.
	intros.
	destruct (TwoPointsOnParallel d0 A H H3) as (D, (E, (H5, (H6, (H7, (H8, H9)))))).

	destruct (PaschLine D E (LineB d0) A d1).
	 from12 H7 (Clockwise E D (LineB d0)).
	 immediate12.
	 immediate12.
	 contrapose0 H4.
	   assert (EqLine d1 (Parallel d0 A H)).
	  step12 (A, D).
	    apply OnLineAParallel.
	  step12 H10.
	 contrapose0 H4.
	   assert (EqLine d1 (Parallel d0 A H)).
	  step12 (A, E).
	    apply OnLineAParallel.
	  step12 H10.
	 immediate12.

	 destruct H10 as (F, (H11, H12)).
	   destruct (PaschLine D (LineB d0) (LineA d0) F d1).
	  since12 (Clockwise D (LineA d0) (LineB d0)).
	  immediate12.
	  immediate12.
	  contrapose0 H4.
	    assert (EqLine d1 (Parallel d0 A H)).
	   step12 (A, D).
	     apply OnLineAParallel.
	   step12 H10.
	  immediate12.
	  immediate12.

	  destruct H10 as (G, (H13, H14)).
	    destruct (StrictParallelogrammExistM A D (LineA d0) (LineB d0) G) as (J, (H15, H16)).
	   immediate12.
	   immediate12.
	   step12 (LineA d0, LineB d0, (G, J)).
	    step12 H15.
	      intro; subst.
	      since12 (Clockwise G D (LineA d0)).
	      contradict1 H13 H10.
	    step12 H13.
	      right; immediate12.

	  destruct H10 as (G, (H13, H14)).
	    apply SecantLinesSym; step12 (G, A).
	    destruct d0; simplLine1; immediate12.
	 destruct H10 as (F, (H11, H12)).
	   destruct (StrictParallelogrammExistN E A (LineA d0) (LineB d0) F) as (K, (H13, H14)).
	  immediate12.
	  immediate12.
	  step12 (LineA d0, LineB d0, (A, K)).
	    step12 H13.
	    intro; subst.
	    since12 (Clockwise (LineB d0) E F).
	    contradict1 H11 H10.
Qed.

Lemma SecantParallel : forall d0 d1 : Line, forall A : Point, forall H : ~OnLine d0 A,
	OnLine d1 A ->
	SecantLines d1 (Parallel d0 A H) ->
	SecantLines d0 d1.
Proof.
	intros.
	destruct d0.
	destruct (OnOrNotOnLine d1 A0).
	 apply SecantLinesSym; step12 (A0, A).
	 destruct (OnOrNotOnLine d1 B).
	  apply SecantLinesSym; step12 (B, A).
	  since12 (~ Collinear A0 B A).
	    by2Cases1 H4.
	   apply (SecantParallelClockwise (Ruler A0 B n) d1 A H); immediate12.
	   as12 (EqLine (Ruler A0 B n) (Ruler B A0 (sym_not_eq n))).
	     since12 (~ OnLine (Ruler B A0 (sym_not_eq n)) A).
	    intro; elim H.
	      step12 H6.
	    apply (SecantParallelClockwise (Ruler B A0 (sym_not_eq n)) d1 A H7).
	     immediate12.
	     immediate12.
	     immediate12.
	     immediate12.
	     since12 (EqLine (Parallel (Ruler A0 B n) A H) (Parallel (Ruler B A0 (sym_not_eq n)) A H7)).
	      apply EqParallelOppLines.
	      step12 H8.
Qed.

Lemma EqParallel : forall d0 d1 : Line, forall A : Point, forall H : ~OnLine d0 A,
	OnLine d1 A ->
	ParallelLines d0 d1 ->
	EqLine d1 (Parallel d0 A H).
Proof.
	intros.
	destruct d1.
	byApartCases3 A0 B A.
	 destruct (OnOrNotOnLine (Parallel d0 A H) A0).
	  step12 (A0, A).
	    apply OnLineAParallel.
	  since12 (SecantLines (Ruler A0 B n) (Parallel d0 A H)).
	   step12 (A, A0).
	     apply OnLineAParallel.
	   since12 (SecantLines d0 (Ruler A0 B n)).
	    apply (SecantParallel d0 (Ruler A0 B n) A H); immediate12.
	    elim H5; immediate12.
	 destruct (OnOrNotOnLine (Parallel d0 A H) B).
	  step12 (B, A).
	    apply OnLineAParallel.
	  since12 (SecantLines (Ruler A0 B n) (Parallel d0 A H)).
	   step12 (A, B).
	     apply OnLineAParallel.
	   since12 (SecantLines d0 (Ruler A0 B n)).
	    apply (SecantParallel d0 (Ruler A0 B n) A H); immediate12.
	    elim H5; immediate12.
Qed.

Lemma UniqueParallel : forall d0 d1 d2: Line, forall A : Point,
	OnLine d1 A ->
	OnLine d2 A ->
	ParallelLines d0 d1 ->
	ParallelLines d0 d2 ->
	EqLine d1 d2.
Proof.
	intros; destruct (OnOrNotOnLine d0 A).
	 intros; step12 d0.
	  step12 H1.
	  step12 H2.
	 step12 (Parallel d0 A H3).
	  apply EqParallel; immediate12.
	  apply EqLineSym; apply EqParallel; immediate12.
Qed.

Lemma ParallelSecant : forall d0 d1 d2 : Line,
	ParallelLines d0 d1 ->
	SecantLines d0 d2 ->
	SecantLines d1 d2.
Proof.
	intros.
	setInterLinesPoint4 d0 d2 ipattern:(A).
	destruct (OnOrNotOnLine d1 A).
	 from12 H (EqLine d0 d1).
	   step12 H4.
	 apply (SecantParallel d1 d2 A H3).
	  immediate12.
	  since12 (EqLine d0 (Parallel d1 A H3)).
	   apply EqParallel; immediate12.
	   step12 H4.
Qed.

Lemma  ParallelTrans : forall d0 d1 d2 : Line,
	ParallelLines d0 d1 ->
	ParallelLines d1 d2 ->
	ParallelLines d0 d2.
Proof.
	intros; destruct d2.
	destruct (OnOrNotOnLine d0 A).
	 since12 (EqLine d0 (Ruler A B n)).
	   apply (UniqueParallel d1 d0 (Ruler A B n) A); immediate12.
	 destruct (OnOrNotOnLine (Parallel d0 A H1) B).
	  since12 (EqLine (Ruler A B n) (Parallel d0 A H1)).
	   step12 (A, B).
	     apply OnLineAParallel.
	   step12 H3.
	     apply ParallelParallelLine.
	  since12 (SecantLines (Ruler A B n) (Parallel d0 A H1)).
	   step12 (A, B).
	     apply OnLineAParallel.
	   since12 (SecantLines d1 (Parallel d0 A H1)).
	    apply (ParallelSecant (Ruler A B n)); immediate12.
	    since12 (SecantLines d0 (Parallel d0 A H1)).
	     apply (ParallelSecant d1); immediate12.
	     elim H5; apply ParallelParallelLine.
Qed.

End UNICITY_OF_THE_PARALLEL.


Set Warnings "-notation-overridden".

From Coq Require Export ssreflect ssrfun ssrbool.
From mathcomp Require Export eqtype seq ssrnat fintype.

Lemma and_swap : forall x y z, [&& x, y & z] = [&& y, x & z].
Proof. by case; case; case. Qed.

Definition decide {T : Type} (H : bool)
  (kt : (H = true)  -> T)
  (kf : (H = false) -> T) : T :=
  (fun (if_true  : (fun b : bool => protect_term (H = b) -> T) true)
       (if_false : (fun b : bool => protect_term (H = b) -> T) false) =>
    if H as b return ((fun b0 : bool => protect_term (H = b0) -> T) b)
    then if_true
    else if_false)
  (fun (E : H = true)  => kt E)
  (fun (E : H = false) => kf E)
  (erefl H).

Arguments decide {T} H kt kf.

Definition prop (b : bool) : option (is_true b) :=
  if b then Some is_true_true else None.