From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon BBSub.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_ssubo ===== *)
(* TODO: check *)

(* (~s1 && s2 && s3) || (s1 && ~s2 && ~s3) *)

(* (¬r ∨ ¬s1 ∨ ¬s3) ∧ (¬r ∨ s1 ∨ s2) ∧ (¬r ∨ ¬s2 ∨ s3) ∧ (r ∨ ¬s1 ∨ s2 ∨ s3) ∧ (r ∨ s1 ∨ ¬s2 ∨ ¬s3) *)

Definition bit_blast_ssubo g ls1 ls2: generator * cnf * literal :=
  let (tls1, sign1) := eta_expand (splitmsl ls1) in
  let (tls2, sign2) := eta_expand (splitmsl ls2) in
  let '(g_sub, cs_sub, lrs_sub) := bit_blast_sub g ls1 ls2 in
  let (usub, sign_sub) := eta_expand (splitmsl lrs_sub) in
  let (gr, r) := gen g_sub in
  let csr := [::
                [:: neg_lit r; neg_lit sign1; neg_lit sign_sub];
                [:: neg_lit r; sign1; sign2];
                [:: neg_lit r; neg_lit sign2; sign_sub];
                [:: r; neg_lit sign1; sign2; sign_sub];
                [:: r; sign1; neg_lit sign2; neg_lit sign_sub]
      ] in
  (gr, catrev cs_sub csr, r).

Lemma bit_blast_ssubo_correct g bs1 bs2 E ls1 ls2 g' cs lr :
  bit_blast_ssubo g ls1 ls2 = (g', cs, lr) ->
  size ls1 == size ls2 ->
  enc_bits E ls1 bs1 ->
  enc_bits E ls2 bs2 ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (Ssubo bs1 bs2).
Proof.
  rewrite /bit_blast_ssubo /gen.
  dcase (bit_blast_sub g ls1 ls2) => [[[g_sub cs_sub] lrs_sub] Hblast_sub].
  case=> _ <- <-.
  move => Hsz Henc1 Henc2.
  rewrite !add_prelude_catrev.
  move /andP => [Hicnf_sub Hicnf].
  move: (add_prelude_enc_bit_ff Hicnf_sub) => Hencff.
  move: (add_prelude_enc_bit_tt Hicnf_sub) => Henctt.
  dcase (subB bs1 bs2) => [brs HsubB].
  move: (bit_blast_sub_correct Hblast_sub Henc1 Henc2 Hicnf_sub (eqP Hsz)) => Henc_brs.
  have Hitt: interp_lit E lit_tt by exact: (eqP Henctt).
  move: (enc_bits_splitmsb Hitt Henc1) => /andP [Henc_s1 Henc_t1].
  move: (enc_bits_splitmsb Hitt Henc2) => /andP [Henc_s2 Henc_t2].
  move: (enc_bits_splitmsb Hitt Henc_brs) => /andP [Henc_sbrs Henc_tbrs].
  move: Hicnf.
  repeat rewrite add_prelude_cons add_prelude_singleton.
  rewrite /Ssubo.
  rewrite /=.
  rewrite !interp_lit_neg_lit.
  move => H. split_andb_hyps.
  repeat match goal with H: is_true (E var_tt) |- _ => clear H end.
  rewrite /enc_bit.
  rewrite /= in Henc_tbrs.
  move: Henc_t1 Henc_t2 Henc_tbrs.
  rewrite HsubB /=.
  move=> /eqP <- /eqP <- /eqP <-.
  move: H5 H6 H7 H8 H9.
    by case H_gfa: (E g_sub); case H_s1 :(interp_lit E (lastd lit_ff ls1)); case H_s2: (interp_lit E (lastd lit_ff ls2)); case H_sbrs: (interp_lit E (lastd lit_ff lrs_sub)).
Qed.

Definition mk_env_ssubo E g ls1 ls2: env * generator * cnf * literal :=
  let (tls1, sign1) := eta_expand (splitmsl ls1) in
  let (tls2, sign2) := eta_expand (splitmsl ls2) in
  let '(E_sub, g_sub, cs_sub, lrs_sub) := mk_env_sub E g ls1 ls2 in
  let (usub, sign_sub) := eta_expand (splitmsl lrs_sub) in
  let (gr, r) := gen g_sub in
  let E' := env_upd E_sub (var_of_lit r) (
                      (~~(interp_lit E_sub sign1) && (interp_lit E_sub sign2) && (interp_lit E_sub sign_sub)
                      ) ||
                      ((interp_lit E_sub sign1) && ~~(interp_lit E_sub sign2) && ~~(interp_lit E_sub sign_sub))) in
  let csr := [::
                [:: neg_lit r; neg_lit sign1; neg_lit sign_sub];
                [:: neg_lit r; sign1; sign2];
                [:: neg_lit r; neg_lit sign2; sign_sub];
                [:: r; neg_lit sign1; sign2; sign_sub];
                [:: r; sign1; neg_lit sign2; neg_lit sign_sub]
      ] in
  (E', gr, catrev cs_sub csr, r).

Lemma mk_env_ssubo_is_bit_blast_ssubo E g ls1 ls2 E' g' cs lr :
  mk_env_ssubo E g ls1 ls2 = (E', g', cs, lr) ->
  bit_blast_ssubo g ls1 ls2 = (g', cs, lr).
Proof.
  rewrite /mk_env_ssubo /bit_blast_ssubo /gen.
  case Hmkfsub : (mk_env_sub E g ls1 ls2)
  => [[[E_sub g_sub] cs_sub] r_sub].
  rewrite (mk_env_sub_is_bit_blast_sub Hmkfsub).
    by case=> _ <- <- <-.
Qed.

Lemma mk_env_ssubo_newer_gen E g ls1 ls2 E' g' cs lr :
  mk_env_ssubo E g ls1 ls2 = (E', g', cs, lr) ->
  (g <=? g')%positive.
Proof.
  rewrite /mk_env_ssubo /gen.
  dcase (mk_env_sub E g ls1 ls2) => [[[[E_sub g_sub] cs_sub] lrs_sub] Henv_sub].
  case=> _ <- _ _.
  move: (mk_env_sub_newer_gen Henv_sub) =>  Hgngf.
  move : (pos_leb_add_diag_r g_sub 1) => Hgfg1.
  by apply (pos_leb_trans Hgngf Hgfg1).
Qed.

Lemma mk_env_ssubo_newer_res E g ls1 ls2 E' g' cs lr :
  mk_env_ssubo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g' lr.
Proof.
  rewrite /mk_env_ssubo /gen.
  dcase (mk_env_sub E g ls1 ls2) => [[[[E_sub g_sub] cs_sub] lrs_sub] Henv_sub].
  case=> _ <- _ <-.
  by apply newer_than_lit_add_diag_r.
Qed.

Lemma mk_env_ssubo_newer_cnf E g ls1 ls2 E' g' cs lr :
  mk_env_ssubo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_ssubo /gen.
  dcase (mk_env_sub E g ls1 ls2) => [[[[E_sub g_sub] cs_sub] lrs_sub] Henv_sub].
  case=> _ <- <- _ Hgt Hgl1 Hgl2. rewrite /= !newer_than_cnf_catrev.
  (* newer_than_cnf (g_subdd+1) cs_subdd *)
  move : (mk_env_sub_newer_cnf Henv_sub Hgt Hgl1 Hgl2) => Hgfcf.
  move : (pos_leb_add_diag_r g_sub 1) => Hgfg1.
  rewrite (newer_than_cnf_le_newer Hgfcf Hgfg1) /=.
  (* others *)
  rewrite !newer_than_lit_neg.
  rewrite /=.
  move: (mk_env_sub_newer_gen Henv_sub) => Hgf.
  move: (pos_leb_trans Hgf Hgfg1) => Hggf1.
  move : (newer_than_lits_splitmsl Hgt Hgl1) => /andP [_ Hgs1].
  move : (newer_than_lits_splitmsl Hgt Hgl2) => /andP [_ Hgs2].
  rewrite (newer_than_lit_le_newer Hgs1 Hggf1) (newer_than_lit_le_newer Hgs2 Hggf1).
  move: (mk_env_sub_newer_res Henv_sub) => H.
  have Hgt2: newer_than_lit g_sub lit_tt by t_newer_hook.
  move: (newer_than_lits_splitmsl Hgt2 H) => /andP /= [_ Hgssub].
  rewrite (newer_than_lit_le_newer Hgssub Hgfg1).
  rewrite /newer_than_lit /newer_than_var /=.
  by rewrite (pos_ltb_add_diag_r g_sub 1).
Qed.

Lemma mk_env_ssubo_preserve E g ls1 ls2 E' g' cs lr :
    mk_env_ssubo E g ls1 ls2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_ssubo /gen.
  dcase (mk_env_sub E g ls1 ls2) => [[[[E_sub g_sub] cs_sub] lrs_sub] Henv_sub].
  case=> <- _ _ _.
  move : (mk_env_sub_preserve Henv_sub) => HpEnEfgn.
  move : (mk_env_sub_newer_gen Henv_sub) => {Henv_sub} Hgngf.
  eapply env_preserve_trans.
  exact: HpEnEfgn.
  eapply env_preserve_le.
  exact: env_upd_eq_preserve.
  exact: Hgngf.
Qed.

Lemma mk_env_ssubo_sat E g ls1 ls2 E' g' cs lr :
  mk_env_ssubo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_ssubo /gen.
  dcase (mk_env_sub E g ls1 ls2) => [[[[E_sub g_sub] cs_sub] lrs_sub] Henv_sub].
  case=> <- _ <- _ Hngg Hngls1 Hngls2.
  rewrite !interp_cnf_catrev.
  rewrite !interp_cnf_cons.
  remember (env_upd E_sub g_sub
           (~~ interp_lit E_sub (lastd lit_ff ls1) && interp_lit E_sub (lastd lit_ff ls2) &&
            interp_lit E_sub (lastd lit_ff lrs_sub)
            || interp_lit E_sub (lastd lit_ff ls1) && ~~ interp_lit E_sub (lastd lit_ff ls2) &&
               ~~ interp_lit E_sub (lastd lit_ff lrs_sub))) as Ef.
  move: (mk_env_sub_sat Henv_sub Hngg Hngls1 Hngls2) => Hicnf_sub.
  move: (mk_env_sub_newer_gen Henv_sub) => Hggsub.
  move: (mk_env_sub_newer_cnf Henv_sub Hngg Hngls1 Hngls2) => H.
  move: (mk_env_sub_preserve Henv_sub) => Hpre_sub.
  have: (env_preserve E_sub Ef g_sub) => Hpre_ef.
  {
    rewrite HeqEf.
    exact: env_upd_eq_preserve.
  }
  have -> : (interp_cnf Ef cs_sub).
  {
    by rewrite (env_preserve_cnf Hpre_ef H).
  }
  rewrite /=.
  rewrite !interp_lit_neg_lit.
  move: (newer_than_lits_le_newer Hngls1 Hggsub) => Hngsubls1.
  move: (newer_than_lits_le_newer Hngls2 Hggsub) => Hngsubls2.
  move: (mk_env_sub_newer_res Henv_sub) => Hngsubrsub.
  have Hgsubtt: (newer_than_lit g_sub lit_tt) by t_newer_hook.
  move: (newer_than_lits_splitmsl Hgsubtt Hngsubls1) => /andP [ _ Hnsub_s1].
  move: (newer_than_lits_splitmsl Hgsubtt Hngsubls2) => /andP [ _ Hnsub_s2].
  move: (newer_than_lits_splitmsl Hgsubtt Hngsubrsub) => /andP [_ Hnsub_ssub].
  rewrite !(env_preserve_lit Hpre_ef Hnsub_s1).
  rewrite !(env_preserve_lit Hpre_ef Hnsub_s2).
  rewrite !(env_preserve_lit Hpre_ef Hnsub_ssub).
  rewrite HeqEf. rewrite !env_upd_eq.
  rewrite /=.
    by case (interp_lit E_sub (lastd lit_ff ls1));
    case (interp_lit E_sub (lastd lit_ff ls2));
    case (interp_lit E_sub (lastd lit_ff lrs_sub)).
Qed.

Lemma mk_env_ssubo_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_ssubo E1 g ls1 ls2 = (E1', g1', cs1, lr1) ->
  mk_env_ssubo E2 g ls1 ls2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_ssubo => Heq.
  dcase (mk_env_sub E1 g ls1 ls2) => [[[[E_sub1 g_sub1] cs_sub1] lrs_sub1] Hsub1].
  dcase (mk_env_sub E2 g ls1 ls2) => [[[[E_sub2 g_sub2] cs_sub2] lrs_sub2] Hsub2].
  move: (mk_env_sub_env_equal Heq Hsub1 Hsub2) => {Heq Hsub1 Hsub2} [Heq [? [? ?]]]; subst.
  dcase (gen g_sub2) => [[g' r'] Hg']. case=> ? ? ? ?; case=> ? ? ? ?; subst.
  repeat split. rewrite !(env_equal_interp_lit _ Heq). apply: env_equal_upd.
  assumption.
Qed.


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

Set Implicit Arguments.

Require Import ZArith Lia.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleLift.
 Variable w : univ_of_cycles.
 Variable w_0 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_W0 : w ->  zn2z w.
 Variable w_0W : w ->  zn2z w.
 Variable w_compare : w -> w -> comparison.
 Variable ww_compare : zn2z w -> zn2z w -> comparison.
 Variable w_head0 : w -> w.
 Variable w_tail0 : w -> w.
 Variable w_add: w -> w -> zn2z w.
 Variable w_add_mul_div : w -> w -> w -> w.
 Variable ww_sub: zn2z w -> zn2z w -> zn2z w.
 Variable w_digits : positive.
 Variable w_zdigits : w.
 Variable ww_zdigits : zn2z w.
 Variable low: zn2z w -> w.

 Definition ww_head0 x :=
  match x with
  | W0 => ww_zdigits
  | WW xh xl =>
    match w_compare w_0 xh with
    | Eq => w_add w_zdigits (w_head0 xl)
    | _ => w_0W (w_head0 xh)
    end
  end.

 Definition ww_tail0 x :=
  match x with
  | W0 => ww_zdigits
  | WW xh xl =>
    match w_compare w_0 xl with
    | Eq => w_add w_zdigits (w_tail0 xh)
    | _ => w_0W (w_tail0 xl)
    end
  end.

  (* 0 < p < ww_digits *)
 Definition ww_add_mul_div p x y :=
  let zdigits := w_0W w_zdigits in
  match x, y with
  | W0, W0 => W0
  | W0, WW yh yl =>
    match ww_compare p zdigits with
    | Eq => w_0W yh
    | Lt => w_0W (w_add_mul_div (low p) w_0 yh)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl)
    end
  | WW xh xl, W0 =>
    match ww_compare p zdigits with
    | Eq => w_W0 xl
    | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_W0 (w_add_mul_div n xl w_0)
    end
  | WW xh xl, WW yh yl =>
    match ww_compare p zdigits with
    | Eq => w_WW xl yh
    | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
    end
  end.

 Section DoubleProof.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_to_w_Z  : forall x, 0 <= [[x]] < wwB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_compare : forall x y,
   w_compare x y = Z.compare [|x|] [|y|].
  Variable spec_ww_compare : forall x y,
   ww_compare x y = Z.compare [[x]] [[y]].
  Variable spec_w_head00  : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits.
  Variable spec_w_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB.
  Variable spec_w_tail00  : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits.
  Variable spec_w_tail0 : forall x, 0 < [|x|] ->
         exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]).
  Variable spec_w_add_mul_div : forall x y p,
       [|p|] <= Zpos w_digits ->
       [| w_add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB.
 Variable spec_w_add: forall x y,
   [[w_add x y]] = [|x|] + [|y|].
 Variable spec_ww_sub: forall x y,
   [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.

 Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits.
 Variable spec_low: forall x, [| low x|] = [[x]] mod wB.

  Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift.
  Ltac zarith := auto with zarith lift.

  Lemma spec_ww_head0  : forall x,  0 < [[x]] ->
	 wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB.
  Proof.
   rewrite wwB_div_2;rewrite Z.mul_comm;rewrite wwB_wBwB.
   assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H.
   unfold Z.lt in H;discriminate H.
   rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0.
   rewrite <- H0 in *. simpl Z.add. simpl in H.
   case (spec_to_Z w_zdigits);
     case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4.
   rewrite spec_w_add.
   rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
   case (spec_w_head0 H); intros H1 H2.
   rewrite Z.pow_2_r; fold wB; rewrite <- Z.mul_assoc; split.
     apply Z.mul_le_mono_nonneg_l; auto with zarith.
   apply Z.mul_lt_mono_pos_l; auto with zarith.
   assert (H1 := spec_w_head0 H0).
   rewrite spec_w_0W.
   split.
   rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc.
   apply Z.le_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB).
   rewrite Z.mul_comm; zarith.
   assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith.
   assert (H2:=spec_to_Z xl);apply Z.mul_nonneg_nonneg;zarith.
   case (spec_to_Z (w_head0 xh)); intros H2 _.
   generalize ([|w_head0 xh|]) H1 H2;clear H1 H2;
     intros p H1 H2.
   assert (Eq1 : 2^p < wB).
     rewrite <- (Z.mul_1_r (2^p));apply Z.le_lt_trans with (2^p*[|xh|]);zarith.
   assert (Eq2: p < Zpos w_digits).
    destruct (Z.le_gt_cases (Zpos w_digits) p);trivial;contradict  Eq1.
   apply Z.le_ngt;unfold base;apply Zpower_le_monotone;zarith.
   assert (Zpos w_digits = p + (Zpos w_digits - p)). ring.
   rewrite Z.pow_2_r.
   unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith.
   rewrite <- Z.mul_assoc; apply Z.mul_lt_mono_pos_l; zarith.
   rewrite <- (Z.add_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith.
   apply Z.mul_lt_mono_pos_r with (2 ^ p); zarith.
   rewrite <- Zpower_exp;zarith.
   rewrite Z.mul_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith.
   assert (H1 := spec_to_Z xh);zarith.
  Qed.

  Lemma spec_ww_tail0  : forall x,  0 < [[x]] ->
	 exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]].
  Proof.
   destruct x as [ |xh xl];simpl ww_to_Z;intros H.
   unfold Z.lt in H;discriminate H.
   rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0.
   rewrite <- H0; rewrite Z.add_0_r.
   case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
   generalize H; rewrite <- H0; rewrite Z.add_0_r; clear H; intros H.
   case (@spec_w_tail0 xh).
     apply Z.mul_lt_mono_pos_r with wB; auto with zarith.
     unfold base; auto with zarith.
   intros z (Hz1, Hz2); exists z; split; auto.
   rewrite spec_w_add; rewrite (fun x => Z.add_comm [|x|]).
   rewrite spec_zdigits; rewrite Zpower_exp by auto with zarith.
   rewrite Z.mul_assoc; rewrite <- Hz2; auto.

   case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
   case (spec_w_tail0 H0); intros z (Hz1, Hz2).
   assert (Hp: [|w_tail0 xl|] < Zpos w_digits).
     case (Z.le_gt_cases (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1.
     absurd (2 ^  (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]).
       apply Z.lt_nge.
       case (spec_to_Z xl); intros HH3 HH4.
       apply Z.le_lt_trans with (2 := HH4).
       rewrite Hz2.
       apply Z.le_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith.
     apply Zpower_le_monotone; auto with zarith.
   exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split.
     apply Z.add_nonneg_nonneg; auto.
     apply Z.mul_nonneg_nonneg; auto with zarith.
     case (spec_to_Z xh); auto.
   rewrite spec_w_0W.
   rewrite (Z.mul_add_distr_l 2); rewrite <- Z.add_assoc.
   rewrite Z.mul_add_distr_r; rewrite <- Hz2.
   apply f_equal2 with (f := Z.add); auto.
   rewrite (Z.mul_comm 2).
   repeat rewrite <- Z.mul_assoc.
   apply f_equal2 with (f := Z.mul); auto.
   case (spec_to_Z (w_tail0 xl)); intros HH3 HH4.
   pattern 2 at 2; rewrite <- Z.pow_1_r.
   lazy beta; repeat rewrite <- Zpower_exp; auto with zarith.
   unfold base; apply f_equal with (f := Z.pow 2); auto with zarith.

   contradict H0; case (spec_to_Z xl); auto with zarith.
  Qed.

  Hint Rewrite Zdiv_0_l Z.mul_0_l Z.add_0_l Z.mul_0_r Z.add_0_r
    spec_w_W0 spec_w_0W spec_w_WW spec_w_0
    (wB_div w_digits w_to_Z spec_to_Z)
    (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite.
  Ltac w_rewrite := autorewrite with w_rewrite;trivial.

  Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p,
   let zdigits := w_0W w_zdigits in
    [[p]] <= Zpos (xO w_digits) ->
      [[match ww_compare p zdigits with
        | Eq => w_WW xl yh
        | Lt => w_WW (w_add_mul_div (low p) xh xl)
                     (w_add_mul_div (low p) xl yh)
        | Gt =>
              let n := low (ww_sub p zdigits) in
            w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
        end]] =
      ([[WW xh xl]] * (2^[[p]]) +
       [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
  Proof.
   intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits).
   case (spec_to_w_Z p); intros Hv1 Hv2.
   replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits).
   2 : rewrite Pos2Z.inj_xO;ring.
   replace (Zpos w_digits + Zpos w_digits - [[p]]) with
     (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring.
   intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl);
   assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl));
   simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl);
   assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy.
   rewrite spec_ww_compare; case Z.compare_spec; intros H1.
   rewrite H1; unfold zdigits; rewrite spec_w_0W.
   rewrite spec_zdigits; rewrite Z.sub_diag; rewrite Z.add_0_r.
   simpl ww_to_Z; w_rewrite;zarith.
   fold wB.
   rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;rewrite <- Z.add_assoc.
   rewrite <- Z.pow_2_r.
   rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|].
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring.
   simpl ww_to_Z; w_rewrite;zarith.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small.
     case (spec_to_w_Z p); intros HH1 HH2; split; auto.
     generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; intros tmp.
     apply Z.lt_le_trans with (1 := tmp).
     unfold base.
     apply Zpower2_le_lin; auto with zarith.
   2: generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; auto with zarith.
   generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; auto; clear H1; intros H1.
   assert (HH: [|low p|] <= Zpos w_digits).
     rewrite HH0; auto with zarith.
   repeat rewrite spec_w_add_mul_div with (1 := HH).
   rewrite HH0.
   rewrite Z.mul_add_distr_r.
   pattern ([|xl|] * 2 ^ [[p]]) at 2;
   rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith.
   replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc.
   unfold base at 5;rewrite <- Zmod_shift_r;zarith.
   unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
   fold wB;fold wwB;zarith.
   rewrite wwB_wBwB;rewrite Z.pow_2_r; rewrite  Zmult_mod_distr_r;zarith.
   unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. apply Z_mod_lt;zarith.
   split;zarith. apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith.
   assert (Hv: [[p]] > Zpos w_digits).
     generalize H1; clear H1.
     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto with zarith.
   clear H1.
   assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits).
     rewrite spec_low.
     rewrite spec_ww_sub.
     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits.
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
     exists wB; unfold base.
     unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits).
     rewrite <- Zpower_exp; auto with zarith.
     apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
   assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits).
     rewrite HH0; auto with zarith.
   replace (Zpos w_digits + (Zpos w_digits - [[p]])) with
       (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith.
   lazy zeta; simpl ww_to_Z; w_rewrite;zarith.
   repeat rewrite spec_w_add_mul_div;zarith.
   rewrite HH0.
   pattern wB at 5;replace wB with
    (2^(([[p]] - Zpos w_digits)
         + (Zpos w_digits - ([[p]] - Zpos w_digits)))).
   rewrite Zpower_exp;zarith. rewrite Z.mul_assoc.
   rewrite Z_div_plus_l;zarith.
   rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits)
    (n := Zpos w_digits);zarith. fold wB.
   set (u := [[p]] - Zpos w_digits).
   replace [[p]] with (u + Zpos w_digits);zarith.
   rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. fold wB.
   repeat rewrite Z.add_assoc. rewrite <- Z.mul_add_distr_r.
   repeat rewrite <- Z.add_assoc.
   unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
   fold wB;fold wwB;zarith.
   unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits)
   (b:= Zpos w_digits);fold wB;fold wwB;zarith.
   rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite  Zmult_mod_distr_r;zarith.
   rewrite Z.mul_add_distr_r.
   replace ([|xh|] * wB * 2 ^ u) with
     ([|xh|]*2^u*wB). 2:ring.
   repeat rewrite <- Z.add_assoc.
   rewrite (Z.add_comm ([|xh|] * 2 ^ u * wB)).
   rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith.
   unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
   try (unfold u; lia).
   split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   fold u.
   ring_simplify (u + (Zpos w_digits - u)); fold
   wB;zarith. unfold ww_digits;rewrite Pos2Z.inj_xO;zarith.
   unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
   try (unfold u; lia).
   unfold u; split;zarith.
   apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   fold u.
   ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
   try (unfold u;zarith).
   try (unfold u;zarith).
   set (u := [[p]] - Zpos w_digits).
   ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
  Qed.

  Lemma spec_ww_add_mul_div : forall x y p,
       [[p]] <= Zpos (xO w_digits) ->
       [[ ww_add_mul_div p x y ]] =
         ([[x]] * (2^[[p]]) +
          [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
  Proof.
   intros x y p H.
   destruct x as [ |xh xl];
   [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0)
   |assert (H1 := @spec_ww_add_mul_div_aux xh xl)];
   (destruct y as [ |yh yl];
    [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)];
    clear H1;w_rewrite);simpl ww_add_mul_div.
   replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
   intros Heq;rewrite <- Heq;clear Heq; auto.
   rewrite spec_ww_compare. case Z.compare_spec; intros H1; w_rewrite.
   rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
   generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small.
     case (spec_to_w_Z p); intros HH1 HH2; split; auto.
     apply Z.lt_le_trans with (1 := H1).
     unfold base; apply Zpower2_le_lin; auto with zarith.
   rewrite HH0; auto with zarith.
   replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
   intros Heq;rewrite <- Heq;clear Heq.
   generalize (spec_ww_compare p (w_0W w_zdigits));
     case ww_compare; intros H1; w_rewrite.
   rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
   rewrite Pos2Z.inj_xO in H;zarith.
   assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits).
     symmetry in H1; change ([[p]] > [[w_0W w_zdigits]]) in H1.
     revert H1.
     rewrite spec_low.
     rewrite spec_ww_sub; w_rewrite; intros H1.
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
     unfold base; auto with zarith.
     unfold base; auto with zarith.
     exists wB; unfold base.
     unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits).
     rewrite <- Zpower_exp; auto with zarith.
     apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
  case (spec_to_Z xh); auto with zarith.
  Qed.

 Variable ww_Digits : positive.
 Variable spec_ww_digits : ww_Digits = xO w_digits.
 Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits.

  Lemma spec_ww_head00  : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits.
  Proof.
  intros x; case x; unfold ww_head0.
    intros HH; rewrite spec_ww_zdigits; auto.
  intros xh xl; simpl; intros Hx.
  case (spec_to_Z xh); intros Hx1 Hx2.
  case (spec_to_Z xl); intros Hy1 Hy2.
  assert (F1: [|xh|] = 0).
  { Z.le_elim Hy1; auto.
    - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
      apply Z.lt_le_trans with (1 := Hy1); auto with zarith.
      pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]).
      apply Z.add_le_mono_r; auto with zarith.
    - Z.le_elim Hx1; auto.
      absurd (0 < [|xh|] * wB + [|xl|]). auto with zarith.
      rewrite <- Hy1; rewrite Z.add_0_r.
      apply Z.mul_pos_pos; auto with zarith. }
  rewrite spec_compare. case Z.compare_spec.
    intros H; simpl.
    rewrite spec_w_add; rewrite spec_w_head00.
    rewrite spec_zdigits; rewrite spec_ww_digits.
    rewrite Pos2Z.inj_xO; auto with zarith.
  rewrite F1 in Hx; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  Qed.

  Lemma spec_ww_tail00  : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits.
  Proof.
  intros x; case x; unfold ww_tail0.
    intros HH; rewrite spec_ww_zdigits; auto.
  intros xh xl; simpl; intros Hx.
  case (spec_to_Z xh); intros Hx1 Hx2.
  case (spec_to_Z xl); intros Hy1 Hy2.
  assert (F1: [|xh|] = 0).
  { Z.le_elim Hy1; auto.
    - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
      apply Z.lt_le_trans with (1 := Hy1); auto with zarith.
      pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]).
      apply Z.add_le_mono_r; auto with zarith.
    - Z.le_elim Hx1; auto.
      absurd (0 < [|xh|] * wB + [|xl|]). auto with zarith.
      rewrite <- Hy1; rewrite Z.add_0_r.
      apply Z.mul_pos_pos; auto with zarith. }
  assert (F2: [|xl|] = 0).
    rewrite F1 in Hx; auto with zarith.
  rewrite spec_compare; case Z.compare_spec.
    intros H; simpl.
    rewrite spec_w_add; rewrite spec_w_tail00; auto.
    rewrite spec_zdigits; rewrite spec_ww_digits.
    rewrite Pos2Z.inj_xO; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  Qed.

 End DoubleProof.

End DoubleLift.


Set Universe Polymorphism.

Require Import Coq.Arith.Compare_dec.

Require Import Coq.Strings.String.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Reals.Rdefinitions.
Require Import MetaCoq.Template.All.

Require Import Helix.Util.Misc.
Require Import Helix.Util.ListSetoid.
Require Import Helix.Util.OptionSetoid.
Require Import Helix.Util.FinNat.
Require Import Helix.MSigmaHCOL.Memory.
Require Import Helix.MSigmaHCOL.MSigmaHCOL.
Require Import Helix.DSigmaHCOL.DSigmaHCOL.
Require Import Helix.DSigmaHCOL.DSigmaHCOLEval.
Require Import Helix.RSigmaHCOL.RSigmaHCOL.

Require Import Helix.Tactics.HelixTactics.

Require Import Switch.Switch.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.misc.util.

(* This import must be after Vector stuff, so `const` will point to
   Basics.const not Vector.const. We need this to be able to unfold it
   in TemplateCoq, which does not understand qualified names (with
   ".") *)
Require Import Coq.Program.Basics.

Import RHCOL.

Import MonadNotation.

Require Import Coq.Lists.List. Import ListNotations.
Open Scope string_scope.

Definition toDSHType (t: term): TemplateMonad DSHType :=
  match t with
  | tInd {| inductive_mind := (MPfile ["Datatypes"; "Init"; "Coq"], "nat"); inductive_ind := 0 |} _ =>
    tmReturn DSHnat
  | (tApp(tInd {| inductive_mind := (MPfile ["Specif"; "Init"; "Coq"], "sig"); inductive_ind := 0 |} _)
         [tInd
            {| inductive_mind := (MPfile ["Datatypes"; "Init"; "Coq"], "nat"); inductive_ind := 0 |} _ ; _])
    => tmReturn DSHnat (* `FinNat` is treated as `nat` *)
  | (Ast.tApp
             (Ast.tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierA") [])
             [Ast.tConst (BasicAst.MPfile ["RasCarrierA"; "MSigmaHCOL"; "Helix"], "CarrierDefs_R") []]) => tmReturn DSHCType
  | tApp
      (tInd {| inductive_mind := (MPfile ["VectorDef"; "Vectors"; "Coq"], "t"); inductive_ind := 0 |} _)
      [(Ast.tApp
      (Ast.tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierA") [])
      [Ast.tConst (BasicAst.MPfile ["RasCarrierA"; "MSigmaHCOL"; "Helix"], "CarrierDefs_R") []]) ; nat_term] =>
    size <- tmUnquoteTyped nat nat_term ;;
    tmReturn (DSHPtr size) (* mapping vectors to memory blocks pointers *)
  | _ =>
    (* tmPrint t ;; this print slows complilation down *)
    tmFail "non-DSHCOL type encountered"
  end.

(* DeBruijn indixed list variables. Each variable has name and type *)
Definition varbindings:Type := list (string*DSHType).

Definition var_resolver := nat -> var_id.
Definition ID_var_resolver : var_resolver := id.
Definition Fake_var_resolver (parent: var_resolver) (n:nat) : var_resolver
  := fun r => ((parent r)+n)%nat.
Definition Lambda_var_resolver (parent: var_resolver) (n:nat) : var_resolver
  := fun r => if lt_dec r n then r else ((parent (r-n))+n)%nat.

Fixpoint compileNExpr (res:var_resolver) (a_n:term): TemplateMonad NExpr :=
  match a_n with
  | tConstruct {| inductive_mind := (MPfile ["Datatypes"; "Init"; "Coq"], "nat"); inductive_ind := 0 |} 0 []
    => tmReturn (NConst 0)
  | tApp (tConst (MPfile ["Specif"; "Init"; "Coq"], "proj1_sig") []) [ _ ; _ ; tRel i]
    => tmReturn (NVar (res i))
  | tApp (tConstruct {| inductive_mind := (MPfile ["Datatypes"; "Init"; "Coq"], "nat"); inductive_ind := 0 |} 1 []) [e] =>
    d_e <- compileNExpr res e ;;
        tmReturn (match d_e with
                  | NConst v => NConst (v+1)
                  | o => NPlus o (NConst 1)
                  end)
  | tApp (tConst (MPfile ["Nat"; "Init"; "Coq"], "add") []) [ a_a ; a_b] =>
    d_a <- compileNExpr res a_a ;;
        d_b <- compileNExpr res a_b ;;
        tmReturn (NPlus d_a d_b)
  | tApp (tConst (MPfile ["Nat"; "Init"; "Coq"], "sub") []) [ a_a ; a_b] =>
    d_a <- compileNExpr res a_a ;;
        d_b <- compileNExpr res a_b ;;
        tmReturn (NMinus d_a d_b)
  | tApp (tConst (MPfile ["Nat"; "Init"; "Coq"], "mul") []) [ a_a ; a_b] =>
    d_a <- compileNExpr res a_a ;;
        d_b <- compileNExpr res a_b ;;
        tmReturn (NMult d_a d_b)
  (* TODO: more cases *)
  | _ => tmFail ("Unsupported NExpr " ++ (string_of_term a_n))
  end.

Definition compileMExpr (res:var_resolver) (a_e:term): TemplateMonad (MExpr):=
  match a_e with
  | tRel i => tmReturn (MPtrDeref (PVar (res i)))
  (* TODO: support for constant vectors as MConst *)
  | _ => tmFail ("Unsupported MExpr " ++ (string_of_term a_e))
  end.

(* TODO: this one takes a long time to compile. Speed up! *)
Fixpoint compileAExpr (res:var_resolver) (a_e:term): TemplateMonad AExpr  :=
  match a_e with
  | tApp (tConst (MPfile ["canonical_names"; "interfaces"; "MathClasses"], "abs") [])
         [(Ast.tApp
             (Ast.tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierA") [])
             [Ast.tConst (BasicAst.MPfile ["RasCarrierA"; "MSigmaHCOL"; "Helix"], "CarrierDefs_R") []]);
         _; _; _; a_a] =>
    d_a <- compileAExpr res a_a ;;
        tmReturn (AAbs d_a)
  | tApp (tConst (MPfile ["canonical_names"; "interfaces"; "MathClasses"], "abs") [])
         [(Ast.tApp
             (Ast.tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierA") [])
             [Ast.tConst (BasicAst.MPfile ["RasCarrierA"; "MSigmaHCOL"; "Helix"], "CarrierDefs_R") []]);
         _; _; _; _; _; a_a] =>
    d_a <- compileAExpr res a_a ;;
        tmReturn (AAbs d_a)
  | tApp (tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "sub") []) [_; _; _; _; _; a_a ; a_b] =>
    d_a <- compileAExpr res a_a ;;
        d_b <- compileAExpr res a_b ;;
        tmReturn (AMinus d_a d_b)
  | tApp (tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "sub") []) [_; _; _; a_a ; a_b] =>
    d_a <- compileAExpr res a_a ;;
        d_b <- compileAExpr res a_b ;;
        tmReturn (AMinus d_a d_b)
  | tApp (tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierAmult") []) [_; a_a ; a_b] =>
    d_a <- compileAExpr res a_a ;;
        d_b <- compileAExpr res a_b ;;
        tmReturn (AMult d_a d_b)
  | tApp (tConst (MPfile ["VecUtil"; "Vector"; "Util"; "CoLoR"], "Vnth") [])
         [(Ast.tApp
             (Ast.tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierA") [])
             [Ast.tConst (BasicAst.MPfile ["RasCarrierA"; "MSigmaHCOL"; "Helix"], "CarrierDefs_R") []]) ; _ ; a_v ; a_i ; _] =>
    d_v <- compileMExpr res a_v ;;
    d_i <- compileNExpr res a_i ;;
    tmReturn (ANth d_v d_i)
  | tRel i =>
    tmReturn (AVar (res i))
  (* TODO: support for constant values as AConst *)
  | _ => tmFail ("Unsupported AExpr " ++ (string_of_term a_e))
  end.

Definition compileDSHUnCarrierA (res:var_resolver) (a_f:term): TemplateMonad AExpr :=
  match a_f with
  (* TODO: check type of lambda's argument. Fail if not [CarrierA] *)
  | tLambda _ _ a_f' => compileAExpr (Lambda_var_resolver res 1) a_f'
  | _ => tmFail ("Unsupported UnCarrierA " ++ (string_of_term a_f))
  end.

Definition compileDSHIUnCarrierA (res:var_resolver) (a_f:term): TemplateMonad AExpr :=
  match a_f with
  (* TODO: check types of lambda's arguments. Fail if not [nat], [CarrierA] *)
  | tLambda _ _ (tLambda _ _ a_f') =>
    compileAExpr (Lambda_var_resolver res 2) a_f'
  | _ => tmFail ("Unsupported IUnCarrierA " ++ (string_of_term a_f))
  end.

Definition compileDSHBinCarrierA (res:var_resolver) (a_f:term): TemplateMonad AExpr :=
  match a_f with
  | tApp (tConst (MPfile ["minmax"; "orders"; "MathClasses"], "max") [])
         [(Ast.tApp
             (Ast.tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierA") [])
             [Ast.tConst (BasicAst.MPfile ["RasCarrierA"; "MSigmaHCOL"; "Helix"], "CarrierDefs_R") []]); _; _ ] =>
    tmReturn (AMax (AVar 1) (AVar 0))
  | tApp (tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "Zless") []) [_] =>
    tmReturn (AZless (AVar 1) (AVar 0))
  | tApp (tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierAplus") []) [_] =>
    tmReturn (APlus (AVar 1) (AVar 0))
  | tApp (tConst (MPfile ["CarrierType"; "HCOL"; "Helix"], "CarrierAmult") []) [_] =>
    tmReturn (AMult (AVar 1) (AVar 0))
  (* TODO: check types of lambda's arguments. Fail if not [CarrierA], [CarrierA] *)
  | tLambda _ _ (tLambda _ _ a_f') => compileAExpr (Lambda_var_resolver res 2) a_f'
  (* TODO: not sure the next constructor makes sense. It seems like we are
     allowing binary functions with one argument.  *)
  | tLambda _ _ a_f' => compileAExpr (Lambda_var_resolver res 1) a_f'
  | _ => tmFail ("Unsupported BinCarrierA " ++ (string_of_term a_f))
  end.

Definition compileDSHIBinCarrierA (res:var_resolver) (a_f:term): TemplateMonad AExpr :=
  match a_f with
  (* TODO: check type of lambda's argument. Fail if not [nat] *)
  | tLambda _ _ a_f' => compileDSHBinCarrierA (Lambda_var_resolver res 1) a_f'
  | _ => tmFail ("Unsupported IBinCarrierA " ++ (string_of_term a_f))
  end.

MetaCoq Run
    (mkSwitch string
              string_beq
              [  ("MSHEmbed"     , "n_Embed"       ) ;
                 ("MSHPick"      , "n_Pick"      ) ;
                 ("MSHPointwise" , "n_SHPointwise") ;
                 ("MSHBinOp"     , "n_SHBinOp"    ) ;
                 ("MSHInductor"  , "n_SHInductor" ) ;
                 ("MSHIUnion"    , "n_IUnion"     ) ;
                 ("MSHIReduction", "n_IReduction" ) ;
                 ("MSHCompose"   , "n_SHCompose"  ) ;
                 ("MApply2Union" , "n_Apply2Union" ) ]

              "SHCOL_Op_Names" "parse_SHCOL_Op_Name"
    ).

(* return tuple: vars, [DSHOperator x_p y_p] *)
Fixpoint compileMSHCOL2DSHCOL
         (res: var_resolver)
         (* the [vars] parameter used to accumulate and return list of globals.
            All lambdas at this point are globals *)
         (vars: varbindings)
         (t:term)
         (x_p y_p: PExpr)
  : TemplateMonad (varbindings*(DSHOperator)) :=
  match t with
  | tLambda (mkBindAnn (nNamed n) _) vt b =>
    tmPrint ("lambda " ++ n)  ;;
    dt <- toDSHType vt ;; (* to enforce valid type *)
    compileMSHCOL2DSHCOL (Lambda_var_resolver res 1) ((n,dt)::vars) b (incrPVar 0 x_p) (incrPVar 0 y_p)
  | tApp (tConst (opmod,opname) _) args =>
    match parse_SHCOL_Op_Name opname, args with
    | Some n_Embed, [o ; b ; _] =>
      tmPrint "MSHEmbed" ;;
      no <- tmUnquoteTyped nat o ;;
      bc <- compileNExpr res b ;;
      tmReturn (vars,  DSHAssign (x_p, NConst 0) (y_p, bc))
    | Some n_Pick, [i ; b ; _] =>
      tmPrint "MSHPick" ;;
      ni <- tmUnquoteTyped nat i ;;
      bc <- compileNExpr res b ;;
      tmReturn (vars, DSHAssign (x_p, bc) (y_p, NConst 0))
    | Some n_SHPointwise, [n ; f ; _ ] =>
      tmPrint "MSHPointwise" ;;
      nn <- tmUnquoteTyped nat n ;;
      df <- compileDSHIUnCarrierA res f ;;
      tmReturn (vars, DSHIMap nn (x_p) (y_p) df)
    | Some n_SHBinOp, [o ; f ; _] =>
      tmPrint "MSHBinOp" ;;
      no <- tmUnquoteTyped nat o ;;
      df <- compileDSHIBinCarrierA res f ;;
      tmReturn (vars, DSHBinOp no (x_p) (y_p) df )
    | Some n_SHInductor, [n ; f ; _ ; z] =>
      tmPrint "MSHInductor" ;;
      zconst <- tmUnquoteTyped R z ;;
      nc <- compileNExpr res n ;;
      df <- compileDSHBinCarrierA res f ;;
      tmReturn (vars, DSHPower nc (x_p, NConst 0) (y_p, NConst 0) df zconst)
    | Some n_IUnion, [i ; o ; n ; op_family] =>
      tmPrint "MSHIUnion" ;;
      ni <- tmUnquoteTyped nat i ;;
      no <- tmUnquoteTyped nat o ;;
      nn <- tmUnquoteTyped nat n ;;
      '(_, rr) <- compileMSHCOL2DSHCOL res vars op_family x_p y_p ;;
      tmReturn (vars, DSHLoop nn rr )
    | Some n_IReduction, [i ; o ; n ; z; f ; _ ; op_family] =>
      tmPrint "MSHIReduction" ;;
      nn <- tmUnquoteTyped nat n ;;
      match nn with
      | O => tmReturn (vars, DSHNop)
      | S _ =>
        ni <- tmUnquoteTyped nat i ;;
        no <- tmUnquoteTyped nat o ;;
        zconst <- tmUnquoteTyped R z ;;
        (* freshly allocated, inside alloc before loop *)
        let t_i := PVar 0 in
        (* single inc. inside loop *)
        let t_i' := PVar 1 in
        (* single inc. inside alloca before loop *)
        let x_p' := incrPVar 0 x_p in
        (* double inc. inside alloc and loop *)
        let x_p'' := incrPVar 0 x_p' in
        let y_p'' := incrPVar 0 (incrPVar 0 y_p) in
        (* op_family will introduce [Lambda_var_resolver],
                 but we need [Fake_var_resolver] for alloc
         *)
        let res1 := Fake_var_resolver res 1 in
        '(_, rr) <- compileMSHCOL2DSHCOL res1 vars op_family x_p' t_i ;;
        df <- compileDSHBinCarrierA res1 f ;;
        tmReturn (vars,
                  DSHSeq
                    (DSHMemInit y_p zconst)
                    (DSHAlloc no
                              (DSHLoop nn
                                       (DSHSeq
                                          rr
                                          (DSHMemMap2 no y_p'' t_i' y_p'' df)))))
      end
      | Some n_SHCompose, [i1 ; o2 ; o3 ; op1 ; op2] =>
        tmPrint "MSHCompose" ;;
        ni1 <- tmUnquoteTyped nat i1 ;;
        no2 <- tmUnquoteTyped nat o2 ;;
        no3 <- tmUnquoteTyped nat o3 ;;
        (* freshly allocated, inside alloc *)
        let t_i := PVar 0 in
        (* single inc. inside alloc *)
        let x_p' := incrPVar 0 x_p in
        let y_p' := incrPVar 0 y_p in
        let res1 := Fake_var_resolver res 1 in
      '(_, cop2) <- compileMSHCOL2DSHCOL res1 vars op2 x_p' t_i ;;
      '(_, cop1) <- compileMSHCOL2DSHCOL res1 vars op1 t_i y_p' ;;
      tmReturn (vars, DSHAlloc no2 (DSHSeq cop2 cop1))
    | Some n_Apply2Union, [i ; o ; dot ; op1 ; op2] =>
      tmPrint "MApply2Union" ;;
      (* This only works under assumption that output index
                 sets of [op1] and [op2] are disjount *)
      '(_, cop1) <- compileMSHCOL2DSHCOL res vars op1 x_p y_p ;;
      '(_,cop2) <- compileMSHCOL2DSHCOL res vars op2 x_p y_p ;;
      tmReturn (vars, DSHSeq cop1 cop2)
    | None, _ =>
      tmFail ("Usupported SHCOL operator " ++ opname)
    | _, _ =>
      tmFail ("Usupported arguments "
                ++ string_of_list string_of_term args
                ++ "for SHCOL operator " ++ opname)
    end
  | _ as t =>
    tmFail ("Usupported SHCOL syntax " ++ (AstUtils.string_of_term t))
  end.

Fixpoint tmUnfoldList {A:Type} (names:list kername) (e:A): TemplateMonad A :=
  match names with
  | [] => tmReturn e
  | x::xs =>  u <- @tmEval (unfold x) A e ;;
              tmUnfoldList xs u
  end.

Definition reifyMSHCOL
           {A:Type}
           (expr: A)
           (unfold_names: list kername)
           (res_name: string)
           (res_globals_name: string)
  : TemplateMonad unit :=
  let unfold_names := List.app unfold_names [
                                 (MPfile ["SigmaHCOL"; "SigmaHCOL"; "Helix"], "SHFamilyOperatorCompose") ;
                               (MPfile ["HCOL"; "HCOL"; "Helix"], "IgnoreIndex") ;
                               (MPfile ["HCOL"; "HCOL"; "Helix"], "Fin1SwapIndex") ;
                               (MPfile ["HCOL"; "HCOL"; "Helix"], "Fin1SwapIndex2") ;
                               (MPfile ["HCOL"; "HCOL"; "Helix"], "IgnoreIndex2") ;
                               (MPfile ["HCOL"; "HCOL"; "Helix"], "mult_by_nth") ;
                               (MPfile ["canonical_names"; "interfaces"; "MathClasses"], "plus") ;
                               (MPfile ["canonical_names"; "interfaces"; "MathClasses"], "mult") ;
                               (MPfile ["Basics"; "Program"; "Coq"], "const")
                               ] in
  eexpr <- tmUnfoldList unfold_names expr ;;
        ast <- @tmQuote A eexpr ;;
        mt <- tmQuote mem_block ;;
        (* Fake resolver for 2 vars: Y,X *)
        let res := Fake_var_resolver ID_var_resolver 2 in
        '(globals, dshcol) <- compileMSHCOL2DSHCOL res [] ast (PVar 1) (PVar 0) ;;
        dshcol' <- tmEval cbv dshcol ;;
        d_dshcol <- tmDefinition res_name dshcol' ;;
        d_globals <- tmDefinition res_globals_name globals
        ;; tmReturn tt.


(* ******************************************************************************* *)
(** The projection of the total bicategory of some displayed category to the base
 ********************************************************************************* *)
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.Invertible_2cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section Projection.
  Context {C : bicat}.
  Variable (D : disp_bicat C).

  Definition strict_pr1_psfunctor_data : strict_psfunctor_data (total_bicat D) C.
  Proof.
    use make_strict_psfunctor_data.
    - exact pr1.
    - exact (λ _ _, pr1).
    - exact (λ _ _ _ _, pr1).
    - exact (λ a, idpath _).
    - exact (λ _ _ _ f g, idpath _).
  Defined.

  Definition strict_pr1_psfunctor_laws : is_strict_psfunctor strict_pr1_psfunctor_data.
  Proof.
    repeat split; intro a; intros; cbn.
    - rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite id2_left.
      apply idpath.
    - rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite id2_left.
      apply idpath.
    - rewrite !lwhisker_id2, !id2_rwhisker.
      rewrite !id2_left, !id2_right.
      apply idpath.
    - rewrite id2_right.
      rewrite id2_left.
      apply idpath.
    - rewrite id2_left.
      rewrite id2_right.
      apply idpath.
  Qed.

  Definition strict_pr1_psfunctor : strict_psfunctor (total_bicat D) C.
  Proof.
    use make_strict_psfunctor.
    - exact strict_pr1_psfunctor_data.
    - exact strict_pr1_psfunctor_laws.
  Defined.

  Definition pr1_psfunctor : psfunctor (total_bicat D) C
    := strict_psfunctor_to_psfunctor_map _ _ strict_pr1_psfunctor.
End Projection.


Require Import RndHoare.sigma_algebra.
Require Import RndHoare.measurable_function.
Require Import RndHoare.regular_conditional_prob.
Require Import RndHoare.random_oracle.
Require Import RndHoare.random_variable.
Require Import RndHoare.meta_state.
Require Import RndHoare.probabilistic_pred.
Require Import RndHoare.imperative.
Import Randomized.

Module Normal.

Class Imperative : Type := {
  acmd: Type;
  expr: Type
}.

Inductive cmd {imp: Imperative}: Type :=
  | Sifthenelse: expr -> cmd -> cmd -> cmd
  | Swhile: expr -> cmd -> cmd
  | Satomic: acmd -> cmd
  | Ssequence: cmd -> cmd -> cmd
  | Sskip: cmd.

Class SmallStepSemantics {imp: Imperative} : Type := {
  state: Type;
  state_sig: SigmaAlgebra state;
  cmd_state_sig := (left_discreste_prod_sigma_alg cmd state);
  ora: RandomOracle;
  SFo: SigmaAlgebraFamily RandomHistory;
  HBSFo: HistoryBasedSigF ora;
  eval_bool: state -> expr -> option bool;
  atomic_step: forall c: acmd, state -> forall {Omega: RandomVarDomain}, ProgState Omega state -> Prop
}.

Existing Instances state_sig cmd_state_sig ora SFo HBSFo.

Inductive step {imp: Imperative} {sss: SmallStepSemantics}: cmd * state -> forall {Omega: RandomVarDomain}, ProgState Omega (cmd * state)%type -> Prop :=
  | step_atomic: forall (ac: acmd) (s: state) (Omega: RandomVarDomain) (cs: ProgState Omega state),
      atomic_step ac s cs -> step (Satomic ac, s) (ProgState_pair_left Sskip cs)
  | step_if_true: forall e c1 c2 s, eval_bool s e = Some true -> step (Sifthenelse e c1 c2, s) (non_branch_tstate (c1, s))
  | step_if_false: forall e c1 c2 s, eval_bool s e = Some false -> step (Sifthenelse e c1 c2, s) (non_branch_tstate (c2, s))
  | step_while_true: forall e c s, eval_bool s e = Some true -> step (Swhile e c, s) (non_branch_tstate (Ssequence c (Swhile e c), s))
  | step_while_false: forall e c s, eval_bool s e = Some false -> step (Swhile e c, s) (non_branch_tstate (Sskip, s))
  | step_skip: forall c s, step (Ssequence Sskip c, s) (non_branch_tstate (c, s)).

End Normal.

Instance normal_imp {Nimp: Normal.Imperative}: Imperative := Build_Imperative Normal.cmd Normal.expr Normal.Sskip Normal.Ssequence.

Instance normal_sss {Nimp: Normal.Imperative} {Nsss: Normal.SmallStepSemantics}: SmallStepSemantics := Build_SmallStepSemantics normal_imp Normal.state Normal.state_sig Normal.ora Normal.SFo Normal.HBSFo Normal.step.

Section HoareSound.

Context {Nimp: Normal.Imperative} {Nsss: Normal.SmallStepSemantics}.

Lemma Consequence: forall P P' Q Q' c, derives P' P -> derives Q Q' -> triple P c Q -> triple P' c Q'.
Proof.
  intros.
  unfold triple in *.
  intros.
  specialize (H _ s1); simpl in H.
  specialize (H0 _ s2); simpl in H0.
  specialize (H1 o1 s1 (H H2) o2 s2 H3).
  destruct H1; auto.
Qed.

Lemma Sequence: forall P Q R c1 c2, triple P c1 Q -> triple Q c2 R -> triple P (Ssequence c1 c2) R.
Proof.
  intros ? ? ? ? ? TRIPLE1 TRIPLE2.
  unfold triple in *; intros.
  destruct H0 as [path [? ?]].
Abort.

End HoareSound.