(** * The functions of the over-towers defined by T and their iterations.

by Vladimir Voevodsky, started on Jan. 22, 2015 *)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Csystems.hSet_ltowers.
Require Export TypeTheory.Bsystems.T_Tt .

(** ** The definition of an extended operation T and its elementary properties. *)

Definition T_ext_dom { BB : lBsystem_carrier } ( X1 X2 : BB ) :=
  ( ll X1 > 0 ) × ( isover X2 ( ft X1 ) ) .

(** The only difference with [T_dom] is the possibility that X2 is ft X1. *)

Definition T_ext_dom_constr { BB : lBsystem_carrier } { X1 X2 : BB }
           ( gt0 : ll X1 > 0 ) ( isov : isover X2 ( ft X1 ) ) : T_ext_dom X1 X2 :=
  gt0 ,, isov .

Definition T_ext_dom_gt0 { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) :
  ll X1 > 0:= pr1 inn .

Definition T_ext_dom_isov { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) : isover X2 ( ft X1 ) := pr2 inn .

Definition T_dom_to_T_ext_dom { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_dom X1 X2 ) :
  T_ext_dom X1 X2 := T_ext_dom_constr ( T_dom_gt0 inn ) ( T_dom_isabove inn ) .
Coercion T_dom_to_T_ext_dom : T_dom >-> T_ext_dom .

Definition T_dom_to_T_ext_dom_ft { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_dom X1 X2 ) :
  T_ext_dom X1 ( ft X2 ) := T_ext_dom_constr ( T_dom_gt0 inn ) ( isover_ft' ( T_dom_isabove inn ) ) .

Definition T_ext { BB : lBsystem_carrier } ( T : T_ops_type BB )
           { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) : BB .
Proof .
  set ( gt0 := pr1 inn ) . set ( isov := pr2 inn ) .
  destruct ( ovab_choice isov ) as [ isab | eq ] .
  + exact ( T _ _ ( gt0 ,, isab ) ) .
  + exact X1 .
Defined.

(** The second case is the corner case motivated by the first line of p.4 of arXiv:1410.5389v1 when there is no item after En. *)

Lemma isover_T_ext { BB : lBsystem_carrier }
      ( T : T_ops_type BB ) ( ax1b : T_ax1b_type T )
      { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) :
  isover ( T_ext T inn ) X1 .
Proof .
  unfold T_ext .
  destruct ( ovab_choice (pr2 inn) ) as [ isab | eq ] .
  + exact ( ax1b _ _ _ ) .
  + exact ( isover_XX _ ) .
Defined.

(** [T_ext] is monotone in its argument [X2] w.r.t. [isover]: *)

Lemma isover_T_ext_T_ext_2 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 :  T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 X2 X2' : BB } ( inn : T_ext_dom X1 X2 ) ( inn' : T_ext_dom X1 X2' )
      ( is : isover X2 X2' ) : isover ( T_ext T inn ) ( T_ext T inn' ) .
Proof .
  unfold T_ext .
  destruct ( ovab_choice (pr2 inn) ) as [ isab | eq ] .
  + destruct ( ovab_choice (pr2 inn') ) as [ isab' | eq' ] .
    * apply ( isover_T_T_2 ax0 ax1a _ _ is ) .
    * exact ( ax1b _ _ _ ) .
  + destruct ( ovab_choice (pr2 inn') ) as [ isab' | eq' ] .
    * apply fromempty.
      rewrite eq in is .
      assert ( ge := isover_geh is ) .
      assert ( gt := isabove_gth isab' ) .
      exact ( natgthnegleh gt ge ) .
    * exact ( isover_XX _ ) .
Defined.

(** *** The function T_fun of the over-towers defined by the extended operation T *)

Definition T_fun_int { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) ( X2' : ltower_over ( ft X1 ) ) : ltower_over X1 .
Proof .
  set ( X2 := pr1 X2' ) . set ( isov := pr2 X2' : isover X2 ( ft X1 ) ) .
  split with ( T_ext T ( gt0 ,, isov ) )  .

  apply ( isover_T_ext T ax1b ) .

Defined.

(** [T_fun_int] is monotone in the argument [X2'] w.r.t. [isover]: *)

Lemma isovmonot_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 )
      ( X3' X2' : ltower_over ( ft X1 ) ) ( isov : isover X3' X2' ) :
  isover ( T_fun_int ax1b gt0 X3' ) ( T_fun_int ax1b gt0 X2' ) .
Proof .
  apply isinvovmonot_pocto .
  unfold T_fun_int. simpl .
  apply ( isover_T_ext_T_ext_2 ax0 ax1a ax1b ) .
  apply isovmonot_pocto .
  exact isov .

Defined.

Opaque isovmonot_T_fun .

Lemma ll_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) ( X2' : ltower_over ( ft X1 ) ) :
  ll ( T_fun_int ax1b gt0 X2' ) = ll X2' .
Proof.
  change ( ll ( T_ext T ( make_dirprod gt0 ( pr2 X2' ) ) ) - ll X1 = ll X2' ) .
  change ( ll X2' ) with ( ll ( pr1 X2' ) - ll ( ft X1 ) ) .
  unfold T_ext .
  destruct (ovab_choice (pr2 (make_dirprod gt0 (pr2 X2')))) as [ isab | eq ] .
  + rewrite ax0 .
    rewrite ll_ft .
    assert ( ge : ll (pr1 X2') >= ll X1 ) .
    apply natgthminus1togeh .
    rewrite <- ll_ft .
    apply ( isabove_gth isab ) .

    rewrite <- natassocmpeq .
    * rewrite ( natpluscomm _ 1 ) .
      apply natassocpmeq .
      apply ge .
    * apply ge .
    * apply ( @natgthminus1togeh 1 _ gt0 ) .
  + rewrite natminusnn .
    rewrite eq .
    rewrite natminusnn .
    apply idpath .
Defined.

Opaque ll_T_fun .

Lemma isllmonot_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) : isllmonot ( T_fun_int ax1b gt0 ) .
Proof.
  unfold isllmonot .
  intros X Y .
  do 2 rewrite ( ll_T_fun ax0 ) .
  apply idpath .

Defined.

Opaque isllmonot_T_fun .

Lemma isbased_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) : isbased ( T_fun_int ax1b gt0 ) .
Proof.
  red.  intros X eq0 .
  rewrite ll_T_fun .
  + exact eq0.
  + exact ax0.
Defined.

Opaque isbased_T_fun.

Definition T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) :
  ltower_fun ( ltower_over ( ft X1 ) ) ( ltower_over X1 ) :=
  ltower_fun_constr ( isovmonot_T_fun ax0 ax1a ax1b gt0 )
                    ( isllmonot_T_fun ax0 ax1b gt0 )
                    ( isbased_T_fun ax0 ax1b gt0 ) .

(** ** Definition of Tj_fun as iterations of the functions T_fun *)

(** *** Construction of Tj *)

(** The construction of a function requires only an operation of type [T_ops_type] satisfying
    a condition of type [T_ax1b_type] but the proof that it is an ltower function requires
    two other properties of this operation. *)

Definition Tj_fun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           { A X1 : BB } ( isov : isover X1 A ) :
  ltower_fun ( ltower_over A ) ( ltower_over X1 ) :=
  isover_ind ( fun ( X Y : BB ) => ltower_fun ( ltower_over Y ) ( ltower_over X ) )
             ( fun X => ltower_idfun _ )
             ( fun X gt0 => T_fun ax0 ax1a ax1b gt0 )
             ( fun X Y f g => ltower_funcomp g f ) _ _ isov .

Lemma Tj_fun_compt { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X Y : BB } ( isab : isabove X Y ) :
  Tj_fun ax0 ax1a ax1b isab =
  ltower_funcomp ( Tj_fun ax0 ax1a ax1b ( isover_ft' isab ) )
                 ( T_fun ax0 ax1a ax1b ( isabove_gt0 isab ) ) .
Proof.
  unfold Tj_fun .
  rewrite (@isover_ind_isab BB _ _ _ _ _ _ ).
  apply idpath .

Defined.

(*

Lemma Tj_fun_compt0 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X : BB } ( isov : isover X Y ) :
  Tj_fun ax0 ax1a ax1b isab =

Lemma Tj_fun_int_l0 { BB : lBsystem_carrier }
      { A X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = 0 ) : X1 = A .
Proof .
  intros .
  destruct ( ovab_choice isov ) as [ isab | eq ] .
  assert ( absd : empty ) .
  assert ( gt := isabove_gth isab ) .
  assert ( gt0 := minusgth0 _ _ gt ) .
  rewrite ell in gt0 .
  exact ( negnatgthnn _ gt0 ) .

  destruct absd .

  exact eq .

Defined.

Lemma Tj_fun_int_l1 { BB : lBsystem_carrier }
      ( j : nat )
      { A X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = S j ) :
  isover ( ft X1 ) A .
Proof .
  intros .
  assert ( gth : ll X1 > ll A ) .
  apply minusgth0inv .
  rewrite ell .
  exact ( natgthsn0 _ ) .

  exact ( isover_ft' ( isabove_constr gth isov ) ) .

Defined.

Opaque  Tj_fun_int_l1 .

Lemma Tj_fun_int_l2 { BB : lBsystem_carrier }
      ( j : nat )
      { A X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = S j ) :
  ll ( ft X1 ) - ll A = j .
Proof .
  intros .
  rewrite ll_ft .
  rewrite natminuscomm .
  rewrite ell .
  simpl .
  exact ( natminuseqn _ ) .

Defined.

Opaque Tj_fun_int_l2 .

Lemma Tj_fun_int_l3 { BB : lBsystem_carrier }
      ( j : nat )
      { A X1 : BB }
      ( ell : ll X1 - ll A = S j ) : ll X1 > 0 .
Proof .
  intros .
  refine ( natgehgthtrans _ ( ll X1 - ll A ) _ ( natminuslehn _ _ ) _ ) .
  rewrite ell .
  exact ( natgthsn0 _ ) .

Defined.

Opaque Tj_fun_int_l3 .

Definition Tj_fun_int { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax1b : T_ax1b_type T )
           { A : BB }
           ( j : nat )
           { X1 : BB } ( isov : isover X1 A )
           ( ell : ll X1 - ll A = j )
           ( X2' : ltower_over A ) : ltower_over X1 .
Proof .
  intros until j . induction j as [ | j IHj ] .
  intros .
  assert ( eq := Tj_fun_int_l0 isov ell ) .
  split with ( pr1 X2' ) .
  rewrite eq .
  exact ( pr2 X2' ) .

  intros .
  assert ( Tprev := IHj ( ft X1 ) ( Tj_fun_int_l1 j isov ell ) (  Tj_fun_int_l2 j isov ell ) X2' ) .
  exact ( T_fun ax1b ( Tj_fun_int_l3 j ell ) Tprev ) .

Defined.

Definition Tj_fun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax1b : T_ax1b_type T )
           { A X1 : BB } ( isov : isover X1 A ) : ltower_over A -> ltower_over X1 :=
  fun X2' => Tj_fun_int ax1b ( ll X1 - ll A ) isov ( idpath _ ) X2' .

(** **** Proof of monotonicity of Tj relative to the predicate isover *)

Lemma isovmonot_Tj_fun_int { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { A : BB }
      ( j : nat )
      { X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = j )
      ( X2' X3' : ltower_over A ) ( isov' : isover X3' X2' ) :
  isover ( Tj_fun_int ax1b j isov ell X3' ) ( Tj_fun_int ax1b j isov ell X2' ) .
Proof .
  intros until j . induction j as [ | j IHj ] .
  intros .
  assert ( eq := Tj_fun_int_l0 isov ell ) .
  unfold Tj_fun_int .
  simpl .
  apply isinvovmonot_pocto .
  simpl .
  apply isovmonot_pocto .
  exact isov' .

  intros .
  simpl .
  unfold T_fun .
  apply isinvovmonot_pocto .
  simpl .
  apply ( isover_T_ext_T_ext_2 ax0 ax1a ax1b ) .
  apply isovmonot_pocto .
  apply IHj .
  exact isov' .

Defined.

Lemma isovmonot_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 A : BB } ( isov : isover X1 A )
      ( X2' X3' : ltower_over A ) ( isov' : isover X2' X3' ) :
  isover ( Tj_fun ax1b isov X2' ) ( Tj_fun ax1b isov X3' ) .
Proof .
  intros .
  apply ( isovmonot_Tj_fun_int ax0 ax1a ax1b ) .
  exact isov' .

Defined.

(** **** Functions Tj and the length function ll *)

Lemma ll_Tj_fun_int { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A : BB }
      ( j : nat )
      { X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = j )
      ( X2' : ltower_over A ) :
  ll ( Tj_fun_int ax1b j isov ell X2' ) = ll X2' .
Proof .
  intros BB T ax0 ax1b A j .
  induction j as [ | j IHj ] . intros .
  simpl .
  change _ with ( ll ( pr1 X2' ) - ll X1 = ll ( pr1 X2' ) - ll A ) .
  assert ( eq : ll X1 = ll A ) . apply natminusmequalsn .
  apply ( isover_geh isov ) .

  apply ell .

  rewrite eq . apply idpath .

  simpl .

  intros .  rewrite ll_T_fun .
  apply IHj .

  apply ax0 .

Defined.

Lemma ll_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A )
      ( X2' : ltower_over A ) :
  ll ( Tj_fun ax1b isov X2' ) = ll X2' .
Proof.
  intros.
  apply ll_Tj_fun_int .

  apply ax0 .

Defined.

Lemma isllmonot_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A ) : isllmonot ( Tj_fun ax1b isov ) .
Proof.
  intros .
  unfold isllmonot .
  intros X Y .
  repeat rewrite ll_Tj_fun .
  apply idpath .

  apply ax0.

  apply ax0.

Defined.

Lemma isbased_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A ) : isbased ( Tj_fun ax1b isov ) .
Proof.
  intros. unfold isbased. intros X eq0 .
  rewrite ll_Tj_fun .
  exact eq0.

  exact ax0.

Defined.

Definition ltower_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A ) :
  ltower_fun ( ltower_over A ) ( ltower_over X1 ) :=
  ltower_fun_constr ( isovmonot_Tj_fun ax0 ax1a ax1b isov )
                    ( isllmonot_Tj_fun ax0 ax1b isov )
                    ( isbased_Tj_fun ax0 ax1b isov ) .

(** *** Function Tt_fun *)

(* Definition Tt_fun { BB : lBsystem_carrier }
           ( T : T_ops_type BB ) ( Tt : Tt_ops_type BB )
           ( X : BB ) : *)

*)

(** *** Function Tprod for pointed lB-systems *)

Definition Tprod_fun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) :
  ltower_fun BB ( ltower_over X1 ) :=
  ltower_funcomp ( @ltower_fun_to_ltower_over BB )
                 ( Tj_fun ax0 ax1a ax1b ( isoverll0 ( ll_cntr BB ) X1 ) ) .

(* Definition Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X Y : BB ) : BB := pocto ( Tprod_fun ax0 ax1a ax1b X Y ) .

Definition isover_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X Y : BB ) : isover ( Tprod ax0 ax1a ax1b X Y ) X :=
  pr2 ( Tprod_fun ax0 ax1a ax1b X Y ) .  *)

Lemma Tprod_compt { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      ( X Y : BB ) ( gt0 : ll X > 0 ) :
  Tprod_fun ax0 ax1a ax1b X Y = T_fun ax0 ax1a ax1b gt0 ( Tprod_fun ax0 ax1a ax1b ( ft X ) Y ) .
Proof.
  simpl .
  unfold funcomp .
  simpl .
  assert ( gt : ll X > ll ( cntr BB ) ) . rewrite (@ll_cntr BB). apply gt0 .

  set ( isab := make_dirprod gt (isoverll0 (ll_cntr BB) X) : isabove X ( cntr BB ) ) .
  change (isoverll0 (ll_cntr BB) X) with ( isabove_to_isover isab ) .
  rewrite Tj_fun_compt .
  simpl .
  assert ( int : (isover_ft' isab) = (isoverll0 (ll_cntr BB) (ft X)) ) by apply isaprop_isover .
  rewrite int .
  assert ( int' : gt0 = (isabove_gt0 isab) ) by apply ( pr2 ( _ > _ ) ) .
  rewrite int' . apply idpath .
Defined.

(*

Proof .
  intros .
  set ( X2' := @to_ltower_over BB X2 ) .
  exact ( Tj_fun ax0 ax1a ax1b ( isoverll0 ( ll_cntr BB ) X1 ) X2' ) .

Defined.

Lemma isovmonot_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T )  ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : isovmonot ( Tprod ax1b X1 ) .
Proof .
  intros .
  unfold isovmonot .
  intros X Y isov .
  set ( X' := @to_ltower_over BB X ) . set ( Y' := @to_ltower_over BB Y ) .
  set ( isov' := isovmonot_to_ltower_over isov ) .
  exact ( isovmonot_Tj_fun ax0 ax1a ax1b ( isoverll0 ( ll_cntr BB ) X1 ) X' Y' isov' ) .

Defined.

Definition Tprod_ovmonotfun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T )  ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : ovmonot_fun BB ( ltower_over X1 ) :=
  ovmonot_fun_constr ( Tprod ax1b X1 ) ( isovmonot_Tprod ax0 ax1a ax1b X1 ) .

Lemma ll_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) ( X2 : BB ) : ll ( Tprod ax1b X1 X2 ) = ll X2 .
Proof .
  intros .
  unfold Tprod .
  rewrite ll_Tj_fun .
  rewrite (@ll_to_ltower_over BB).
  apply idpath .

  apply ax0 .

Defined.

Lemma isllmonot_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : isllmonot ( Tprod ax1b X1 ) .
Proof .
  intros . unfold isllmonot .  intros X Y .
  repeat rewrite ll_Tprod . apply idpath .

  apply ax0 .

  apply ax0 .

Defined.

Lemma isbased_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : isbased ( Tprod ax1b X1 ) .
Proof.
  intros. unfold isbased . intros X eq0 .
  rewrite ll_Tprod .

  exact eq0.

  exact ax0.

Defined.

Definition ltower_fun_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) :
  ltower_fun BB ( ltower_over X1 ) :=
  ltower_fun_constr ( isovmonot_Tprod ax0 ax1a ax1b X1 )
                    ( isllmonot_Tprod ax0 ax1b X1 )
                    ( isbased_Tprod ax0 ax1b X1 ) .

(*

Definition isabove_Tj { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 X2 : BB } ( isov : isover X1 A ) ( isab : isabove X2 A ) :
  isabove ( Tj ax0 ax1b isov isab ) X1 :=
  pr1 ( pr2 ( Tj_int_package ax0 ax1b ( ll X1 - ll A ) isov ( idpath _ ) isab ) ) .

Opaque isabove_Tj .

Definition ll_Tj { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 X2 : BB } ( isov : isover X1 A ) ( isab : isabove X2 A ) :
  ll ( Tj ax0 ax1b isov isab ) = ll X2 - ll A + ll X1 :=
  pr2 ( pr2 ( Tj_int_package ax0 ax1b ( ll X1 - ll A ) isov ( idpath _ ) isab ) ) .

*)

*)

(* End of the file T_fun.v - used to be T_fun_Tj_Ttj.v *)


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.AbsAppI.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprDI.

Require Import MirrorCore.Util.Compat.

Set Implicit Arguments.
Set Strict Implicit.

Module Make (ED : ExprDenote).

  Hint Rewrite @ED.lambda_exprD_Var @ED.lambda_exprD_UVar @ED.lambda_exprD_Inj @ED.lambda_exprD_Abs @ED.lambda_exprD_App using (eauto with typeclass_instances) : exprD_rw.

  Section with_types.
    Context {typ : Set}.
    Context {RType_typD : RType typ}.
    Context {Typ2_Fun : Typ2 _ RFun}.
    Context {func : Set}.
    Context {RSym_func : RSym func}.

    (** Reasoning principles **)
    Context {RTypeOk_typD : RTypeOk}.
    Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
    Context {RSymOk_func : RSymOk RSym_func}.

    Local Instance RelDec_eq_typ : RelDec (@eq typ) :=
    { rel_dec := fun a b => match type_cast a b with
                              | Some _ => true
                              | None => false
                            end }.

    Local Instance RelDecCorrect_eq_typ : @RelDec_Correct _ (@eq typ) _.
    Proof.
      constructor. split; intros.
      { generalize (@type_cast_total _ _ _ x y). unfold rel_dec in H.
        simpl in *.
        destruct (type_cast x y). auto. congruence. }
      { subst. unfold rel_dec; simpl. rewrite type_cast_refl; auto. }
    Qed.

    Theorem lambda_exprD_ind
    : (*@RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func -> *)
      forall (P : forall tus tvs, _ -> forall t, option (exprT tus tvs (typD t)) -> Prop) tus
        (Hnone : forall tvs e t,
                   ED.lambda_exprD tus tvs t e = None ->
                   P tus tvs e t None)
        (Hvar : forall tvs v t t' get (pf : Rty t t'),
                  nth_error_get_hlist_nth _ tvs v = Some (@existT _ _ t' get) ->
                  P tus tvs (Var v) t
                    (Some (Relim (exprT tus tvs) pf (fun _ (vs : hlist _ tvs) => get vs))))
        (Huvar : forall tvs u t t' get (pf : Rty t t'),
                   nth_error_get_hlist_nth _ tus u = Some (@existT _ _ t' get) ->
                   P tus tvs (UVar u) t
                     (Some (Relim (exprT tus tvs) pf ((fun us _ => get us)))))
        (Hinj : forall tvs i t t' (pf : typeof_sym i = Some t)
                (pf' : Rty t' t),
                  P tus tvs (Inj i) t'
                    (Some (Relim (exprT tus tvs) pf' (fun _ _ =>
                             match pf in _ = t
                                   return match t with
                                            | Some t => typD t
                                            | None => unit
                                          end with
                               | eq_refl => symD i
                             end))))
        (Happ : forall tvs d r f x fval xval,
                  ED.typeof_expr tus tvs x = Some d ->
                  P tus tvs f (typ2 d r) (Some fval) ->
                  P tus tvs x d (Some xval) ->
                  P tus tvs (App f x) r
                    (Some (exprT_App fval xval)))
        (Habs : forall tvs d r e fval,
                  P tus (d :: tvs) e r (Some fval) ->
                  P tus tvs (Abs d e) (typ2 d r) (Some (exprT_Abs fval))),
        forall tvs e t,
        P tus tvs e t (ED.lambda_exprD tus tvs t e).
    Proof.
      intros P tus Pnone Hvar Huvar Hinj Happ Habs tvs e; revert tvs.
      generalize (fun tvs => Pnone tvs e). intro.
      induction e;
      intros; generalize (H tvs t);
      autorewrite with exprD_rw in *; simpl in *;
      repeat match goal with
               | |- context [ match ?X with _ => _ end ] =>
                 (consider X; intros; auto); [ ]
             end.
      { subst. clear Happ Habs Huvar Hinj Pnone.
        specialize (@Hvar _ _ _ _ _ (Rsym r) H1).
        unfold ED.Rcast_val, ED.Rcast, Relim in *.
        generalize dependent (P tus tvs (Var v) t); clear.
        destruct r.
        auto. }
      { clear Habs Happ Huvar Hvar.
        unfold symAs in *.
        specialize (Hinj tvs f).
        generalize dependent (symD f).
        destruct (typeof_sym f); intros.
        { forward. specialize (Hinj _ t eq_refl r).
          generalize dependent (P tus tvs (Inj f) t).
          destruct r.
          simpl. unfold ED.Rcast in H0. simpl in H0.
          inv_all; subst. auto. }
        { exfalso; congruence. } }
      { clear Habs Hinj Huvar Hvar.
        eapply Happ; eauto.
        rewrite <- H1. auto.
        rewrite <- H2. auto. }
      { clear Hinj Huvar Hvar Happ.
        destruct (@typ2_match_case _ _ RFun _ _ t0).
        { specialize (H tvs t0). autorewrite with exprD_rw in *.
          (do 3 destruct H0); rewrite H0 in *; clear H0.
          consider (type_cast x t); intros.
          { specialize (fun H => IHe H (t :: tvs) x0).
            consider (ED.lambda_exprD tus (t :: tvs) x0 e); intros.
            { eapply Habs in IHe; eauto.
              revert IHe. unfold exprT_Abs.
              destruct r.
              match goal with
                | |- _ _ _ _ _ (Some (match ?X with _ => _ end _)) ->
                     _ _ _ _ _ (Relim _ _ match ?Y with _ => _ end) =>
                  change Y with X ; generalize X
              end.
              clear H2. destruct x1.
              simpl. generalize (P tus tvs (Abs x e) t0).
              destruct e1. auto. }
            { match goal with
                | |- context [ match ?X with _ => _ end ] =>
                  generalize dependent X
              end.
              destruct x1. simpl.
              intros. rewrite eq_option_eq. eapply H3.
              clear. rewrite eq_option_eq. reflexivity. } }
          { clear - H0.
            match goal with
              | |- context [ match ?X with _ => _ end ] =>
                generalize dependent X
            end.
            destruct x1. simpl.
            intros. rewrite eq_option_eq. apply H0.
            rewrite eq_option_eq. reflexivity. } }
        { specialize (H tvs t0). autorewrite with exprD_rw in H.
          rewrite H0 in *. intros; apply H. reflexivity. } }
      { subst. clear Happ Habs Hvar Hinj Pnone.
        specialize (@Huvar tvs _ _ _ _ (Rsym r) H1).
        unfold ED.Rcast_val, ED.Rcast, Relim in *.
        generalize dependent (P tus tvs (UVar u) t); clear.
        destruct r.
        auto. }
    Qed.

    Theorem lambda_exprD_ind_with
    : (*@RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func -> *)
      forall (P : forall tus tvs, _ -> forall t, option (exprT tus tvs (typD t)) -> Prop) tus
        (Hnone : forall tvs e t,
                   ED.lambda_exprD tus tvs t e = None ->
                   P tus tvs e t None)
        (Hvar : forall tvs v t t' get (pf : Rty t t'),
                  nth_error_get_hlist_nth _ tvs v = Some (@existT _ _ t' get) ->
                  P tus tvs (Var v) t
                    (Some (Relim (exprT tus tvs) pf (fun _ (vs : hlist _ tvs) => get vs))))
        (Huvar : forall tvs u t t' get (pf : Rty t t'),
                   nth_error_get_hlist_nth _ tus u = Some (@existT _ _ t' get) ->
                   P tus tvs (UVar u) t
                     (Some (Relim (exprT tus tvs) pf ((fun us _ => get us)))))
        (Hinj : forall tvs i t t' (pf : typeof_sym i = Some t)
                (pf' : Rty t' t),
                  P tus tvs (Inj i) t'
                    (Some (Relim (exprT tus tvs) pf' (fun _ _ =>
                             match pf in _ = t
                                   return match t with
                                            | Some t => typD t
                                            | None => unit
                                          end with
                               | eq_refl => symD i
                             end))))
        (Happ : forall tvs d r f x fval xval,
                  ED.typeof_expr tus tvs x = Some d ->
                  P tus tvs f (typ2 d r) (Some fval) ->
                  P tus tvs x d (Some xval) ->
                  P tus tvs (App f x) r
                    (Some (exprT_App fval xval)))
        (Habs : forall tvs d r e fval,
                  P tus (d :: tvs) e r (Some fval) ->
                  P tus tvs (Abs d e) (typ2 d r) (Some (exprT_Abs fval))),
        forall tvs e t,
        P tus tvs e t (ED.lambda_exprD tus tvs t e).
    Proof.
      intros P tus ? ? ? ? ? ? tvs e t.
      cut (ED.lambda_exprD tus tvs t e = ED.lambda_exprD tus tvs t e /\
           P tus tvs e t (ED.lambda_exprD tus tvs t e)).
      { intuition. }
      refine (@lambda_exprD_ind (fun tus tvs e t val =>
                           ED.lambda_exprD tus tvs t e = val /\
                           P tus tvs e t val) tus _ _ _ _ _ _ tvs e t); eauto.
      { intros; split; eauto.
        autorewrite with exprD_rw.
        rewrite H. simpl.
        destruct pf. rewrite type_cast_refl; eauto. }
      { intros; split; eauto.
        autorewrite with exprD_rw.
        rewrite H. simpl.
        destruct pf. rewrite type_cast_refl; eauto. }
      { intros; split; eauto.
        autorewrite with exprD_rw.
        unfold symAs.
        generalize (symD i).
        rewrite pf. destruct pf'. rewrite type_cast_refl; eauto. }
      { intros. destruct H0. destruct H1.
        split; eauto.
        autorewrite with exprD_rw.
        Cases.rewrite_all_goal. reflexivity. }
      { intros. destruct H. split; eauto.
        autorewrite with exprD_rw.
        rewrite typ2_match_iota; eauto.
        rewrite type_cast_refl; eauto. rewrite H.
        simpl. unfold exprT_Abs.
        autorewrite with eq_rw.
        reflexivity. }
    Qed.

    Theorem typeof_expr_weaken
    : RTypeOk -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall tus tvs e t tus' tvs',
        ED.typeof_expr tus tvs e = Some t ->
        ED.typeof_expr (tus ++ tus') (tvs ++ tvs') e = Some t.
    Proof.
      intros ? ? ? tus tvs e; revert tvs.
      induction e; simpl; intros; eauto using ListNth.nth_error_weaken.
      { forward.
        erewrite IHe1; eauto.
        erewrite IHe2; eauto. }
      { forward. change (t :: tvs ++ tvs') with ((t :: tvs) ++ tvs').
        erewrite IHe; eauto. }
    Qed.

    Theorem lambda_exprD_weaken
    : RTypeOk -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall tus tvs (e : expr typ func) t val tus' tvs',
        ED.lambda_exprD tus tvs t e = Some val ->
        exists val',
          ED.lambda_exprD (tus ++ tus') (tvs ++ tvs') t e = Some val' /\
          forall us vs us' vs',
            val us vs = val' (hlist_app us us') (hlist_app vs vs').
    Proof.
      intros ? ? ? tus tvs e t val tus' tvs'.
      revert e t val.
      refine (@lambda_exprD_ind
                (fun tus tvs e t val =>
                   forall val'',
                     val = Some val'' ->
                     exists val' : exprT (tus ++ tus') (tvs ++ tvs') (typD t),
                       ED.lambda_exprD (tus ++ tus') (tvs ++ tvs') t e = Some val' /\
                       (forall (us : hlist typD tus) (vs : hlist typD tvs)
                               (us' : hlist typD tus') (vs' : hlist typD tvs'),
                           val'' us vs = val' (hlist_app us us') (hlist_app vs vs')))
                _ _ _ _ _ _ _ _).
      { congruence. }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl.
        eapply nth_error_get_hlist_nth_weaken in H1.
        simpl in *. destruct H1 as [ ? [ ? ? ] ].
        rewrite H1.
        destruct pf. rewrite type_cast_refl; eauto. }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl.
        eapply nth_error_get_hlist_nth_weaken in H1.
        simpl in *. destruct H1 as [ ? [ ? ? ] ].
        rewrite H1.
        destruct pf. rewrite type_cast_refl; eauto.
        simpl. eexists; split; eauto. intros.
        eapply H2. }
      { intros; inv_all; subst.
        autorewrite with exprD_rw. simpl.
        unfold symAs.
        generalize (symD i). rewrite pf.
        destruct pf'.
        rewrite type_cast_refl; eauto. }
      { simpl; intros.
        specialize (H3 _ eq_refl).
        specialize (H2 _ eq_refl).
        forward_reason; inv_all; subst.
        autorewrite with exprD_rw. simpl.
        erewrite typeof_expr_weaken by eauto.
        rewrite H2. rewrite H3.
        eexists; split; eauto.
        revert H5 H6. clear.
        unfold exprT_App. intros.
        autorewrite_with_eq_rw.
        rewrite <- H6.
        rewrite <- H5. reflexivity. }
      { intros. forward_reason; inv_all; subst.
        specialize (H1 _ eq_refl).
        destruct H1 as [ ? [ ? ? ] ].
        autorewrite with exprD_rw. simpl.
        rewrite typ2_match_iota; eauto.
        rewrite type_cast_refl; eauto.
        simpl in *.
        rewrite H1.
        rewrite eq_option_eq. eexists; split; eauto.
        intros.
        clear - H2.
        unfold exprT_Abs, exprT.
        autorewrite_with_eq_rw; simpl.
        match goal with
          | |- match ?X with _ => _ end = match ?Y with _ => _ end =>
            change Y with X ; generalize X
        end.
        destruct e. eapply FunctionalExtensionality.functional_extensionality.
        intros.
        erewrite H2. reflexivity. }
    Qed.

    Theorem typeof_expr_lambda_exprD
    : RTypeOk -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall tus tvs e t,
        ED.typeof_expr tus tvs e = Some t ->
        exists val,
          ED.lambda_exprD tus tvs t e = Some val.
    Proof.
      intros ? ? ? tus tvs e; revert tvs; induction e; simpl; intros;
      autorewrite with exprD_rw; simpl.
      { consider (nth_error_get_hlist_nth typD tvs v); intros.
        { destruct s.
          eapply nth_error_get_hlist_nth_Some in H2. simpl in *.
          destruct H2. rewrite x0 in H1. inv_all; subst.
          rewrite type_cast_refl; eauto. }
        { rewrite nth_error_get_hlist_nth_None in H2. congruence. } }
      { unfold symAs.
        generalize (symD f). rewrite H1.
        rewrite type_cast_refl; eauto. }
      { forward.
        eapply IHe1 in H1.
        eapply IHe2 in H2.
        forward_reason.
        unfold ED.type_of_apply in H3.
        destruct (typ2_match_case (F := RFun)  t0).
        { forward_reason. rewrite H4 in H3; clear H4.
          unfold Relim in H3.
          rewrite eq_Const_eq in H3.
          rewrite H2.
          generalize dependent (typ2_cast x1 x2).
          destruct e. simpl; intros; forward.
          inv_all; subst. red in r. red in x3. subst.
          rewrite H1. eauto. }
        { exfalso. rewrite H4 in H3. congruence. } }
      { forward. inv_all; subst.
        rewrite typ2_match_iota; eauto.
        rewrite type_cast_refl; eauto.
        eapply IHe in H1. forward_reason.
        rewrite H1.
        destruct (eq_sym (typ2_cast t t1)). eauto. }
      { consider (nth_error_get_hlist_nth typD tus u); intros.
        { destruct s.
          eapply nth_error_get_hlist_nth_Some in H2. simpl in *.
          destruct H2. rewrite x0 in H1. inv_all; subst.
          rewrite type_cast_refl; eauto. }
        { rewrite nth_error_get_hlist_nth_None in H2. congruence. } }
    Qed.

    Theorem type_of_apply_Some
    : forall t u v (H : ED.type_of_apply t u = Some v),
        t = typ2 u v.
    Proof.
      intros.
      unfold ED.type_of_apply in H.
      destruct (typ2_match_case t) as [[a [b [pf H1]]] | H1].
      { unfold Rty in pf. subst.
        rewrite typ2_match_iota in H; [|apply _].
        unfold eq_sym in H.
        forward. }
      { specialize (H1 (fun _ => option typ)).
        specialize (H1 (fun d r => match type_cast d u with | Some _ => Some r | None => None end)).
        simpl in H1. specialize (H1 None). rewrite H in H1. congruence. }
    Qed.

    Theorem typeof_expr_App
    : forall tus tvs e1 e2 t,
        ED.typeof_expr tus tvs (App e1 e2) = Some t ->
        exists u,
             ED.typeof_expr tus tvs e1 = Some (typ2 u t)
          /\ ED.typeof_expr tus tvs e2 = Some u.
    Proof.
      simpl. intros; forward.
      eapply type_of_apply_Some in H1. subst.
      eauto.
    Qed.

    Theorem typeof_expr_Abs
    : forall tus tvs e t1 t,
        ED.typeof_expr tus tvs (Abs t1 e) = Some t ->
        exists t2, t = typ2 t1 t2 /\
             ED.typeof_expr tus (t1 :: tvs) e = Some t2.
    Proof.
      simpl. intros.
      forward. inv_all. subst. eauto.
    Qed.

    Theorem typeof_expr_Var
    : forall tus tvs v t,
        ED.typeof_expr tus tvs (Var v) = Some t ->
        nth_error tvs v = Some t.
    Proof.
      simpl; auto.
    Qed.

    Theorem typeof_expr_UVar
    : forall tus tvs v t,
        ED.typeof_expr tus tvs (UVar v) = Some t ->
        nth_error tus v = Some t.
    Proof.
      simpl; auto.
    Qed.

    Theorem typeof_expr_Inj
    : forall tus tvs (f : func) (t : typ),
        ED.typeof_expr tus tvs (Inj f) = Some t ->
        typeof_sym f = Some t.
    Proof.
      simpl; auto.
    Qed.

    Global Instance Injective_typeof_expr_Inj tus tvs (f : func) (t : typ)
    : Injective (ED.typeof_expr tus tvs (Inj f) = Some t) :=
    { result := typeof_sym f = Some t
    ; injection := @typeof_expr_Inj _ _ _ _ }.

    Global Instance Injective_typeof_expr_Var tus tvs v (t : typ)
    : Injective (ED.typeof_expr tus tvs (Var v) = Some t) :=
    { result := nth_error tvs v = Some t
    ; injection := @typeof_expr_Var _ _ _ _ }.

    Global Instance Injective_typeof_expr_UVar tus tvs v (t : typ)
    : Injective (ED.typeof_expr tus tvs (UVar v) = Some t) :=
    { result := nth_error tus v = Some t
    ; injection := @typeof_expr_UVar _ _ _ _ }.

    Global Instance Injective_typeof_expr_App tus tvs e1 e2 (t : typ)
    : Injective (ED.typeof_expr tus tvs (App e1 e2) = Some t) :=
    { result := _
    ; injection := @typeof_expr_App _ _ _ _ _ }.

    Global Instance Injective_typeof_expr_Abs tus tvs t1 e2 (t : typ)
    : Injective (ED.typeof_expr tus tvs (Abs t1 e2) = Some t) :=
    { result := _
    ; injection := @typeof_expr_Abs _ _ _ _ _ }.

    Theorem lambda_exprD_single_type
    : (*@RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func -> *)
      forall tus tvs e t t' val val',
        ED.lambda_exprD tus tvs t e = Some val ->
        ED.lambda_exprD tus tvs t' e = Some val' ->
        exists pf : Rty t t',
          Relim (exprT tus tvs) pf val' = val.
    Proof.
      intros tus tvs.
      refine (@lambda_exprD_ind
                          (fun tus tvs e t val'' =>
                             forall t' val val',
                               val'' = Some val ->
                               ED.lambda_exprD tus tvs t' e = Some val' ->
                               exists pf : Rty t t',
                                 Relim (exprT tus tvs) pf val' = val)
                          _ _ _ _ _ _ _ _).
      { congruence. }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl in *.
        rewrite H in *.
        destruct (type_cast t' t'0).
        { inv_all; subst. destruct r. destruct pf. exists (Rrefl _).
          reflexivity. }
        { congruence. } }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl in *.
        rewrite H in *.
        destruct (type_cast t' t'0).
        { inv_all; subst. destruct r. destruct pf. exists (Rrefl _).
          reflexivity. }
        { congruence. } }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl in *.
        unfold symAs in *.
        generalize dependent (symD i).
        rewrite pf.
        destruct pf'.
        destruct (type_cast t'0 t').
        { intros. exists (Rsym r).
          destruct r. simpl in *. inv_all; subst. reflexivity. }
        { congruence. } }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl in *.
        forward; inv_all; subst.
        eapply (H0 _ _ _ eq_refl) in H3.
        eapply (H1 _ _ _ eq_refl) in H4.
        forward_reason.
        destruct (typ2_inj _ _ _ _ x1).
        exists H5. destruct H5. simpl.
        subst. clear - RTypeOk_typD.
        f_equal. generalize dependent (typ2 d r).
        (** NOTE(gmalecha): relying on [Rty = eq] **)
        unfold Rty. uip_all'. reflexivity.
        red in x0. uip_all'. reflexivity. }
      { intros; inv_all; subst.
        autorewrite with exprD_rw in *; simpl in *.
        forward; inv_all; subst.
        destruct (typ2_match_case t').
        { destruct H0 as [ ? [ ? [ ? ? ] ] ].
          rewrite H0 in *; clear H0.
          destruct (type_cast x d).
          { destruct r0.
            consider (ED.lambda_exprD tus (x :: tvs0) x0 e); intros.
            { eapply H in H0; clear H; eauto.
              destruct H0. destruct x2.
              subst. exists (Rsym x1). unfold exprT_Abs.
              generalize dependent (typ2_cast x r).
              destruct x1. simpl; intros.
              rewrite eq_option_eq in H1.
              inv_all; subst.
              rewrite eq_Arr_eq; rewrite eq_Const_eq. reflexivity. }
            { exfalso.
              generalize dependent (typ2_cast x x0). clear.
              destruct x1. destruct e. simpl; congruence. } }
          { exfalso.
            generalize dependent (typ2_cast x x0). clear.
            destruct x1. destruct e. simpl; congruence. } }
        { rewrite H0 in *. congruence. } }
    Qed.

    Lemma symAs_typeof_sym (f : func) (t : typ) (v : typD t) (H : symAs f t = Some v) :
      typeof_sym f = Some t.
    Proof.
      unfold symAs in H.
      generalize dependent (symD f).
      destruct (typeof_sym f); intros; [|congruence].
      destruct (type_cast t t0) eqn:Heq; [|congruence].
      unfold type_cast in Heq.
      forward.
    Qed.

    Theorem lambda_exprD_typeof_expr
    : (*@RTypeOk _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func -> *)
      forall tus tvs e t,
        ED.typeof_expr tus tvs e = Some t <->
        exists val,
          ED.lambda_exprD tus tvs t e = Some val.
    Proof.
      intros tus tvs e; revert tvs.
      induction e; simpl; intros; autorewrite with exprD_rw; simpl.
      { split; intro.
        { consider (nth_error_get_hlist_nth typD tvs v); intros.
          { destruct s. eapply nth_error_get_hlist_nth_Some in H0.
            simpl in *. destruct H0.
            rewrite x0 in H. inv_all; subst.
            rewrite type_cast_refl; eauto. }
          { rewrite nth_error_get_hlist_nth_None in H0. congruence. } }
        { forward_reason. forward; inv_all; subst.
          destruct r. eapply nth_error_get_hlist_nth_Some in H0.
          destruct H0. assumption. } }
      { split; intros.
        { unfold symAs. generalize (symD f).
          rewrite H. rewrite type_cast_refl; eauto. }
        { forward_reason; forward.
          unfold symAs in H.
          generalize dependent (symD f).
          destruct (typeof_sym f); try congruence.
          intros. forward. } }
      { split; intros.
        { forward.
          eapply IHe1 in H. eapply IHe2 in H0.
          forward_reason.
          unfold ED.type_of_apply in H1.
          destruct (typ2_match_case t0).
          { destruct H2 as [ ? [ ? [ ? ? ] ] ].
            rewrite H2 in H1; clear H2.
            rewrite H0. generalize dependent (typ2_cast x1 x2).
            red in x3. subst.
            destruct e. simpl; intros; forward.
            destruct r. inv_all; subst. rewrite H. eauto. }
          { rewrite H2 in H1. congruence. } }
        { forward_reason; forward; inv_all; subst.
          cutrewrite (ED.typeof_expr tus tvs e1 = Some (typ2 t0 t)).
          { unfold ED.type_of_apply.
            rewrite typ2_match_iota; eauto.
            rewrite type_cast_refl; eauto.
            rewrite eq_Const_eq. reflexivity. }
          { rewrite IHe1. eauto. } } }
      { split; intros; forward; inv_all; subst.
        { rewrite typ2_match_iota; eauto.
          rewrite type_cast_refl; eauto.
          rewrite IHe in H. forward_reason.
          rewrite H. forward. eauto. }
        { forward_reason.
          destruct (typ2_match_case t0).
          { destruct H0 as [ ? [ ? [ ? ? ] ] ].
            rewrite H0 in H; clear H0.
            generalize dependent (typ2_cast x0 x1).
            red in x2. subst. simpl; intros.
            consider (type_cast x0 t); intros.
            { specialize (IHe (t :: tvs) x1).
              destruct (ED.lambda_exprD tus (t :: tvs) x1 e).
              { destruct IHe. rewrite H2; eauto. destruct r. auto. }
              { exfalso. clear - H0. destruct e0. simpl in *; congruence. } }
            { exfalso; clear - H0. destruct e0. simpl in *; congruence. } }
          { rewrite H0 in H. congruence. } } }
      { split; intro.
        { consider (nth_error_get_hlist_nth typD tus u); intros.
          { destruct s. eapply nth_error_get_hlist_nth_Some in H0.
            simpl in *. destruct H0.
            rewrite x0 in H. inv_all; subst.
            rewrite type_cast_refl; eauto. }
          { rewrite nth_error_get_hlist_nth_None in H0. congruence. } }
        { forward_reason. forward; inv_all; subst.
          destruct r. eapply nth_error_get_hlist_nth_Some in H0.
          destruct H0. assumption. } }
    Qed.

    Theorem lambda_exprD_type_cast
    : @RTypeOk typ _ -> Typ2Ok Typ2_Fun -> RSymOk RSym_func ->
      forall tus tvs e t ,
        ED.lambda_exprD tus tvs t e =
        match ED.typeof_expr (Typ2_Fun:=Typ2_Fun) tus tvs e with
          | None => None
          | Some t' =>
            match @type_cast _ _ t' t with
              | None => None
              | Some cast =>
                match ED.lambda_exprD tus tvs t' e with
                  | None => None
                  | Some x =>
                    Some (fun us gs => ED.Rcast (fun x => x) cast (x us gs))
                end
            end
        end.
    Proof.
      intros.
      consider (ED.typeof_expr tus tvs e); intros.
      { consider (type_cast t0 t); intros.
        { symmetry.
          erewrite ED.lambda_exprD_respects with (pf := Rsym r); eauto.
          clear. destruct r.
          destruct (ED.lambda_exprD tus tvs t0 e); reflexivity. }
        { consider (ED.lambda_exprD tus tvs t e); auto; intros.
          exfalso.
          rewrite lambda_exprD_typeof_expr in H1.
          destruct H1.
          destruct (lambda_exprD_single_type H1 H3).
          destruct x0. rewrite type_cast_refl in H2; eauto.
          congruence. } }
      { consider (ED.lambda_exprD tus tvs t e); auto.
        intros. exfalso.
        cut (ED.typeof_expr tus tvs e = Some t).
        congruence.
        rewrite lambda_exprD_typeof_expr. eauto. }
    Qed.

  End with_types.
End Make.


Module Type SIG.
  Axiom A : Set.
End SIG.

Module M0.
  Definition A : Set.
  exact nat.
  Qed.
End M0.

Module M1 : SIG.
  Definition A := nat.
End M1.

Module M2 <: SIG.
  Definition A := nat.
End M2.

Module M3 := M0.

Module M4 : SIG := M0.

Module M5 <: SIG := M0.

Module F (X: SIG) := X.

Module Type T.

  Module M0.
    Axiom A : Set.
  End M0.

  Declare Module M1: SIG.

  Module M2 <: SIG.
    Definition A := nat.
  End M2.

  Module M3 := M0.

  Module M4 : SIG := M0.

  Module M5 <: SIG := M0.

  Module M6 := F M0.

End T.


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

From QArithSternBrocot Require Export homographicAcc_Qhomographic_sign.
From Coq Require Import ZArithRing.

(** note that ~(`c=0`/\`d=0`)<->`c<>0`\/`c<>d` *)

Lemma Qhomographic_sg_denom_nonzero_nonzero :
 forall (c d : Z) (p : Qpositive),
 c = 0%Z -> d = 0%Z -> ~ Qhomographic_sg_denom_nonzero c d p.
Proof.
 intros c d p Hc Hd H_Qhomographic_sg_denom_nonzero.
 generalize Hc Hd.
 elim H_Qhomographic_sg_denom_nonzero; intros; apply H0; first
  [ assumption | rewrite Hc0; rewrite Hd0; constructor ].
Defined.

Lemma Qhomographic_sg_denom_nonzero_nonzero_2 :
 forall (c d : Z) (p : Qpositive),
 Qhomographic_sg_denom_nonzero c d p -> c <> d \/ c <> 0%Z.
Proof.
 intros.
 apply double_not_equal_zero.
 intros (Hc, Hd).
 apply (Qhomographic_sg_denom_nonzero_nonzero c d p); assumption.
Defined.

Lemma Qhomographic_sg_denom_nonzero_nonzero_3 :
 forall (c d : Z) (p : Qpositive),
 Qhomographic_sg_denom_nonzero c d p -> c <> 0%Z \/ d <> 0%Z.
Proof.
 intros c d p H_Qhomographic_sg_denom_nonzero.
 generalize
  (Qhomographic_sg_denom_nonzero_nonzero_2 c d p
     H_Qhomographic_sg_denom_nonzero); intros [Hcd| Hd];
  [ case (Z_zerop c); intro Hc;
     [ right; apply sym_not_equal; rewrite Hc in Hcd | left ]
  | left ]; try assumption.
Defined.

Definition Qhomographic_Qpositive_to_Q (a b c d : Z)
  (p : Qpositive) (H_hsign : Qhomographic_sg_denom_nonzero c d p) : Q.
case (Z.eq_dec (a * d) (b * c)).
 (* a d = b c *)
 intro ad_eq_bc.
 case (Z_zerop d).
  (* d = 0 *)
  intro d_eq_zero.
  refine (fraction_encoding a c _).
  case (Qhomographic_sg_denom_nonzero_nonzero_2 c d p H_hsign).
   rewrite d_eq_zero.
   intros H; assumption.

   intros H; assumption.
  (* d <> 0 *)
  intro d_neq_zero.
  exact (fraction_encoding b d d_neq_zero).
 (* a d <> b c *)
 intro ad_neq_bc.
 case (sg_sign_dec a b c d p H_hsign).
  intro l1_not_minus_one.
  case l1_not_minus_one.
    (* (h_sign a b c d p) = 0 *)
    intro l1_eq_zero.
    exact Zero.
    (* (h_sign a b c d p) = 1 *)
    intro l1_eq_one.
      case
       (Z_lt_le_dec 0
          (Z.sgn (new_a a b c d p H_hsign + new_b a b c d p H_hsign))).
      (* 0<s_ab *)
      intro z.
      refine
       (Qpos
          (Qhomographic_Qpositive_to_Qpositive (new_a a b c d p H_hsign)
             (new_b a b c d p H_hsign) (new_c a b c d p H_hsign)
             (new_d a b c d p H_hsign) (new_p a b c d p H_hsign) _)).
      abstract apply
                (Qhomographic_Qpositive_to_Q_homographicAcc_pos_1 _ _ _ _ _
                   H_hsign ad_neq_bc l1_eq_one z).
      (* s_ab <= 0 *)
      intro z.
      refine
       (Qpos
          (Qhomographic_Qpositive_to_Qpositive (- new_a a b c d p H_hsign)
             (- new_b a b c d p H_hsign) (- new_c a b c d p H_hsign)
             (- new_d a b c d p H_hsign) (new_p a b c d p H_hsign) _)).
      abstract apply
                (Qhomographic_Qpositive_to_Q_homographicAcc_pos_2 _ _ _ _ _
                   H_hsign ad_neq_bc l1_eq_one z).
    (* (h_sign a b c d p) = (-1) *)
    intro l1_eq__minus_one.
     case
      (Z_lt_le_dec (Z.sgn (new_a a b c d p H_hsign + new_b a b c d p H_hsign))
         0).
      (* s_ab<0 *)
      intro z.
      refine
       (Qneg
          (Qhomographic_Qpositive_to_Qpositive (- new_a a b c d p H_hsign)
             (- new_b a b c d p H_hsign) (new_c a b c d p H_hsign)
             (new_d a b c d p H_hsign) (new_p a b c d p H_hsign) _)).
      abstract apply
                (Qhomographic_Qpositive_to_Q_homographicAcc_neg_1 _ _ _ _ _
                   H_hsign ad_neq_bc l1_eq__minus_one z).
      (* 0 <= s_ab *)
      intro z.
      refine
       (Qneg
          (Qhomographic_Qpositive_to_Qpositive (new_a a b c d p H_hsign)
             (new_b a b c d p H_hsign) (- new_c a b c d p H_hsign)
             (- new_d a b c d p H_hsign) (new_p a b c d p H_hsign) _)).
      abstract apply
                (Qhomographic_Qpositive_to_Q_homographicAcc_neg_2 _ _ _ _ _
                   H_hsign ad_neq_bc l1_eq__minus_one z).
Defined.

Inductive Qhomographic_denom_nonzero : Z -> Z -> Q -> Prop :=
  | Qhomographicok0 :
      forall (c d : Z) (s : Q),
      s = Zero -> d <> 0%Z -> Qhomographic_denom_nonzero c d s
  | Qhomographicok1 :
      forall (c d : Z) (s : Q) (p : Qpositive),
      s = Qpos p ->
      Qhomographic_sg_denom_nonzero c d p -> Qhomographic_denom_nonzero c d s
  | Qhomographicok2 :
      forall (c d : Z) (s : Q) (p : Qpositive),
      s = Qneg p ->
      Qhomographic_sg_denom_nonzero (- c) d p ->
      Qhomographic_denom_nonzero c d s.

Lemma Qhomographic_denom_nonzero_0 :
 forall c d : Z, Qhomographic_denom_nonzero c d Zero -> d <> 0%Z.
Proof.
 intros; abstract (inversion_clear H; assumption || discriminate H0).
Defined.

Lemma Qhomographic_denom_nonzero_1 :
 forall (c d : Z) (p : Qpositive),
 Qhomographic_denom_nonzero c d (Qpos p) ->
 Qhomographic_sg_denom_nonzero c d p.
Proof.
 intros;
  abstract (inversion_clear H; solve
             [ assumption
             | match goal with
               | id1:(?X1 = ?X2) |- ?X3 => try discriminate id1; clear id1
               end
             | match goal with
               | id1:(?X1 = ?X2) |- ?X3 =>
                   injection id1; intro H_injected; rewrite H_injected;
                    assumption
               end ]).
Defined.

Lemma Qhomographic_denom_nonzero_2 :
 forall (c d : Z) (p : Qpositive),
 Qhomographic_denom_nonzero c d (Qneg p) ->
 Qhomographic_sg_denom_nonzero (- c) d p.
Proof.
 intros;
  abstract (inversion_clear H; solve
             [ assumption
             | match goal with
               | id1:(?X1 = ?X2) |- ?X3 => try discriminate id1; clear id1
               end
             | match goal with
               | id1:(?X1 = ?X2) |- ?X3 =>
                   injection id1; intro H_injected; rewrite H_injected;
                    assumption
               end ]).
Defined.

Definition Qhomographic (a b c d : Z) (s : Q)
  (H_Qhomographic_denom_nonzero : Qhomographic_denom_nonzero c d s) : Q.
destruct s as [| p| p].
refine (fraction_encoding b d _).
apply Qhomographic_denom_nonzero_0 with c; assumption.
refine (Qhomographic_Qpositive_to_Q a b c d p _).
apply Qhomographic_denom_nonzero_1; assumption.
refine (Qhomographic_Qpositive_to_Q (- a) b (- c) d p _).
apply Qhomographic_denom_nonzero_2; assumption.
Defined.

Lemma Qhomographic_sg_denom_nonzero_always_1 :
 forall (d k k' : Z) (p : Qpositive),
 d <> 0%Z ->
 (0 < k)%Z -> (0 < k')%Z -> Qhomographic_sg_denom_nonzero (k * d) (k' * d) p.
Proof.
 intros.
 generalize k k' H0 H1.
 induction p.
 intros.
 apply Qhomographic_signok1.
 replace (k0 * d + k'0 * d)%Z with ((k0 + k'0) * d)%Z.
 apply IHp.
 assumption.
 replace 0%Z with (0 + 0)%Z.
 apply Zlt_plus_plus.
 assumption.
 assumption.
 constructor.
 rewrite Zmult_plus_distr_l; reflexivity.
 intros.
 apply Qhomographic_signok2.
 replace (k0 * d + k'0 * d)%Z with ((k0 + k'0) * d)%Z.
 apply IHp.
 replace 0%Z with (0 + 0)%Z.
 apply Zlt_plus_plus.
 assumption.
 assumption.
 constructor.
 assumption.
 rewrite Zmult_plus_distr_l; reflexivity.
 intros.
 apply Qhomographic_signok0.
 reflexivity.
 replace (k0 * d + k'0 * d)%Z with ((k0 + k'0) * d)%Z.
 intro.
 apply H.
 apply Zmult_integral_l with (k0 + k'0)%Z.
 apply Zgt_not_eq.
 apply Z.lt_gt.
 replace 0%Z with (0 + 0)%Z.
 apply Zlt_plus_plus.
 assumption.
 assumption.
 constructor.
 rewrite Z.mul_comm.
 assumption.
 rewrite Zmult_plus_distr_l; reflexivity.
Defined.

Lemma Qhomographic_sg_denom_nonzero_Zero_always :
 forall (d : Z) (p : Qpositive),
 d <> 0%Z -> Qhomographic_sg_denom_nonzero 0 d p.
Proof.
 intros.
 induction p.
 apply Qhomographic_signok1.
 simpl in |- *.
 assumption.
 apply Qhomographic_signok2.
 simpl in |- *.
 replace d with (1 * d)%Z.
 apply Qhomographic_sg_denom_nonzero_always_1.
 assumption.
 constructor.
 constructor.
 rewrite Zmult_1_l.
 reflexivity.
 apply Qhomographic_signok0.
 reflexivity.
 simpl in |- *.
 assumption.
Defined.

Lemma Qhomographic_sg_denom_nonzero_always_Zero :
 forall (c : Z) (p : Qpositive),
 c <> 0%Z -> Qhomographic_sg_denom_nonzero c 0 p.
Proof.
 intros.
 induction p.
 apply Qhomographic_signok1.
 rewrite Zplus_0_r.
 replace c with (1 * c)%Z.
 apply Qhomographic_sg_denom_nonzero_always_1.
 assumption.
 constructor.
 constructor.
 rewrite Zmult_1_l.
 reflexivity.
 apply Qhomographic_signok2.
 rewrite Zplus_0_r.
 assumption.
 apply Qhomographic_signok0.
 reflexivity.
 rewrite Zplus_0_r.
 assumption.
Defined.

Lemma always_nonzero_Qhomographic_sg_denom_nonzero :
 forall (d : Z) (p : Qpositive),
 Qhomographic_sg_denom_nonzero 0 d p -> d <> 0%Z.
Proof.
 intros.
 intro.
 apply (Qhomographic_sg_denom_nonzero_nonzero 0 d p); solve
  [ constructor | assumption ].
Defined.

Lemma Qhomographic_denom_nonzero_Zero_always :
 forall (d : Z) (s : Q), d <> 0%Z -> Qhomographic_denom_nonzero 0 d s.
Proof.
 abstract (intros; destruct s as [| p| p];
            [ apply Qhomographicok0
            | apply Qhomographicok1 with p
            | apply Qhomographicok2 with p ];
            reflexivity ||
              (try apply Qhomographic_sg_denom_nonzero_Zero_always);
            assumption).
Defined.

Lemma Qhomographic_denom_nonzero_Zero_ONE :
 forall s : Q, Qhomographic_denom_nonzero 0 1 s.
Proof.
 intros.
 apply Qhomographic_denom_nonzero_Zero_always.
 abstract discriminate.
Defined.

Lemma Qhomographic_denom_nonzero_always_Zero :
 forall (c : Z) (s : Q) (H_nonzero_s : s <> Zero :>Q),
 c <> 0%Z -> Qhomographic_denom_nonzero c 0 s.
Proof.
 abstract (intros; destruct s as [| p| p];
            [ Falsum
            | apply Qhomographicok1 with p
            | apply Qhomographicok2 with p ]; try reflexivity;
            apply Qhomographic_sg_denom_nonzero_always_Zero;
            try
             match goal with
             | id1:?X2 |- ((- ?X1)%Z <> 0%Z) => apply Zopp_app
             end; assumption).
Defined.

Lemma Qhomographic_denom_nonzero_ONE_Zero :
 forall (s : Q) (H_nonzero_s : s <> Zero :>Q),
 Qhomographic_denom_nonzero 1 0 s.
Proof.
 intros; apply Qhomographic_denom_nonzero_always_Zero;
  assumption || (abstract discriminate).
Defined.

(** Example: h(x)=2x   i.e. a=2 b=0 c=0 d=1 *)
Definition Qhomographic_2x (x : Q) : Q :=
  Qhomographic 2 0 0 1 x (Qhomographic_denom_nonzero_Zero_ONE x).

(** Example h(x)=-x i.e. a=`-1` b=0 c=0 d=1 *)
(** This is the additive opposite function *)
Definition Qopp_lazy (x : Q) : Q :=
  Qhomographic (-1) 0 0 1 x (Qhomographic_denom_nonzero_Zero_ONE x).

(** Example h(x)=kx i.e. a=k b=0 c=0 d=1 *)
Definition Qhomographic_kx (k : Z) (x : Q) : Q :=
  Qhomographic k 0 0 1 x (Qhomographic_denom_nonzero_Zero_ONE x).

(** Example h(x)=x/k i.e. a=1 b=0 c=0 d=k<>0 *)
Definition Qhomographic_x_over_k (k : Z) (Hk : k <> 0%Z)
  (x : Q) : Q :=
  Qhomographic 1 0 0 k x (Qhomographic_denom_nonzero_Zero_always k x Hk).

(** Example h(x)=1/x i.e. a=0 b=1 c=1 d=0 *)
(** This is the multiplicative inverse function *)
Definition Qinv_lazy (x : Q) (Hx : x <> Zero) : Q :=
  Qhomographic 0 1 1 0 x (Qhomographic_denom_nonzero_ONE_Zero x Hx).