Add LoadPath "../from_compcert".
Require Import Libs.
Require Import Polyhedra.
Require Import Loops.
Require Import Memory.
Require Import ArithClasses.
Require Import Permutation.
Require Import Sorted.
Require Import PLang.
Require Import CeildFloord.
Require Import Psatz.
Require Import Instructions.
Require Import Bounds.
Require Import BoxedPolyhedra.
Require Import TimeStamp.
Open Scope string_scope.

Generalizable Variables nbr_params depth.

Module Extract (Import M:BASEMEM(ZNum))
  (I:INSTRS(ZNum) with Definition Value := M.Value).
  Module L := Semantics(ZNum)(M)(I).
  Import L.
  Import T.
  Module P := PSemantics M I.
  Import P.
  Open Scope Z_scope.

  Definition not_implemented {A:Type} : res A :=
    Err "Not Implemented".

  Definition res_of_option {A:Type} (oa: option A) (err: String.string) : res A :=
    match oa with
      | None => Err err
      | Some a => OK a
    end.

  Definition instruction_not_found :=
    "The instruction is not linked to any instruction".

  Definition wrong_length :=
    "The vector cannot be build because the lenght is incorrect".

  Program Definition point_boxed_polyhedron (global_depth: nat) :
    Boxed_Polyhedron global_depth 0:=
    {| bp_poly := [];
       bp_elts := (fun _ => [V0 0])|}.
  Next Obligation.
    Case "bp_elts_NoDup".
    constructor; auto. constructor.
  Qed.
  Next Obligation.
    Case "bp_in_elts_in_poly".
    unfold constrain_params.
    unfold constrain_params.
(*    apply Pol_Included_intersertion; auto.
    apply poly_containing_params_drop_2.
    apply Vdrop_p_app.*)
    unfold Pol_In. constructor.
  Qed.
  Next Obligation.
    Case "bp_in_poly_in_elts".
    left. apply PVeq_Veq. reflexivity.
  Qed.

(*  Program Definition ptree_get {A} (i: positive) (m: PTree.t A) :
    {a:A | m ! i = Some a}+{ m ! i = None} :=
    match m ! i with
      | None => inright _ _
      | Some a => inleft _ a
    end.*)

  Definition raise_time_stamp {global_depth: nat} (pos: Z)
    (pi: Polyhedral_Instruction global_depth)
    : Polyhedral_Instruction global_depth :=
      {| pi_instr := pi.(pi_instr);
         pi_depth := pi.(pi_depth);
         pi_poly := pi.(pi_poly);
         pi_schedule := (pos ::: V0 (pi.(pi_depth) + global_depth)) :: pi.(pi_schedule);
         pi_transformation := pi.(pi_transformation)|}.

  (* let's try dependent types horrors *)

  Definition cast_list {A: nat -> Type} {n p: nat} (EQnp: p= n)
    (l: list (A n)) : list (A p).
  Proof.
    rewrite <- EQnp in l. exact l.
  Defined.

  Definition cast_A {A: nat -> Type} {n p: nat} (EQnp: p = n)
    (a: (A n)) : (A p).
  Proof.
    rewrite <- EQnp in a; exact a.
  Defined.

  Lemma cast_list_cast_A {A: nat -> Type} {n p: nat} (EQnp: p = n)
    (l: list (A n)):
    cast_list EQnp l = map (cast_A EQnp) l.
  Proof.
    induction' l as [|a l].
    Case "nil".
      destruct EQnp. reflexivity.
    Case "cons a l".
      simpl.
      rewrite <- IHl. clear IHl.
      destruct EQnp. simpl. reflexivity.
  Qed.

  Definition plus_nSm_Snm n m := eq_sym (plus_Snm_nSm n m).

  Definition cast_polyhedron {nbr_global_parameters depth}
    (pol: Polyhedron (depth + (S nbr_global_parameters))) :
    Polyhedron ((S depth) + nbr_global_parameters):=
    cast_list (plus_Snm_nSm _ _) pol.

  Definition cast_constr {nbr_global_parameters depth}
    (constr: Constraint (depth + (S nbr_global_parameters))) :
    Constraint ((S depth) + nbr_global_parameters) :=
    cast_A (plus_Snm_nSm _ _) constr.

  Lemma cast_poly_cast_constr nbr_global_parameters depth
    (pol: Polyhedron (depth + (S nbr_global_parameters))):
    cast_polyhedron pol = map cast_constr pol.
  Proof.
    apply cast_list_cast_A.
  Qed.

  Ltac dest_eq_rect :=
    match goal with
      | |- context[eq_rect_r _ _ ?H] =>
        match H with
          | eq_refl => fail 1
          | _ => destruct H
        end
    end.

  Lemma satify_cast_constraint nbr_global_parameters depth
    (v1 : ZVector depth) (v2: ZVector nbr_global_parameters) z constr:
    satisfy_constraint (v1 +++ z ::: v2) constr <->
    satisfy_constraint ((v1 :::: z) +++ v2) (cast_constr constr).
  Proof.
    destruct constr.
    unfold satisfy_constraint in *. simpl in *.
    unfold cast_constr, cast_A.
    match goal with
      | |- satisfy_comparison ?z ?c ?v <->
        satisfy_comparison ?z' ?c' ?v' =>
        assert' (z = z') as ZEQ;[|
        End_of_assert ZEQ;
        assert' (c = c') as CEQ;[|
        End_of_assert CEQ;
        assert' (v = v') as VEQ]]
    end.
    SCase "Assert: ZEQ".
      clear.
      unfold Vprod. dest_vects.
      dest_eq_rect.
      simpl. f_equal.
      clear.
      induction v1; simpl; auto. f_equal; auto.
    SCase "Assert: CEQ".
      clear. dest_eq_rect. reflexivity.
    SCase "Assert: VEQ".
      clear. dest_eq_rect. reflexivity.
    End_of_assert VEQ.
    split; intro; congruence.
  Qed.

  Lemma Pol_In_cast_polyhedron nbr_global_parameters depth
    (v1 : ZVector depth) (v2: ZVector nbr_global_parameters) z pol:
    v1 +++ (z ::: v2) ∈ pol <->
    (v1 :::: z) +++ v2 ∈ (cast_polyhedron pol).
  Proof.
    rewrite cast_poly_cast_constr.
    unfold Pol_In.
    induction' pol as [|constr pol]; simpl; intros; auto.
    Case "nil".
      split; intros; constructor.
    Case "cons constr pol".
    destruct IHpol.
    split'; intros.
    SCase "->".
      inv H1. constructor; auto.
      apply satify_cast_constraint; auto.
    SCase "<-".
      inv H1. constructor; auto.
      apply satify_cast_constraint; auto.
  Qed.

  (* list of Z between lb and ub *)

  Lemma nat_of_Z_Zabs_nat: forall z, 0 <= z ->
    nat_of_Z z = Zabs_nat z.
  Proof.
    intros z ABS.
    destruct z; try reflexivity.
    compute in ABS. exfalso. auto.
  Qed.

  Require Import Recdef.
  Function list_of_Z_between_aux (ub lb:Z) {measure (fun lb => nat_of_Z ((ub - lb) + 1)) lb}: list Z:=
    if Z_le_dec lb ub then
      lb :: list_of_Z_between_aux ub (Zsucc lb)
    else
      [].
    intros. clear teq.
    unfold Zsucc.
    rewrite nat_of_Z_Zabs_nat; [|lia].
    rewrite nat_of_Z_Zabs_nat; [|lia].
    zify. lia.
  Qed.

  Definition list_of_Z_between lb ub := list_of_Z_between_aux ub lb.

  Lemma list_of_Z_between_correct: forall lb ub z,
    In z (list_of_Z_between lb ub) <-> lb <= z <= ub.
  Proof.
    intros ? ?. unfold list_of_Z_between.
    functional induction (list_of_Z_between_aux ub lb); intros.
    Case "lb <= ub".
    destruct' (z == lb).
    SCase "z = lb".
      subst. split; simpl; intros; auto. lia.
    SCase "z <> lb".
      split; intros.

      simpl in H.
      destruct H; try congruence;
      destruct (IHl z) as [TRI _];
      specialize (TRI H). unfold Zsucc in *. lia.

      simpl. right. apply IHl. unfold Zsucc. lia.

    Case "lb > ub".
    simpl. split; intro; clean. lia.
  Qed.

  Lemma rewrite_list_of_Z_between_le: forall lb ub, lb <= ub ->
    list_of_Z_between lb ub = lb :: list_of_Z_between (Zsucc lb) ub.
  Proof.
    intros. unfold list_of_Z_between.
    rewrite list_of_Z_between_aux_equation.
    dest_if_goal; auto.
    lia.
  Qed.

  Lemma rewrite_list_of_Z_between_gt: forall lb ub, lb > ub ->
    list_of_Z_between lb ub = [].
  Proof.
    intros. unfold list_of_Z_between.
    rewrite list_of_Z_between_aux_equation.
    dest_if_goal; auto.
    lia.
  Qed.

  Definition constraint_of_lower_bound_constr {nbr_params}
    (constr: ZNum.Num * NVector (S nbr_params))
     : Constraint (S nbr_params):=
    {| constr_vect := fst constr ::: (-- (Vtail (snd constr)));
       constr_comp := GE ;
       constr_val := Vhd (snd constr)|}.

  Lemma constraint_of_lower_bound_constr_correct {nbr_params}
    (constr: ZNum.Num * NVector (S nbr_params)):
    forall z (ctxt: Context nbr_params),
      ge_bound_constraint (extend_context ctxt) z constr <->
      satisfy_constraint (z:::ctxt) (constraint_of_lower_bound_constr constr).
  Proof.
    intros.
    destruct constr as (x, v).
    unfold constraint_of_lower_bound_constr, ge_bound_constraint,
      satisfy_constraint, extend_context; simpl.
    rewrite <- (Vcons_hd_tail v).
    repeat rewrite Vprod_Vcons. simpl_vect.
    simpl. rewrite Vprod_comm. lia.

    constructor. exact 0.
  Qed.

  Definition polyhedron_of_lower_bound {nbr_params}
    (lower_bound: bound nbr_params)
      : Polyhedron (S nbr_params) :=
      map constraint_of_lower_bound_constr lower_bound.

  Lemma polyhedron_of_lower_bound_correct {nbr_params}
    (lower_bound: bound nbr_params):
    forall z (ctxt: Context nbr_params),
      ge_bound ctxt lower_bound z <->
      (z:::ctxt) ∈ (polyhedron_of_lower_bound lower_bound).
  Proof.
    intros.
    unfold ge_bound, Pol_In, polyhedron_of_lower_bound.
    split; intro.
    Case "satisfy_constraint".
      eapply list_forall_list_forall_map;[| eauto].
      intros. rewrite <- constraint_of_lower_bound_constr_correct; auto.
    Case "ge_bound_constraint".
      eapply list_forall_map_list_forall;[| eauto].
      intros.
      rewrite -> constraint_of_lower_bound_constr_correct; auto.
  Qed.

  Definition constraint_of_upper_bound_constr {nbr_params}
    (constr: ZNum.Num * NVector (S nbr_params))
     : Constraint (S nbr_params):=
    {| constr_vect := (- fst constr) ::: (Vtail (snd constr));
       constr_comp := GE ;
       constr_val := - (Vhd (snd constr))|}.

  Lemma constraint_of_upper_bound_constr_correct {nbr_params}
    (constr: ZNum.Num * NVector (S nbr_params)):
    forall z (ctxt: Context nbr_params),
      le_bound_constraint (extend_context ctxt) z constr <->
      satisfy_constraint (z:::ctxt) (constraint_of_upper_bound_constr constr).
  Proof.
    intros.
    destruct constr as (x, v).
    unfold constraint_of_upper_bound_constr, le_bound_constraint,
      satisfy_constraint, extend_context; simpl.
    rewrite <- (Vcons_hd_tail v).
    repeat rewrite Vprod_Vcons. simpl_vect.
    simpl. rewrite Vprod_comm. unfold ZNum.Num, ZNum.Numerical_Num.
    lia.
    constructor. exact 0.
  Qed.

  Definition polyhedron_of_upper_bound {nbr_params}
    (upper_bound: bound nbr_params)
      : Polyhedron (S nbr_params) :=
      map constraint_of_upper_bound_constr upper_bound.

  Lemma polyhedron_of_upper_bound_correct {nbr_params}
    (upper_bound: bound nbr_params):
    forall z (ctxt: Context nbr_params),
      le_bound ctxt upper_bound z <->
      (z:::ctxt) ∈ (polyhedron_of_upper_bound upper_bound).
  Proof.
    intros.
    unfold le_bound, Pol_In, polyhedron_of_upper_bound.
    split; intro.
    Case "satisfy_constraint".
      eapply list_forall_list_forall_map; [|eauto].
      intros. rewrite <- constraint_of_upper_bound_constr_correct; auto.
    Case "le_bound_constraint".
      eapply list_forall_map_list_forall; [|eauto].
      intros.
      rewrite -> constraint_of_upper_bound_constr_correct; auto.
  Qed.

  Definition Pol_translate_r {n} p (pol: Polyhedron n) : Polyhedron (p + n) :=
    map (Constr_translate_r p) pol.

  Lemma Pol_translate_r_correct n p (pol: Polyhedron n) v1 v2:
    v2 ∈ pol <-> (v1 +++ v2) ∈ (Pol_translate_r p pol).
  Proof.
    unfold Pol_In, Pol_translate_r.
    split; intro H.
    eapply list_forall_list_forall_map; [|eauto].
    intros. apply Constr_translate_r_correct. assumption.

    eapply list_forall_map_list_forall; [|eauto].
    intros. apply <- Constr_translate_r_correct. eassumption.
  Qed.

  Definition build_poly_for_Loop {nbr_param depth}
    (lower_bound upper_bound: bound nbr_param)
    (pol: Polyhedron (depth + S nbr_param))
    : Polyhedron (S depth + nbr_param) :=
    cast_polyhedron(
      (Pol_translate_r depth (polyhedron_of_lower_bound lower_bound))
    ∩ (Pol_translate_r depth (polyhedron_of_upper_bound upper_bound))
    ∩ pol).

  Program Definition eval_lower_bound_no {nbr_param} params (lower_bound: bound nbr_param)
    (OKLB: bound_correct lower_bound)
      : {z:Z| eval_lower_bound params lower_bound = Some z} :=
    match eval_lower_bound params lower_bound with
      | Some z => z
      | None => !
    end.
  Next Obligation.
    apply bound_correct_eval_lower_bound_is_some with (ctxt := params) in OKLB.
    inv OKLB.
    replace @ZTools.eval_lower_bound with @eval_lower_bound in * by reflexivity.
    congruence.
  Qed.

  Program Definition eval_upper_bound_no {nbr_param} params (upper_bound: bound nbr_param)
    (OKLB: bound_correct upper_bound)
      : {z:Z| eval_upper_bound params upper_bound = Some z} :=
    match eval_upper_bound params upper_bound with
      | Some z => z
      | None => !
    end.
  Next Obligation.
    apply bound_correct_eval_upper_bound_is_some with (ctxt := params) in OKLB.
    inv OKLB.
    replace @ZTools.eval_upper_bound with @eval_upper_bound in * by reflexivity.
    congruence.
  Qed.

  Lemma NoDup_app : forall A (l: list A) l', NoDup l -> NoDup l' ->
    (forall x, In x l -> In x l' -> False) ->
    NoDup (l++l').
  Proof.
    intros A l.
    induction' l as [|a l]; simpl; intros l' NO NO' NOTIN; auto.
    Case "cons a l".
      constructor.
      intro IN. apply in_app_or in IN. destruct IN as [IN|IN].
      inv NO. auto.
      apply (NOTIN a); auto.
      inv NO. apply IHl; auto.
      intros. apply (NOTIN x); eauto.
  Qed.

  Lemma In_map_inj : forall A B (f: A -> B),
    (forall x y, f x = f y -> x = y) ->
    forall a (l: list A),
      In (f a) (map f l) ->
      In a l.
  Proof.
    intros * INJ *.
    induction' l as [|x l]; intro IN; simpl in *; inv IN; auto.
  Qed.

  Lemma NoDup_map_inj : forall A B (f: A -> B),
    (forall x y, f x = f y -> x = y) ->
    forall (l: list A),
    NoDup l ->
    NoDup (map f l).
  Proof.
    intros * INJ.
    induction' l as [|a l]; simpl; intros NO.
    Case "nil".
      constructor.
    Case "cons a l".
      inv NO.
      constructor; auto.
      intro. apply H1. apply In_map_inj with (f := f); auto.
  Qed.

  Lemma In_flatten A (ll: list (list A)) x:
    In x (flatten ll) <-> exists l, In l ll /\ In x l.
  Proof.
    induction' ll as [| l1 ll]; simpl.
    Case "nil".
      split'; auto.
      SCase "<-".
        intros [?[? ?]]; auto.
    Case "cons l1 ll".
      split'.
      SCase "->".
        intro IN.
        apply in_app_or in IN. destruct IN as [IN | IN].
          exists l1; auto.
          rewrite IHll in IN. destruct IN as [l [? ?]].
          exists l; auto.
      SCase "<-".
        intros [l [[?|?] ?]]; subst;
        apply in_or_app; auto.
        right; apply IHll.
        eexists; eauto.
  Qed.

  Lemma in_map2_exists A B C (f: A -> B -> C) la lb c:
    In c (map2 f la lb) ->
    exists a b,
      In a la /\ In b lb /\ f a b = c.
  Proof.
    revert lb.
    induction' la as [|a la]; destruct' lb as [|b lb]; intros * IN; simpl in *; clean.
    Case "cons a la"; SCase "cons b lb".
      destruct IN.
      exists a, b; auto.
      edestruct IHla as [a' [b' [?[? ?]]]]; eauto.
      exists a', b'; auto.
  Qed.

  Lemma snoc_inj A l1 l2 (a:A):
    l1 ++ [a] = l2 ++ [a] ->
    l1 = l2.
  Proof.
    revert l2; induction' l1 as [| a1 l1]; intros l2 EQ;
    destruct' l2 as [|a2 l2]; simpl in *; auto.
    Case "nil"; SCase "cons a2 l2".
      inv EQ. destruct l2; inv H1.
    Case "cons a1 l1"; SCase "nil".
      inv EQ; destruct l1; simpl in *; congruence.
    Case "cons a1 l1"; SCase "cons a2 l2".
      inv EQ; f_equal; auto.
  Qed.

  Fixpoint last_Z (l: list Z) :=
    match l with
      | [] => 0
      | [z] => z
      | _ :: l' => last_Z l'
    end.

  Program Definition Vlast_Z {n} (v: ZVector (S n)) :=
    last_Z v.

  Lemma Vlast_Z_Vsnoc n (v: ZVector n) z :
    Vlast_Z (v::::z) = z.
  Proof.
    dest_vects. unfold Vlast_Z. simpl. clear Lv.
    induction v; simpl; auto.
    destruct v; auto.
  Qed.

  Fixpoint Vtake_aux `{Inhabited A} n (l: list A) :=
    match n with
      | O => []
      | S n' =>
        match l with
          | [] => repeat n repr
          | a:: l' => a :: Vtake_aux n' l'
        end
    end.
  Program Definition Vtake `{Inhabited A} n {p} (v: Vector A p): Vector A n:=
    Vtake_aux n v.
  Next Obligation.
    dest_vects.
    clear.
    revert v.
    induction' n as [|n]; intros; simpl.
    Case "O".
      reflexivity.
    Case "S n".
      destruct' v.
      SCase "nil".
        simpl. f_equal. apply repeat_length.
      SCase "cons".
        simpl. f_equal. auto.
  Qed.

  Lemma split_big_vect nbr_param depth (v:ZVector (S depth + nbr_param)):
    exists elts z params,
      v = (elts :::: z) +++ params.
  Proof.
    exists (Vtake depth v).
    exists (Vnth v depth).
    exists (Vdrop_p (S depth) v).
    dest_vects.
    revert dependent nbr_param.
    revert v.
    induction' depth as [|depth]; simpl; intros; auto.
    Case "O".
      destruct' v as [|z v]; simpl in *; clean.
    Case "S depth".
      destruct' v as [|z v]; simpl in *; clean.
      f_equal; eauto.
  Qed.

  Program Definition build_boxed_poly_for_Loop {nbr_param depth}
    (lower_bound upper_bound: bound nbr_param) (OKLB: bound_correct lower_bound)
    (OKUB: bound_correct upper_bound) (bpol: Boxed_Polyhedron (S nbr_param) depth)
    : Boxed_Polyhedron (nbr_param) (S depth):=
    {| bp_poly := build_poly_for_Loop lower_bound upper_bound bpol.(bp_poly);
       bp_elts := fun params =>
         let lb := eval_lower_bound_no params lower_bound OKLB in
         let ub := eval_upper_bound_no params upper_bound OKUB in
         let lZ := list_of_Z_between lb ub in
         let bpol_params_lst  := map (fun z => z ::: params) lZ in
         let bpol_elts_lst := map bpol.(bp_elts) bpol_params_lst in
         let elts_lst := map2 (fun z vl => map (fun v => v :::: z) vl)
             lZ bpol_elts_lst in
         flatten elts_lst
         |}.
  Next Obligation.
    destruct (eval_lower_bound_no params lower_bound OKLB) as [lb ELB].
    destruct (eval_upper_bound_no params upper_bound OKUB) as [ub EUB].
    simpl.
    unfold list_of_Z_between.
    clear.
    functional induction (list_of_Z_between_aux ub lb); [|constructor].
    simpl.
    apply NoDup_app; auto.
    Case "NoDup".
    apply NoDup_map_inj.
      clear'.
      intros * EQ.
      assert (` (x :::: lb) = ` (y :::: lb)) by congruence. clear EQ.
      dest_vects. simpl in *. eapply snoc_inj; eauto.
      apply bp_elts_NoDup.

    Case "Not In".
      intros * IN INFLAT.
      assert' (Vlast_Z x = lb) as VLASTEQ.
        SCase "Assert: VLASTEQ".
        clear' - IN.
        rewrite in_map_iff in IN.
        destruct IN as [v [? ?]].
        subst. apply Vlast_Z_Vsnoc.
      End_of_assert VLASTEQ.
      assert' (Vlast_Z x > lb) as VLASTGT.
        SCase "Assert: VLASTGT".
        clear' - INFLAT.
        rewrite In_flatten in INFLAT.
        destruct INFLAT as [l [INxl INll]].
        apply in_map2_exists in INxl.
        destruct INxl as [z [l' [INz [_ ?]]]]; subst.
        fold (list_of_Z_between (Zsucc lb) ub) in INz.
        rewrite list_of_Z_between_correct in INz.
        apply in_map_iff in INll. destruct INll as [? [? ?]]; subst.
        rewrite Vlast_Z_Vsnoc. unfold Zsucc in *. lia.
      End_of_assert VLASTGT.
      lia.
  Qed.
  Next Obligation.
    destruct (eval_lower_bound_no params lower_bound OKLB) as [lb ELB].
    destruct (eval_upper_bound_no params upper_bound OKUB) as [ub EUB].
    match goal with
      | |-
        @Pol_In (S (depth +  nbr_param))
        ?v ?p =>
        replace (@Pol_In (S (depth + nbr_param))
        v p) with (@Pol_In ((S depth) + nbr_param)
        v p) by reflexivity
    end.
(*    apply in_pol_in_constrain_params.*)

    simpl in *.
    rewrite In_flatten in H.
    destruct H as [l [IN2 INl]].
    rewrite map_map in IN2.

    match type of IN2 with
      | In l (map2 ?f ?loz (map ?g ?loz)) =>
      assert'
      (exists z, In z (list_of_Z_between lb ub) /\
        l = f z (g z)) as EXZ
    end.
    Case "Assert: EXZ".
      remember (list_of_Z_between lb ub) as loz. clear Heqloz.
      induction' loz as [|z loz]; simpl in *; clean.
      SCase "cons z loz".
        inv IN2.
        exists z; split'; auto.
        specialize (IHloz H).
        destruct IHloz as [z' [? ?]].
        exists z'; eauto.
    End_of_assert EXZ.
    clear IN2.
    destruct EXZ as [z [IN ?]].
    subst.
    rewrite list_of_Z_between_correct in IN.
    rewrite in_map_iff in INl.
    destruct INl as [v [? INv]]; subst.

    unfold build_poly_for_Loop.
    apply Pol_In_cast_polyhedron.
    repeat (apply Pol_Included_intersertion).
    Case "lower".
    apply Pol_translate_r_correct.
    apply polyhedron_of_lower_bound_correct.
    apply eval_lower_bound_is_ge in ELB.
    eapply ge_bound_trans; eauto. lia.
    Case "upper".
    apply Pol_translate_r_correct.
    apply polyhedron_of_upper_bound_correct.
    apply eval_upper_bound_is_ge in EUB.
    eapply le_bound_trans; eauto. lia.
    Case "params".
    pose proof in_constrain_param_in_pol. unfold Pol_Included in H.
    eapply H.
    eapply bp_in_elts_in_poly_constrain. eauto.
  Qed.
  Next Obligation.
    destruct (eval_lower_bound_no params lower_bound OKLB) as [lb ELB].
    destruct (eval_upper_bound_no params upper_bound OKUB) as [ub EUB].
    simpl.
    unfold constrain_params in H.
    destruct (split_big_vect _ _ vect) as [elts[z[params' ?]]].
    subst.
    assert' (params = params').
    Case "Assert".
      apply Pol_intersection_Included_l in H.
      apply poly_containing_params_drop_1 in H.
      rewrite Vdrop_p_app in H. auto.
    End_of_assert.
    subst.
    apply Pol_intersection_Included_r in H.
    unfold build_poly_for_Loop in H.
    apply Pol_In_cast_polyhedron in H.
    repeat match goal with
      | H : ?v ∈ ?p1 ∩ ?p2 |- _ =>
        pose proof (Pol_intersection_Included_l _ _ H);
        pose proof (Pol_intersection_Included_r _ _ H);
        clear H
    end.
    rewrite Vtake_p_app.
    apply Pol_translate_r_correct in H. apply Pol_translate_r_correct in H2.
    rewrite <- polyhedron_of_upper_bound_correct in H2.
    rewrite <- polyhedron_of_lower_bound_correct in H.
    eapply ge_bound_ge_lower_bound in H; eauto.
    eapply le_bound_le_upper_bound in H2; eauto.
    clear dependent lower_bound. clear dependent upper_bound.
    apply in_pol_in_constrain_params in H1.
    eapply bp_in_poly_in_elts in H1.
    rewrite Vtake_p_app in H1.
    assert' (In z (list_of_Z_between lb ub)) as INZ.
      Case "Assert: INZ".
      apply list_of_Z_between_correct. lia.
    End_of_assert INZ.
    remember (list_of_Z_between lb ub) as loz. clear Heqloz.
    clear dependent lb. clear dependent ub.
    induction' loz as [|z' loz]; inv INZ; simpl;
    rewrite in_app_iff; auto.
    Case "cons z' loz".
    left.
    apply in_map_iff. eexists; eauto.
  Qed.

  Definition cast_pi_transformation {pi_depth global_depth num_of_args}
    (mat: ZMatrix num_of_args (S (pi_depth + S global_depth)))
      : ZMatrix num_of_args (S (S pi_depth + global_depth)).
    pattern (S pi_depth + global_depth)%nat.
    refine (cast_A (plus_Snm_nSm _ _) mat).
  Defined.

  Lemma snoc_app A (v1 v2: list A) a :
    v1 ++ a :: v2 = (v1 ++[a]) ++ v2.
  Proof.
    induction v1; simpl; auto.
    f_equal; assumption.
  Qed.

  Lemma cast_pi_transformation_id {pi_depth global_depth num_of_args}
    (pi_transf: ZMatrix num_of_args (S (pi_depth + S global_depth)))
     (a: ZVector pi_depth) lb (ctxt: ZVector global_depth):
    pi_transf × (1 ::: (a +++ lb ::: ctxt)) =
   cast_pi_transformation pi_transf  × (1 ::: ((a :::: lb) +++ ctxt)).
  Proof.
    apply PVeq_Veq. unfold Matrix in *.
    dest_vects.
    unfold Mprod_vect, Vprod. simpl.
    clear.
    unfold cast_pi_transformation. unfold cast_A.
    dest_eq_rect. simpl.
    apply map_ext.
    intro v.
    clear.
    dest_vects. clear.
    rewrite snoc_app. auto.
  Qed.

  Definition make_pi_schedule {depth global_depth}
    (schedule: list (ZVector (S (depth + S global_depth))))
    : list (ZVector (S ( S depth + global_depth))) :=
    (0::: (((V0 depth) :::: 1) +++ V0 global_depth))::
    cast_list (eq_S _ _ (plus_Snm_nSm _ _)) schedule.

(*  Definition make_schedule*)

  Fixpoint extract_statement {global_depth: nat}
    (st: statement global_depth) {struct st}
    : res (list (Polyhedral_Instruction global_depth)) :=
    match st with
    | Instr instr transf =>
      OK [
        {| pi_instr := instr;
          pi_depth := O;
          pi_poly := point_boxed_polyhedron global_depth;
          pi_schedule := [(1 ::: V0 (0 + global_depth))];
          pi_transformation := transf
        |}]
    | Loop lb ub sts =>
      match check_bound lb with
      | left CLB =>
      match check_bound ub with
      | left CUB =>
      do lpi <- extract_statement_list 1 sts;
      OK(
        map (fun pi =>
          {|pi_instr := pi.(pi_instr);
            pi_depth := S (pi.(pi_depth));
            pi_poly := build_boxed_poly_for_Loop lb ub CLB CUB pi.(pi_poly);
            pi_schedule := make_pi_schedule pi.(pi_schedule);
            pi_transformation := cast_pi_transformation pi.(pi_transformation)|}
        ) lpi)
      | right _ => Err "Upper bound incorrect"
      end
      | right _ => Err "Lower bound incorrect"
      end

    end
  with extract_statement_list {global_depth: nat}
    (pos: Z) (stl: statement_list global_depth) {struct stl}
    : res (list (Polyhedral_Instruction global_depth)) :=
    match stl with
      | stl_nil => OK []
      | stl_cons st stl' =>
        do{;
          pil1 <- extract_statement st;;
          let pil1' := map (raise_time_stamp pos) pil1;;
          pil2 <- extract_statement_list (Zsucc pos) stl';
          OK (pil1' ++ pil2)
        }
    end.

  Lemma res_of_option_OK A (oa: option A) (a:A) err:
    res_of_option oa err = OK a -r> oa = Some a.
  Proof.
    constructor. unfold res_of_option. intro. destruct oa; clean.
  Qed.
  Hint Rewrite res_of_option_OK: clean.

  (* we use another semantics for the proof, juste to remove the poly
     program constructors. It's just a bit easier to express things *)

  Definition poly_list_semantics (global_depth: nat)
    (instrs_lst: list (Polyhedral_Instruction global_depth))
      (params : ZVector global_depth) (sorted_instruction_points : list Instruction_Point)
      (mem1 mem2 : Memory) : Prop :=
      Sorted instruction_point_lt sorted_instruction_points /\
      Permutation (flatten (map (expand_poly_instr params) instrs_lst))
        sorted_instruction_points /\
      instruction_list_semantics sorted_instruction_points mem1 mem2.

  Ltac destr_poly_list_semantics :=
    match goal with
      | H : poly_list_semantics _ _ _ _ _ _ |- _ =>
        destruct H as [? [? ?]]
    end.

(*  Lemma poly_list_semantics_equiv_poly_program_semantics: forall
    (instructions: PTree.t I.Instruction) (global_depth: nat)
    (instrs_lst: list (Polyhedral_Instruction instructions global_depth))
      (params : ZVector global_depth)  (mem1 mem2 : Memory),
      (exists sorted_instruction_points,
        poly_list_semantics instructions global_depth instrs_lst params
          sorted_instruction_points mem1 mem2)
        <->
      poly_program_semantics
       {| pp_instructions := instructions;
          pp_nbr_global_parameters := global_depth;
          pp_poly_instrs := instrs_lst |} params mem1 mem2.
  Proof.
    intros. constructor; intro H.
    Case "->".
      destruct H. destr_poly_list_semantics. econstructor; eauto.

    Case "<-".
      inv H; econstructor; econstructor; eauto.
  Qed.*)

  Lemma instruction_list_semantics_app1: forall l1 l2 mem1 mem3,
    instruction_list_semantics (l1++l2) mem1 mem3 ->
    exists mem2,
      instruction_list_semantics l1 mem1 mem2 /\
      instruction_list_semantics l2 mem2 mem3.
  Proof.
    intro l1.
    induction' l1 as [|i l1]; intros * INSTR; simpl in *.
    Case "nil".
      exists mem1. split; auto. constructor.
    Case "cons i l1".
      inv INSTR.
      edestruct IHl1 as [mem2' [? ?]]; eauto.
      eexists; split; eauto.
      econstructor; eauto.
  Qed.

  Lemma instruction_list_semantics_app2: forall l1 l2 mem1 mem2 mem3,
    instruction_list_semantics l1 mem1 mem2 ->
    instruction_list_semantics l2 mem2 mem3 ->
    instruction_list_semantics (l1++l2) mem1 mem3.
  Proof.
    intro l1; induction' l1 as [|i1 l1]; intros * INSTRSEM1 INSTRSEM2;
      simpl in *.
    Case "nil".
      inv INSTRSEM1; auto.
    Case "cons i1 l1".
      inv INSTRSEM1; econstructor; eauto.
  Qed.

  Definition raise_time_stamp_instr pos ip :=
    {| ip_instruction := ip.(ip_instruction);
       ip_arguments := ip.(ip_arguments);
       ip_time_stamp := pos :: ip.(ip_time_stamp)|}.

  Lemma raise_time_stamp_expand_poly_instr global_depth pos
    (pinstr: Polyhedral_Instruction global_depth) params :
    expand_poly_instr params (raise_time_stamp pos pinstr) =
    map (raise_time_stamp_instr pos) (expand_poly_instr params pinstr).
  Proof.
    destruct pinstr.
    unfold expand_poly_instr. simpl. clear.

    remember (bp_elts pi_poly0 params) as elts. clear Heqelts.

    induction' elts as [|ctxt elts]; simpl; auto.
    Case "cons ctxt elts".
      simpl. f_equal; auto.
      unfold raise_time_stamp_instr. simpl.
      f_equal.
      f_equal.
      unfold make_context_ext. rewrite Vprod_Vcons. simpl_vect. reflexivity.
  Qed.

  Lemma flatten_map_expand global_depth pos
    (pinstr_lst: list (Polyhedral_Instruction global_depth)) params:
  flatten (map (expand_poly_instr params) (map (raise_time_stamp pos) pinstr_lst)) =
  map (raise_time_stamp_instr pos) (flatten (map (expand_poly_instr params) pinstr_lst)).
  Proof.
    induction pinstr_lst; simpl; auto.
    rewrite map_app. f_equal; auto.
    apply raise_time_stamp_expand_poly_instr.
  Qed.

  Lemma raise_time_stamp_expand_poly_instr_sorted global_depth pos
    (pinstr_lst: list (Polyhedral_Instruction global_depth)) params
    sorted_list_1:
    Sorted instruction_point_lt sorted_list_1 ->
    Permutation (flatten (map (expand_poly_instr params) pinstr_lst))
      sorted_list_1 ->
    Sorted instruction_point_lt (map (raise_time_stamp_instr pos) sorted_list_1) /\
    Permutation (flatten (map (expand_poly_instr params)
                  (map (raise_time_stamp pos) pinstr_lst)))
                (map (raise_time_stamp_instr pos) sorted_list_1)
      .
  Proof.
    intros SORTED PERMUT.
    split.
    Case "Sorted".
      clear PERMUT.
      induction' SORTED; simpl; constructor; auto.
      SCase "Sorted_cons".
      clear' - H.
      induction' H; constructor; auto.
      SSCase "HdRel_cons".
        unfold raise_time_stamp_instr, instruction_point_lt in *.
        destruct a; destruct b. simpl in *.
        clear' - H.
        apply TSLT_eq. auto.
    Case "Permutation".
      clear' - PERMUT.
      rewrite flatten_map_expand.
      apply Permutation_map. auto.
  Qed.

  Lemma raise_time_stamp_poly_list_semantics global_depth
    (pil: list (Polyhedral_Instruction global_depth))
    instr_point_lst pos ctxt mem1 mem2:
    poly_list_semantics global_depth pil ctxt instr_point_lst
    mem1 mem2 ->
    poly_list_semantics global_depth (map (raise_time_stamp pos) pil)
    ctxt (map (raise_time_stamp_instr pos) instr_point_lst) mem1 mem2.
  Proof.
    intro PLS.
    destr_poly_list_semantics.
    edestruct raise_time_stamp_expand_poly_instr_sorted; eauto.
    econstructor;[|econstructor]; eauto.
    clear - H1.
    induction H1; econstructor; eauto.
    inv H. econstructor; eauto.
  Qed.

  Fixpoint list_of_statement_list {global_depth} (stl: statement_list global_depth):
    list (statement global_depth) :=
    match stl with
      | stl_nil => []
      | stl_cons st stl' => st :: list_of_statement_list stl'
    end.

  (* ESL_inv1: extract_statement_list invariant *)

  Inductive ESL_inv1 {global_depth : nat} {ctxt: Context global_depth}:
    forall (pos:Z) (mem1 mem2 : Memory)
    (st_lst: statement_list global_depth)
(*    (pol_instr_lst_lst: list (list (Polyhedral_Instruction global_depth)))*)
    (raised_pol_instr_lst_lst: list (list (Polyhedral_Instruction global_depth)))
    (instr_point_lst_lst: list (list Instruction_Point)),
      Prop :=
  | ESLI1_nil: forall pos mem,
    ESL_inv1 pos mem mem stl_nil (*[]*) [] []
  | ESLI2_cons: forall pos mem1 mem2 mem3
    st st_lst pol_instr_lst (*pol_instr_lst_lst*)
    raised_pol_instr_lst raised_pol_instr_lst_lst instr_point_lst instr_point_lst_lst,

    semantics_statement ctxt st mem1 mem2 ->

    extract_statement st = OK pol_instr_lst ->
    raised_pol_instr_lst = map (raise_time_stamp pos) pol_instr_lst ->

    Sorted instruction_point_lt instr_point_lst ->
    Permutation (flatten (map (expand_poly_instr ctxt) raised_pol_instr_lst))
      instr_point_lst ->
    instruction_list_semantics instr_point_lst mem1 mem2 ->

    ESL_inv1 (Zsucc pos) mem2 mem3
      st_lst (*pol_instr_lst_lst*) raised_pol_instr_lst_lst instr_point_lst_lst ->
    ESL_inv1 pos mem1 mem3 (stl_cons st st_lst) (*(pol_instr_lst :: pol_instr_lst_lst)*)
    (raised_pol_instr_lst :: raised_pol_instr_lst_lst) (instr_point_lst :: instr_point_lst_lst).

  Implicit Arguments ESL_inv1 [].

  Lemma ESL_inv1_extract_statement_list global_depth
    (ctxt: Context global_depth) pos mem1 mem2 st_lst (*pol_instr_lst_lst*)
    raised_pol_instr_lst_lst instr_point_lst_lst:
    ESL_inv1 global_depth ctxt pos mem1 mem2
      st_lst (*pol_instr_lst_lst*) raised_pol_instr_lst_lst instr_point_lst_lst ->
    extract_statement_list pos st_lst =
      OK (flatten raised_pol_instr_lst_lst).
  Proof.
    intros ESL; induction' ESL; simpl.
    Case "ESLI1_nil".
      reflexivity.
    Case "ESLI2_cons".
      rewrite H0. simpl_do. rewrite IHESL. simpl_do.
      f_equal.
      f_equal; auto.
  Qed.

  Lemma flatten_app {A} (l1 l2: list (list A)):
    flatten (l1 ++ l2) = flatten l1 ++ flatten l2.
  Proof.
    induction' l1; simpl; auto.
    rewrite IHl1. apply app_assoc.
  Qed.

  Lemma ESL_inv1_semantics_statement_list global_depth
    (ctxt: Context global_depth) pos mem1 mem2 st_lst (*pol_instr_lst_lst*)
    raised_pol_instr_lst_lst instr_point_lst_lst:
    ESL_inv1 global_depth ctxt pos mem1 mem2
      st_lst (*pol_instr_lst_lst*) raised_pol_instr_lst_lst instr_point_lst_lst ->
    semantics_statement_list  ctxt st_lst mem1 mem2.
  Proof.
    intro ESL.
    induction ESL; econstructor; eauto.
  Qed.

  Inductive first_dim_eq_time_stamp (pos:Z) : Time_Stamp -> Prop:=
  | fde_intro: forall ts, first_dim_eq_time_stamp pos (pos :: ts).

  Definition first_dim_eq pos ip := first_dim_eq_time_stamp pos (ip.(ip_time_stamp)).

  Inductive first_dim_gt_time_stamp (pos:Z) : Time_Stamp -> Prop:=
  | fdg_intro: forall x ts, pos < x -> first_dim_gt_time_stamp pos (x :: ts).

  Definition first_dim_gt pos ip := first_dim_gt_time_stamp pos (ip.(ip_time_stamp)).

  Lemma ESL_inv1_Forall_first_dim_gt global_depth
    (ctxt: Context global_depth) pos pos' mem1 mem2 st_lst (*pol_instr_lst_lst*)
    raised_pol_instr_lst_lst instr_point_lst_lst:
    ESL_inv1 global_depth ctxt pos' mem1 mem2
      st_lst (*pol_instr_lst_lst*) raised_pol_instr_lst_lst instr_point_lst_lst ->
    pos < pos' ->
    Forall (Forall (first_dim_gt pos)) instr_point_lst_lst.
  Proof.
    intros ESL.
    induction' ESL; simpl; intro INF; auto.
    Case "ESLI2_cons".
      constructor.
      SCase "Head".
        eapply Permutation_Forall;[|eauto].
        subst.
        rewrite map_map.
        apply Forall_flatten.
        clear' - INF.
        induction' pol_instr_lst; simpl; auto.
        SSCase "cons".
          constructor; auto.
          rewrite raise_time_stamp_expand_poly_instr.
          rewrite Forall_forall.
          intros * IN.
          rewrite in_map_iff in IN. destruct IN as [?[? ?]].
          subst. unfold first_dim_gt.
          destruct x0. simpl. constructor; assumption.
      SCase "Tail".
        apply IHESL. unfold Zsucc. lia.
  Qed.

  Lemma extract_statement_list_ok_correct (global_depth: nat)
    (pos: Z) (st_lst: statement_list global_depth)
    (instrs_lst : list (Polyhedral_Instruction global_depth)):
    extract_statement_list pos st_lst = OK instrs_lst ->
    forall ctxt mem1 mem2,
    semantics_statement_list ctxt st_lst mem1 mem2 ->
    (exists raised_pol_instr_lst_lst instr_point_lst_lst,
      ESL_inv1 global_depth ctxt pos mem1 mem2
        st_lst raised_pol_instr_lst_lst instr_point_lst_lst) ->
    exists sorted_instruction_points,
      poly_list_semantics global_depth instrs_lst
       ctxt sorted_instruction_points mem1 mem2.
  Proof.
    intros EXTRACT * SEM [raised_pol_instr_lst_lst [instr_point_lst_lst ESL]].
    exists (flatten instr_point_lst_lst).
    constructor; [|constructor].
    Case "Sorted".
      clear' - ESL.
      induction' ESL; simpl; auto.
      SCase "ESLI2_cons".
        apply ESL_inv1_Forall_first_dim_gt with (pos := pos) in ESL;
          [|unfold Zsucc; lia].
        subst.
        rewrite map_map in H3.
        assert (Forall (first_dim_eq pos) instr_point_lst) as FA.
          eapply Permutation_Forall; [|eauto].
          apply Forall_flatten.
          rewrite Forall_forall.
          clear'.
          intros instr_point_lst IN.
          rewrite in_map_iff in IN.
          destruct IN as [? [? ?]].
          subst.
          rewrite raise_time_stamp_expand_poly_instr.
          rewrite Forall_forall.
          clear'.
          intros instr_point_lst IN.
          rewrite in_map_iff in IN.
          destruct IN as [? [? ?]].
          subst. destruct x0; compute. constructor.

        clear' - H2 ESL IHESL FA.
        induction' instr_point_lst as [|ip instr_point_lst]; simpl; auto.
        SSCase "cons ip instr_point_lst".
          inv H2.
          specialize (IHinstr_point_lst H1).
          inv FA.
          constructor; auto.
          inv H3; auto; simpl; [|constructor; auto].
          apply Forall_flatten in ESL.
          inv ESL; constructor.
          clear' - H2 H0.
          unfold first_dim_eq, first_dim_gt, instruction_point_lt in *.
          destruct ip; destruct x; simpl in *.
          inv H2; inv H0. constructor. auto.
    Case "Permutation".
      erewrite ESL_inv1_extract_statement_list in EXTRACT; eauto.
      clean. clear SEM.
      induction' ESL.
      SCase "ESLI1_nil".
        simpl in *. clean.
      SCase "ESLI2_cons".
        simpl.
        rewrite map_app. rewrite flatten_app.
        apply Permutation_app; auto.

    Case "instruction_list_semantics".
      clear' - ESL.
      induction' ESL; simpl.
      SCase "ESLI1_nil".
        constructor.
      SCase "ESLI2_cons".
        eapply instruction_list_semantics_app2; eauto.
  Qed.
  Inductive hd_ge z : list Z -> Prop :=
  | hd_ge_intro: forall x l, z <= x ->
    hd_ge z (x :: l).

  Fixpoint map2_sl {A1 A2 B} (f: A1 -> A2 -> B) (l1: list A1)
    (l2: list A2) : option (list B) :=
    match l1, l2 with
    | [], [] => Some nil
    | [], _
    | _, [] => None
    | a1 :: l1', a2 :: l2' =>
      do l' <- map2_sl f l1' l2';
      Some (f a1 a2 :: l')
    end.

  Lemma flatten_map A B (f: A -> B) ll:
    flatten (map (fun l=> map f l) ll) = map f (flatten ll).
  Proof.
    induction ll; simpl; auto.
    rewrite IHll. symmetry. apply map_app.
  Qed.

  Lemma Permutation_flatten_map A B (f: A -> B) l ll:
    Permutation (flatten ll) l ->
    Permutation (flatten (map (fun l' => map f l') ll)) (map f l).
  Proof.
    intros. rewrite flatten_map. apply Permutation_map. assumption.
  Qed.

  Lemma bar: forall A
    (p_fst_part p_snd_part long_list: list (list A))
    (fst_part snd_part: list A),
    Permutation (flatten p_fst_part) fst_part ->
    Permutation (flatten p_snd_part) snd_part ->
    map2_sl (fun l1 l2 => l1 ++ l2) p_fst_part p_snd_part = Some long_list ->
    Permutation (flatten long_list) (fst_part ++ snd_part).
  Proof.
    intros.
    etransitivity; [|eapply Permutation_app; eauto].
    clear - H1.
    revert dependent p_snd_part. revert long_list.
    induction p_fst_part; simpl in *; intros;
    destruct p_snd_part; clean.
    prog_dos.
    specialize (IHp_fst_part _ _ Heq_do).
    simpl.
    etransitivity. apply Permutation_app; [reflexivity|eexact IHp_fst_part].
    rewrite <- app_assoc. rewrite <- app_assoc.
    apply Permutation_app. reflexivity.
    etransitivity;[|
    apply Permutation_app_comm].
    rewrite <- app_assoc.
    apply Permutation_app. reflexivity.
    apply Permutation_app_comm.
  Qed.

  Lemma foo: forall A
    (p_fst_part p_snd_part long_list: list (list A))
    (fst_part snd_part: list A)
    f,
    Permutation (flatten p_fst_part) fst_part ->
    Permutation (flatten p_snd_part) snd_part ->
    map2_sl (fun l1 l2 => (map f l1) ++ l2) p_fst_part p_snd_part = Some long_list ->
    Permutation (flatten long_list) (map f fst_part ++ snd_part).
  Proof.
    intros.
    eapply bar; eauto.
    apply Permutation_flatten_map; eauto.
    clear - H1.
    revert H1. revert long_list p_snd_part.
    induction p_fst_part; simpl in *; intros; clean.
    destruct p_snd_part; clean. prog_dos.
    erewrite IHp_fst_part in Heq_do0; eauto. clean.

    erewrite IHp_fst_part in Heq_do0;[|eauto]. clean.
  Qed.

  Fixpoint extract_statement_correct (global_depth: nat)
    (st: statement global_depth)
    (instrs_lst: list (Polyhedral_Instruction global_depth)) {struct st}:
    extract_statement st = OK instrs_lst ->
    forall ctxt mem1 mem2,
      semantics_statement ctxt st mem1 mem2 ->
      exists sorted_instruction_points,
      poly_list_semantics global_depth instrs_lst
       ctxt sorted_instruction_points mem1 mem2
  with extract_statement_list_ok (global_depth: nat)
    (pos: Z) (st_lst: statement_list global_depth)
    (instrs_lst : list (Polyhedral_Instruction global_depth)){struct st_lst}:
    extract_statement_list pos st_lst = OK instrs_lst ->
    forall ctxt mem1 mem2,
    semantics_statement_list ctxt st_lst mem1 mem2 ->
    exists raised_pol_instr_lst_lst instr_point_lst_lst,
      ESL_inv1 global_depth ctxt pos mem1 mem2
        st_lst raised_pol_instr_lst_lst instr_point_lst_lst
(*  with extract_statement_list_correct (global_depth: nat)
    (instructions: PTree.t I.Instruction) (pos: Z) (st_lst: statement_list global_depth)
    (instrs_lst : list (Polyhedral_Instruction global_depth)) {struct st_lst}:
    extract_statement_list pos st_lst = OK instrs_lst ->
    forall ctxt mem1 mem2,
      semantics_statement_list ctxt st_lst mem1 mem2 ->
      exists sorted_instruction_points,
      poly_list_semantics global_depth instrs_lst
       ctxt sorted_instruction_points mem1 mem2*).
  Proof.
    Case "extract_statement_correct".
      intros.
      destruct' st; simpl in H; unfold not_implemented in *; clean.
      SCase "Loop".
        destruct (check_bound lower_bound) as [CLB | _]; clean.
        destruct (check_bound upper_bound) as [CUB | _]; clean.
        inv H0; clean.
        assert (
          exists sorted_instruction_points,
            list_forall
              (fun ip => hd_ge lb ip.(ip_time_stamp)) sorted_instruction_points /\
            poly_list_semantics global_depth instrs_lst ctxt
              sorted_instruction_points mem1 mem2) as ASSERT;
        [|solve [destruct ASSERT as [sip [? ?]]; exists sip; auto]].
        prog_dos.
        specialize extract_statement_list_ok with (1 := Heq_do).
        assert' (forall ctxt mem1 mem2,
          semantics_statement_list ctxt body mem1 mem2 ->
          exists sorted_instruction_points,
            poly_list_semantics (S global_depth) lpi
            ctxt sorted_instruction_points mem1 mem2) as ESL_correct.
        SSCase "Assert: ESL_correct".
          intros. eapply extract_statement_list_ok_correct; eauto.
        End_of_assert ESL_correct.
        clear extract_statement_list_ok extract_statement_correct.
        clear Heq_do.
        unfold build_boxed_poly_for_Loop.
        simpl in *.
        unfold poly_list_semantics. simpl.

        repeat rewrite map_map.
        unfold expand_poly_instr. simpl.
        destruct (eval_lower_bound_no ctxt lower_bound CLB) as [lb' ?].
        destruct (eval_upper_bound_no ctxt upper_bound CUB) as [ub' ?].
        simpl.
        assert (ub' = ub) by congruence. subst.
        assert (lb' = lb) by congruence. subst.
        clear dependent lower_bound.
        clear dependent upper_bound.
        unfold list_of_Z_between.
        revert dependent mem2. revert mem1.
        functional induction (list_of_Z_between_aux ub lb); intros.
        SSCase "lb <= ub".
          inv H10; clean;[simpl in *; lia|].
          unfold Zsucc in *.
          specialize (IHl _ _ H6).
          specialize (ESL_correct _ _ _ H3).
          destruct ESL_correct as [fst_part [? [? ?]]].
          destruct IHl as [snd_part [? [? [? ? ]]]].
          exists
            ((map (fun ip =>
                {| ip_instruction := ip.(ip_instruction);
                   ip_arguments := ip.(ip_arguments);
                   ip_time_stamp := lb :: ip.(ip_time_stamp)|}) fst_part) ++
              snd_part).
          repeat (apply conj).
          S3Case "list_forall".
            apply list_forall_list_forall_app.
            S4Case "fst_part".
              clear'.
              induction fst_part; simpl; constructor; auto.
              constructor. lia.
            S4Case "snd_part".
              eapply list_forall_imply; [|eassumption].
              simpl. clear'. intros ip HDGE. inv HDGE. constructor. lia.
          S3Case "Sorted".
            clear' - H H4 H2.
            induction' fst_part as [|ip1 fst_part]; simpl; auto.
            S4Case "cons ip1 fst_part".
              inv H.
              constructor; auto.
              destruct' fst_part as [|ip2 fst_part]; simpl.
              S5Case "nil".
                destruct' snd_part as [|ip2 snd_part]; simpl; auto.
                S6Case "cons ip2 snd_part".
                  constructor.
                  inv H2. destruct ip2. red. simpl in *.
                  inv H1. apply TSLT_lt. lia.
              S5Case "cons ip2 fst_part".
                constructor. red. simpl. apply TSLT_eq.
                inv H5. red in H0. assumption.
          S3Case "Permutation".
            clear' - H0 H5.
            simpl.
            erewrite map_ext.
            Focus 2. intros.
            rewrite map_map. rewrite map_map.
            rewrite map_app. rewrite map_map.
            reflexivity.
            unfold expand_poly_instr in H0.
            Focus 1.
            eapply foo; eauto.
            clear'.
            induction' lpi as [|pi lpi].
            S4Case "nil".
              simpl. reflexivity.
            S4Case "cons pi lpi".
              simpl. rewrite IHlpi.
              simpl_do. clear'. f_equal.
              f_equal. f_equal.
              rewrite  map_map. simpl. rewrite map_map. simpl. apply map_ext.
              unfold make_context_ext. simpl.
              intros; f_equal. apply cast_pi_transformation_id.
              f_equal.
              rewrite Vprod_Vcons. simpl. unfold Context in *.
              clear'.
              destruct pi. simpl in *. clear'.
              match goal with
                | |-
                  context[〈?v1 +++ ?v2, ?v3 +++ ?v4〉] =>
                  pose proof (Vprod_app v1 v3 v2 v4) as VPA
              end.
              unfold ZNum.Num in *. unfold ZNum.Numerical_Num in *.
              simpl in VPA. rewrite VPA. clear VPA.
              simpl_vect. simpl; lia.

              destruct pi; simpl in *; clear'.
              rewrite cast_list_cast_A. unfold apply_schedule.
              induction' pi_schedule0; simpl; auto.
              S5Case "cons".
                f_equal; auto.
                clear'. unfold cast_A.
                dest_vects. clear'. dest_eq_rect. simpl.
                rewrite snoc_app; auto.

              rewrite map_map. rewrite map_map. apply map_ext.
              intros. reflexivity.

          S3Case "instruction_list_semantics".
            eapply instruction_list_semantics_app2; eauto.
            clear' - H1.
            induction H1; econstructor; eauto.
            inv H; simpl. econstructor; eauto.

        SSCase "ub < lb".
          simpl.
          inv H10; clean;[| simpl in *; lia].
          exists (@nil Instruction_Point).
          repeat constructor.
          clear'. induction lpi; auto.

      SCase "Instr".
      eexists; econstructor; [|econstructor]; simpl;[|reflexivity|].
      SSCase "Sorted".
        repeat constructor.
      SSCase "instruction_list_semantics".
        econstructor;[|econstructor].
        unfold make_context_ext.
        rewrite V0_Vapp.
        inv H0. clean.
        econstructor; simpl; clean; eauto.

    Case "extract_statement_list_ok".
      revert instrs_lst pos.
      destruct' st_lst as [|st st_lst]; intros * EXTRACT * SEM; inv SEM; clean.
      SCase "stl_nil".
        repeat econstructor.
      SCase "stl_cons st st_lst".
        simpl in EXTRACT.
        prog_dos.
        edestruct extract_statement_list_ok as [?[??]]; eauto.
        edestruct extract_statement_correct as [instr_point_lst H0]; eauto.
        eapply raise_time_stamp_poly_list_semantics in H0.
        destr_poly_list_semantics.
        eexists; eexists; econstructor; eauto.
(*    Case "extract_statement_list_correct".
    intros.
    eapply extract_statement_list_ok_correct; eauto.*)
  Qed.

  Definition extract_program (prog:Program) : res Poly_Program :=
    do pil <- extract_statement_list 1 prog.(prog_main);
    OK {|pp_nbr_global_parameters := prog.(prog_nbr_global_parameters);
         pp_poly_instrs := pil|}.

  Theorem extract_program_correct prog pprog:
    extract_program prog = OK pprog ->
    forall params mem1 mem2,
      program_semantics prog params mem1 mem2 ->
      poly_program_semantics_param instruction_point_lt pprog params mem1 mem2.
  Proof.
    intros EXTRACT * PROGSEM.
    unfold extract_program in EXTRACT.
    prog_dos.
    pose proof (extract_statement_list_ok _ _ _ _ Heq_do).

    destruct' (make_vector prog.(prog_nbr_global_parameters) params) as [Vparams|] _eqn.
    Case "Some Vparams".
      inv PROGSEM.
      assert (Vparams0 = Vparams) by congruence. subst.
      clear H0.

      edestruct extract_statement_list_ok_correct; eauto.

      destruct H0 as [? [? ?]].
      econstructor; simpl; eauto.

    Case "None".
    inv PROGSEM. rewrite H0 in Heqo. clean.
  Qed.

(*  Fixpoint extract_statement (instructions: PTree.t I.instruction)
    nbr_params depth (ctxt: boxed_poly nbr_params depth)
    (st : statement nbr_params depth) :=
*)
End Extract.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Homotopy coequalizers *)

Require Import HoTT.Basics UnivalenceImpliesFunext.
Require Import Types.Paths Types.Forall Types.Sigma Types.Arrow Types.Universe.
Local Open Scope path_scope.

(** ** Definition *)

Module Export Coeq.

  Private Inductive Coeq {B : Type@{i}} {A : Type@{j}}
    (f g : B -> A) : Type@{max(i,j)} :=
      | coeq : A -> Coeq f g.

  Arguments coeq {B A f g} a.

  Axiom cglue : forall {B A f g} (b:B), @coeq B A f g (f b) = coeq (g b).

  Definition Coeq_ind {B A f g} (P : @Coeq B A f g -> Type)
             (coeq' : forall a, P (coeq a))
             (cglue' : forall b, (cglue b) # (coeq' (f b)) = coeq' (g b))
  : forall w, P w
    := fun w => match w with coeq a => fun _ => coeq' a end cglue'.

  Axiom Coeq_ind_beta_cglue
  : forall {B A f g} (P : @Coeq B A f g -> Type)
           (coeq' : forall a, P (coeq a))
           (cglue' : forall b, (cglue b) # (coeq' (f b)) = coeq' (g b)) (b:B),
      apD (Coeq_ind P coeq' cglue') (cglue b) = cglue' b.

End Coeq.

Definition Coeq_rec {B A f g} (P : Type) (coeq' : A -> P)
  (cglue' : forall b, coeq' (f b) = coeq' (g b))
  : @Coeq B A f g -> P
  := Coeq_ind (fun _ => P) coeq' (fun b => transport_const _ _ @ cglue' b).

Definition Coeq_rec_beta_cglue {B A f g} (P : Type) (coeq' : A -> P)
  (cglue' : forall b:B, coeq' (f b) = coeq' (g b)) (b:B)
  : ap (Coeq_rec P coeq' cglue') (cglue b) = cglue' b.
Proof.
  unfold Coeq_rec.
  (** Use [eapply] rather than [refine] so that we don't get evars as goals, and don't have to shelve any goals with [shelve_unifiable]. *)
  eapply (cancelL (transport_const (cglue b) _)).
  refine ((apD_const (@Coeq_ind B A f g (fun _ => P) coeq' _) (cglue b))^ @ _).
  refine (Coeq_ind_beta_cglue (fun _ => P) _ _ _).
Defined.

(** ** Functoriality *)

Definition functor_coeq {B A f g B' A' f' g'}
           (h : B -> B') (k : A -> A')
           (p : k o f == f' o h) (q : k o g == g' o h)
: @Coeq B A f g -> @Coeq B' A' f' g'.
Proof.
  refine (Coeq_rec _ (coeq o k) _); intros b.
  refine (ap coeq (p b) @ _ @ ap coeq (q b)^).
  apply cglue.
Defined.

Definition functor_coeq_beta_cglue {B A f g B' A' f' g'}
           (h : B -> B') (k : A -> A')
           (p : k o f == f' o h) (q : k o g == g' o h)
           (b : B)
: ap (functor_coeq h k p q) (cglue b)
  = ap coeq (p b) @ cglue (h b) @ ap coeq (q b)^
:= (Coeq_rec_beta_cglue _ _ _ b).

Definition functor_coeq_compose {B A f g B' A' f' g' B'' A'' f'' g''}
           (h : B -> B') (k : A -> A')
           (p : k o f == f' o h) (q : k o g == g' o h)
           (h' : B' -> B'') (k' : A' -> A'')
           (p' : k' o f' == f'' o h') (q' : k' o g' == g'' o h')
: functor_coeq (h' o h) (k' o k)
               (fun b => ap k' (p b) @ p' (h b))
               (fun b => ap k' (q b) @ q' (h b))
  == functor_coeq h' k' p' q' o functor_coeq h k p q.
Proof.
  refine (Coeq_ind _ (fun a => 1) _); cbn; intros b.
  rewrite transport_paths_FlFr.
  rewrite concat_p1; apply moveR_Vp; rewrite concat_p1.
  rewrite ap_compose.
  rewrite !functor_coeq_beta_cglue, !ap_pp, functor_coeq_beta_cglue.
  rewrite <- !ap_compose. cbn.
  rewrite !ap_V, ap_pp, inv_pp, <- ap_compose, !concat_p_pp.
  reflexivity.
Qed.

Definition functor_coeq_homotopy {B A f g B' A' f' g'}
           (h : B -> B') (k : A -> A')
           (p : k o f == f' o h) (q : k o g == g' o h)
           (h' : B -> B') (k' : A -> A')
           (p' : k' o f == f' o h') (q' : k' o g == g' o h')
           (r : h == h') (s : k == k')
           (u : forall b, s (f b) @ p' b = p b @ ap f' (r b))
           (v : forall b, s (g b) @ q' b = q b @ ap g' (r b))
: functor_coeq h k p q == functor_coeq h' k' p' q'.
Proof.
  refine (Coeq_ind _ (fun a => ap coeq (s a)) _); cbn; intros b.
  refine (transport_paths_FlFr (cglue b) _ @ _).
  rewrite concat_pp_p; apply moveR_Vp.
  rewrite !functor_coeq_beta_cglue.
  Open Scope long_path_scope.
  rewrite !concat_p_pp.
  rewrite <- (ap_pp (@coeq _ _ f' g') (s (f b)) (p' b)).
  rewrite u, ap_pp, !concat_pp_p; apply whiskerL; rewrite !concat_p_pp.
  rewrite ap_V; apply moveR_pV.
  rewrite !concat_pp_p, <- (ap_pp (@coeq _ _ f' g') (s (g b)) (q' b)).
  rewrite v, ap_pp, ap_V, concat_V_pp.
  rewrite <- !ap_compose.
  exact (concat_Ap (@cglue _ _ f' g') (r b)).
  Close Scope long_path_scope.
Qed.

Definition functor_coeq_sect {B A f g B' A' f' g'}
           (h : B -> B') (k : A -> A')
           (p : k o f == f' o h) (q : k o g == g' o h)
           (h' : B' -> B) (k' : A' -> A)
           (p' : k' o f' == f o h') (q' : k' o g' == g o h')
           (r : Sect h h') (s : Sect k k')
           (u : forall b, ap k' (p b) @ p' (h b) @ ap f (r b) = s (f b))
           (v : forall b, ap k' (q b) @ q' (h b) @ ap g (r b) = s (g b))
: Sect (functor_coeq h k p q) (functor_coeq h' k' p' q').
Proof.
  refine (Coeq_ind _ (fun a => ap coeq (s a)) _); cbn; intros b.
  refine (transport_paths_FFlr (cglue b) _ @ _).
  rewrite concat_pp_p; apply moveR_Vp.
  rewrite functor_coeq_beta_cglue, !ap_pp.
  rewrite <- !ap_compose; cbn.
  rewrite functor_coeq_beta_cglue.
  Open Scope long_path_scope.
  rewrite !concat_p_pp.
  rewrite <- u, !ap_pp, !(ap_compose k' coeq).
  rewrite !concat_pp_p; do 2 apply whiskerL.
  rewrite !concat_p_pp.
  rewrite <- v.
  rewrite !ap_pp, !ap_V, !concat_p_pp, !concat_pV_p.
  rewrite <- !ap_compose.
  exact (concat_Ap cglue (r b)).
  Close Scope long_path_scope.
Qed.

Section IsEquivFunctorCoeq.

  Context {B A f g B' A' f' g'}
          (h : B -> B') (k : A -> A')
          `{IsEquiv _ _ h} `{IsEquiv _ _ k}
          (p : k o f == f' o h) (q : k o g == g' o h).

  Definition functor_coeq_inverse
  : @Coeq B' A' f' g' -> @Coeq B A f g.
  Proof.
    refine (functor_coeq h^-1 k^-1 _ _).
    - intros b.
      refine (ap (k^-1 o f') (eisretr h b)^ @ _ @ eissect k (f (h^-1 b))).
      apply ap, inverse, p.
    - intros b.
      refine (ap (k^-1 o g') (eisretr h b)^ @ _ @ eissect k (g (h^-1 b))).
      apply ap, inverse, q.
  Defined.

  Definition functor_coeq_eissect
  : Sect functor_coeq_inverse (functor_coeq h k p q).
  Proof.
    Open Scope long_path_scope.
    refine (functor_coeq_sect _ _ _ _ _ _ _ _
                              (eisretr h) (eisretr k) _ _); intros b.
    (** The two proofs are identical modulo replacing [f] by [g], [f'] by [g'], and [p] by [q]. *)
    all:rewrite !ap_pp, <- eisadj.
    all:rewrite <- !ap_compose.
    all:rewrite (concat_pA1_p (eisretr k) _ _).
    all:rewrite concat_pV_p.
    all:rewrite <- (ap_compose (k^-1 o _) k).
    all:rewrite (ap_compose _ (k o k^-1)).
    all:rewrite (concat_A1p (eisretr k) (ap _ (eisretr h b)^)).
    all:rewrite ap_V, concat_pV_p; reflexivity.
    Close Scope long_path_scope.
  Qed.

  Definition functor_coeq_eisretr
  : Sect (functor_coeq h k p q) functor_coeq_inverse.
  Proof.
    Open Scope long_path_scope.
    refine (functor_coeq_sect _ _ _ _ _ _ _ _
                              (eissect h) (eissect k) _ _); intros b.
    all:rewrite !concat_p_pp, eisadj, <- ap_V, <- !ap_compose.
    all:rewrite (ap_compose (_ o h) k^-1).
    all:rewrite <- !(ap_pp k^-1), !concat_pp_p.
    1:rewrite (concat_Ap (fun b => (p b)^) (eissect h b)^).
    2:rewrite (concat_Ap (fun b => (q b)^) (eissect h b)^).
    all:rewrite concat_p_Vp, concat_p_pp.
    all:rewrite <- (ap_compose (k o _) k^-1), (ap_compose _ (k^-1 o k)).
    all:rewrite (concat_A1p (eissect k) _).
    all:rewrite ap_V, concat_pV_p; reflexivity.
    Close Scope long_path_scope.
  Qed.

  Global Instance isequiv_functor_coeq
  : IsEquiv (functor_coeq h k p q)
    := isequiv_adjointify _ functor_coeq_inverse
                          functor_coeq_eissect functor_coeq_eisretr.

  Definition equiv_functor_coeq
  : @Coeq B A f g <~> @Coeq B' A' f' g'
    := Build_Equiv _ _ (functor_coeq h k p q) _.

End IsEquivFunctorCoeq.

Definition equiv_functor_coeq' {B A f g B' A' f' g'}
           (h : B <~> B') (k : A <~> A')
           (p : k o f == f' o h) (q : k o g == g' o h)
: @Coeq B A f g <~> @Coeq B' A' f' g'
  := equiv_functor_coeq h k p q.

(** ** A double recursion principle *)

Section CoeqRec2.
  Context `{Funext}
          {B A : Type} {f g : B -> A} {B' A' : Type} {f' g' : B' -> A'}
          (P : Type) (coeq' : A -> A' -> P)
          (cgluel : forall b a', coeq' (f b) a' = coeq' (g b) a')
          (cgluer : forall a b', coeq' a (f' b') = coeq' a (g' b'))
          (cgluelr : forall b b', cgluel b (f' b') @ cgluer (g b) b'
                               = cgluer (f b) b' @ cgluel b (g' b')).

  Definition Coeq_rec2
  : Coeq f g -> Coeq f' g' -> P.
  Proof.
    simple refine (Coeq_rec _ _ _).
    - intros a.
      simple refine (Coeq_rec _ _ _).
      + intros a'.
        exact (coeq' a a').
      + intros b'; cbn.
        apply cgluer.
    - intros b.
      apply path_arrow; intros a.
      revert a; simple refine (Coeq_ind _ _ _).
      + intros a'. cbn.
        apply cgluel.
      + intros b'; cbn.
        refine (transport_paths_FlFr (cglue b') (cgluel b (f' b')) @ _).
        refine (concat_pp_p _ _ _ @ _).
        apply moveR_Vp.
        refine (_ @ cgluelr b b' @ _).
        * apply whiskerL.
          apply Coeq_rec_beta_cglue.
        * apply whiskerR.
          symmetry; apply Coeq_rec_beta_cglue.
  Defined.

  Definition Coeq_rec2_beta (a : A) (a' : A')
  : Coeq_rec2 (coeq a) (coeq a') = coeq' a a'
    := 1.

  Definition Coeq_rec2_beta_cgluel (a : A) (b' : B')
  : ap (Coeq_rec2 (coeq a)) (cglue b') = cgluer a b'.
  Proof.
    apply Coeq_rec_beta_cglue.
  Defined.

  Definition Coeq_rec2_beta_cgluer (b : B) (a' : A')
  : ap (fun x => Coeq_rec2 x (coeq a')) (cglue b) = cgluel b a'.
  Proof.
    transitivity (ap10 (ap Coeq_rec2 (cglue b)) (coeq a')).
    - refine (ap_compose Coeq_rec2 (fun h => h (coeq a')) _ @ _).
      apply ap_apply_l.
    - unfold Coeq_rec2; rewrite Coeq_rec_beta_cglue.
      rewrite ap10_path_arrow.
      reflexivity.
  Defined.

  (** TODO: [Coeq_rec2_beta_cgluelr] *)

End CoeqRec2.

(** ** A double induction principle *)

Section CoeqInd2.
  Context `{Funext}
          {B A : Type} {f g : B -> A} {B' A' : Type} {f' g' : B' -> A'}
          (P : Coeq f g -> Coeq f' g' -> Type)
          (coeq' : forall a a', P (coeq a) (coeq a'))
          (cgluel : forall b a',
                   transport (fun x => P x (coeq a')) (cglue b)
                             (coeq' (f b) a') = coeq' (g b) a')
          (cgluer : forall a b',
                   transport (fun y => P (coeq a) y) (cglue b')
                             (coeq' a (f' b')) = coeq' a (g' b'))
          (** Perhaps this should really be written using [concatD]. *)
          (cgluelr : forall b b',
                  ap (transport (P (coeq (g b))) (cglue b')) (cgluel b (f' b'))
                  @ cgluer (g b) b'
                  = transport_transport P (cglue b) (cglue b') (coeq' (f b) (f' b'))
                  @ ap (transport (fun x => P x (coeq (g' b'))) (cglue b))
                       (cgluer (f b) b')
                  @ cgluel b (g' b')).

  Definition Coeq_ind2
  : forall x y, P x y.
  Proof.
    simple refine (Coeq_ind _ _ _).
    - intros a.
      simple refine (Coeq_ind _ _ _).
      + intros a'.
        exact (coeq' a a').
      + intros b'; cbn.
        apply cgluer.
    - intros b.
      apply path_forall; intros a.
      revert a; simple refine (Coeq_ind _ _ _).
      + intros a'. cbn.
        refine (transport_forall_constant _ _ _ @ _).
        apply cgluel.
      + intros b'; cbn.
        refine (transport_paths_FlFr_D (cglue b') _ @ _).
        rewrite Coeq_ind_beta_cglue.
        (** Now begins the long haul. *)
        Open Scope long_path_scope.
        rewrite ap_pp.
        repeat rewrite concat_p_pp.
        (** Our first order of business is to get rid of the [Coeq_ind]s, which only occur in the following incarnation. *)
        set (G := (Coeq_ind (P (coeq (f b)))
                            (fun a' : A' => coeq' (f b) a')
                            (fun b'0 : B' => cgluer (f b) b'0))).
        (** Let's reduce the [apD (loop # G)] first. *)
        rewrite (apD_transport_forall_constant P (cglue b) G (cglue b')); simpl.
        rewrite !inv_pp, !inv_V.
        (** Now we can cancel a [transport_forall_constant]. *)
        rewrite !concat_pp_p; apply whiskerL.
        (** And a path-inverse pair.  This removes all the [transport_forall_constant]s. *)
        rewrite !concat_p_pp, concat_pV_p.
        (** Now we can beta-reduce the last remaining [G]. *)
        subst G; rewrite Coeq_ind_beta_cglue; simpl.
        (** Now we just have to rearrange it a bit. *)
        rewrite !concat_pp_p; do 2 apply moveR_Vp; rewrite !concat_p_pp.
        apply cgluelr.
        Close Scope long_path_scope.
  Qed.

End CoeqInd2.

(** ** Symmetry *)

Definition Coeq_sym_map {B A} (f g : B -> A) : Coeq f g -> Coeq g f :=
  Coeq_rec (Coeq g f) coeq (fun b : B => (cglue b)^).

Lemma sect_Coeq_sym_map {B A} {f g : B -> A} : Sect (Coeq_sym_map g f) (Coeq_sym_map f g).
Proof.
  unfold Sect. srapply @Coeq_ind.
  - reflexivity.
  - intro b.
    abstract (rewrite transport_paths_FFlr, Coeq_rec_beta_cglue, ap_V, Coeq_rec_beta_cglue; hott_simpl).
Defined.

Lemma Coeq_sym {B A} {f g : B -> A} : @Coeq B A f g <~> Coeq g f.
Proof.
  exact (equiv_adjointify (Coeq_sym_map f g) (Coeq_sym_map g f) sect_Coeq_sym_map sect_Coeq_sym_map).
Defined.


From CE Require Export Helpers.

Import ListNotations.

Definition Environment : Type := list ((Var + FunctionIdentifier) * Value).

Fixpoint count_closures (env : Environment) : nat :=
match env with
| [] => 0
| (_, VClos _ _ _ _ _)::xs => S (count_closures xs)
| _::xs => count_closures xs
end.

(** Get *)
Fixpoint get_value (env : Environment) (key : (Var + FunctionIdentifier))
   : (Value + Exception) :=
match env with
| [ ] => inr novar
| (k,v)::xs => if var_funid_eqb key k then inl v else get_value xs key
end.

(** Insert *)
Fixpoint insert_value (env : Environment) (key : (Var + FunctionIdentifier))
   (value : Value) : Environment :=
match env with
  | [] => [(key, value)]
  | (k,v)::xs => if var_funid_eqb k key then (key,value)::xs else (k,v)::(insert_value xs key value)
end.

(** Add additional bindings *)
(** We used here: when binding, variables must be unique *)
Fixpoint add_bindings (bindings : list (Var * Value)) (env : Environment) : Environment :=
match bindings with
| [] => env
| (v, e)::xs => add_bindings xs (insert_value env (inl v) e)
end.

(** Add bindings with two lists *)
Fixpoint append_vars_to_env (vl : list Var) (el : list Value) (d : Environment)
   : Environment :=
match vl, el with
| [], [] => d
| v::vs, e::es => append_vars_to_env vs es (insert_value d (inl v) e)
| _, _ => []
end.

Definition append_try_vars_to_env (vl : list Var) (el : list Value) (d : Environment)
   : Environment :=
match el with
| [] => []
| e::es =>
if length vl =? 2 then append_vars_to_env vl es d else append_vars_to_env vl el d
end.

(** Not Overwriting insert *)
(** Overwriting does not fit with this recursion *)
Fixpoint insert_function (id : nat) (v : FunctionIdentifier) (p : list Var) (b : Expression)
   (l : list (nat * FunctionIdentifier * FunctionExpression))
    : list (nat * FunctionIdentifier * FunctionExpression) :=
match l with
| [] => [(id, v, (p, b))]
| (id', k, v0)::xs => if funid_eqb k v then (id', k, v0)::xs
                                   else (id', k, v0)::(insert_function id v p b xs)
end.

(** Lists represented functions *)
Fixpoint list_functions (vl : list FunctionIdentifier) (paramss : list (list Var))
      (bodies : list Expression) (last_id : nat)
      : list (nat * FunctionIdentifier * FunctionExpression) :=
match vl, paramss, bodies with
| [], [], [] => []
| v::vs, varl::ps, e::bs => insert_function last_id v varl e
                                 (list_functions vs ps bs (S last_id))
| _, _, _ => []
end.

(** Add functions *)
Fixpoint append_funs_to_env_base (vl : list FunctionIdentifier) (paramss : list (list Var))
      (bodies : list Expression) (d : Environment) (def : Environment)
      (deffuns : list (nat * FunctionIdentifier * FunctionExpression)) (last_id : nat)
      : Environment :=
match vl, paramss, bodies with
| [], [], [] => d
| v::vs, varl::ps, e::bs => append_funs_to_env_base vs ps bs
                              (insert_value d (inr v)
                                           (VClos def deffuns last_id varl e))
                                           def deffuns (S last_id)
| _, _, _ => []
end.

Definition append_funs_to_env (l : list (FunctionIdentifier * ((list Var) * Expression))) (d : Environment) (last_id : nat) : Environment :=
append_funs_to_env_base (fst (split l)) (fst (split (snd (split l)))) (snd (split (snd (split l)))) d d
                       (list_functions (fst (split l)) (fst (split (snd (split l)))) (snd (split (snd (split l)))) last_id)
                       last_id
.

Compute append_funs_to_env [(("f1"%string,0), ([], ErrorExp)) ;
                            (("f2"%string,0), ([], ErrorExp)) ;
                            (("f1"%string,0), ([], ErrorExp)) ]
                           [(inl "X"%string, ErrorValue)] 0.

Compute insert_function 2 ("f1"%string, 0) [] ErrorExp (list_functions
                              [("f1"%string,0); ("f2"%string,0); ("f1"%string, 0)]
                              [[];[];[]]
                              [ErrorExp; ErrorExp; ErrorExp] 0).

(** Environment construction from the extension and the reference *)
Fixpoint get_env_base (env def : Environment)
   (ext defext : list (nat * FunctionIdentifier * FunctionExpression))
   : Environment :=
match ext with
| [] => env
| (id, f1, (pl, b))::xs => get_env_base (insert_value env (inr f1) (VClos def defext id pl b)) def xs defext
end.

Definition get_env (env : Environment)
   (ext : list (nat * FunctionIdentifier * FunctionExpression))
   : Environment :=
  get_env_base env env ext ext
.

Inductive SideEffectId : Set :=
| Input
| Output
.

Definition SideEffectList : Type := list (SideEffectId * list Value).

Definition nth_def {A : Type} (l : list A) (def err : A) (i : nat) :=
match i with
| 0 => def
| S i' => nth i' l err
end.

Lemma nth_def_eq {A : Type} (l : list A) (i : nat) (e1 def err : A):
  nth_def (e1::l) def err (S i) = nth_def l e1 err i.
Proof.
  simpl. destruct i.
  * simpl. reflexivity.
  * simpl. reflexivity.
Qed.

Theorem last_nth_equal {A : Type} (l : list A) (def err : A) :
  last l def = nth_def l def err (length l).
Proof.
  induction l.
  * auto.
  * simpl. rewrite IHl. destruct l.
    - auto.
    - simpl. auto.
Qed.

Proposition get_value_here (env : Environment) (var : Var + FunctionIdentifier) (val : Value):
get_value (insert_value env var val) var = inl val.
Proof.
  induction env.
  * simpl. rewrite uequal_refl. reflexivity.
  * simpl. destruct a. case_eq (var_funid_eqb s var); intro.
    - simpl. rewrite uequal_refl. reflexivity.
    - simpl. rewrite uequal_sym, H. assumption.
Qed.

(** Previous append result *)
Proposition get_value_there (env : Environment) (var var' : Var + FunctionIdentifier)
     (val : Value):
var <> var' ->
get_value (insert_value env var val) var' = get_value env var'.
Proof.
  intro. induction env.
  * simpl. apply uequal_neq in H. rewrite uequal_sym in H. rewrite H. reflexivity.
  * simpl. destruct a. case_eq (var_funid_eqb s var); intro.
    - apply uequal_eq in H0. assert (var <> var'). auto. rewrite <- H0 in H.
      apply uequal_neq in H. rewrite uequal_sym in H. rewrite H. simpl. apply uequal_neq in H1.
      rewrite uequal_sym in H1. rewrite H1. reflexivity.
    - simpl. case_eq (var_funid_eqb var' s); intros.
      + reflexivity.
      + apply IHenv.
Qed.


(* Adapted with minimal modifications from Hoare Logic, Part I
   (Hoare) of Programming Language Foundations:
   https://softwarefoundations.cis.upenn.edu/plf-current/Hoare.html *)

From Coq Require Import Strings.String Program.Equality.
From LongDivision Require Import Maps Imp.

(* Core definitions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P '->>' Q" := (assert_implies P Q) (at level 80) :
  hoare_spec_scope.

Open Scope hoare_spec_scope.

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion)
  : Prop := forall st st', P st -> st =[ c ]=> st' -> Q st'.

Notation "'{{' P '}}' c '{{' Q '}}'" := (hoare_triple P c Q)
  (at level 90, c at next level) : hoare_spec_scope.

(* Proof rules *)

Ltac inv H := inversion H; subst; clear H.

Theorem hoare_floyd : forall P x a,
  {{ P }} x ::= a {{ fun st => exists st',
  (forall y, x <> y -> st y = st' y) /\
  st x = aeval st' a /\
  P st' }}.
Proof with auto.
  unfold hoare_triple; intros; inv H0; unfold t_update.
  exists st; repeat split...
  - intros; destruct (string_dec x y)...
    contradiction H0.
  - destruct (string_dec x x)...
    now contradiction n.
Qed.

Theorem hoare_consequence : forall P P' Q Q' c,
  P ->> P' ->
  {{ P' }} c {{ Q' }} ->
  Q' ->> Q ->
  {{ P }} c {{ Q }}.
Proof. unfold hoare_triple; eauto. Qed.

Theorem hoare_skip : forall P, {{ P }} SKIP {{ P }}.
Proof. unfold hoare_triple; intros; now inv H0. Qed.

Theorem hoare_seq : forall P Q R c1 c2,
  {{ P }} c1 {{ Q }} ->
  {{ Q }} c2 {{ R }} ->
  {{ P }} c1 ;; c2 {{ R }}.
Proof. unfold hoare_triple; intros; inv H2; eauto. Qed.

Theorem hoare_if : forall P Q b c1 c2,
  {{ fun st => P st /\ beval st b = true }} c1 {{ Q }} ->
  {{ fun st => P st /\ beval st b = false }} c2 {{ Q }} ->
  {{ P }} TEST b THEN c1 ELSE c2 FI {{ Q }}.
Proof. unfold hoare_triple; intros; inv H2; eauto. Qed.

Theorem hoare_while : forall P b c',
  {{ fun st => P st /\ beval st b = true }} c' {{ P }} ->
  {{ P }} WHILE b DO c' END {{ fun st => P st /\
  beval st b = false }}.
Proof.
  unfold hoare_triple; intros; dependent induction H1; eauto.
Qed.

Close Scope hoare_spec_scope.


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

Require Import Cava.Cava.

(****************************************************************************)
(* A few tests to check the unsigned adder.        *)
(****************************************************************************)

Definition v17  := N2Bv_sized 8 17.
Definition v52  := N2Bv_sized 8 52.
Definition v69  := N2Bv_sized 8 69.
Definition v70  := N2Bv_sized 8 70.
Definition v1   := N2Bv_sized 8 1.
Definition v255 := N2Bv_sized 8 255.
Definition v0   := N2Bv_sized 8 0.
Definition v200 := N2Bv_sized 8 200.
Definition v100 := N2Bv_sized 8 100.
Definition v44  := N2Bv_sized 8 44.

(* Perform a few basic checks to make sure the adder works. *)

Example xadd_17_52_0 : xilinxAdderWithCarry (v17, v52, false) =
                       (v69, false).
Proof. reflexivity. Qed.

Example xadd_17_52_1 : xilinxAdderWithCarry (v17, v52, true) =
                       (v70, false).
Proof. reflexivity. Qed.

Example xadd_1_255_1 : xilinxAdderWithCarry (v1, v255, false) =
                       (v0, true).
Proof. reflexivity. Qed.

Example xadd_0_255_1 : xilinxAdderWithCarry (v0, v255, true) =
                       (v0, true).
Proof. reflexivity. Qed.

Example xadd_200_100_0 : xilinxAdderWithCarry (v200, v100, false) =
                         (v44, true).
Proof. reflexivity. Qed.

(****************************************************************************)
(* A module definition for an 8-bit adder for SystemVerilog netlist         *)
(* generation.                                                              *)
(****************************************************************************)

Definition adder8Interface
  := combinationalInterface "adder8"
     [mkPort "a" (Vec Bit 8); mkPort "b" (Vec Bit 8); mkPort "cin" Bit]
     [mkPort "sum" (Vec Bit 8); mkPort "cout" Bit].

Definition adder8Netlist
  := makeNetlist adder8Interface xilinxAdderWithCarry.

Local Open Scope N_scope.

Definition adder8_tb_inputs :=
  map (fun '(a, b, cin)
       => (N2Bv_sized 8 a, N2Bv_sized 8 b, n2bool cin))
  [(7, 3, 0);
   (115, 67, 1);
   (92, 18, 0);
   (50, 200, 0);
   (255, 255, 0);
   (255, 255, 1)].

Definition adder8_tb_expected_outputs :=
  simulate (Comb xilinxAdderWithCarry) adder8_tb_inputs.

Definition adder8_tb :=
  testBench "adder8_tb" adder8Interface
  adder8_tb_inputs adder8_tb_expected_outputs.


(* 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 Coq Require Export Arith.
From Coq Require Export Compare_dec.
From Coq Require Export ArithRing.
From Coq Require Export Lia.
From Coq Require Export ZArith.
From Coq Require Export ZArithRing.

Ltac CaseEq f := generalize (refl_equal f); pattern f at -1 in |- *; case f.

Inductive Qpositive : Set :=
  | nR : Qpositive -> Qpositive
  | dL : Qpositive -> Qpositive
  | One : Qpositive.

Fixpoint Qpositive_i (w : Qpositive) : nat * nat :=
  match w with
  | One => (1, 1)
  | nR w' => match Qpositive_i w' with
             | (p, q) => (p + q, q)
             end
  | dL w' => match Qpositive_i w' with
             | (p, q) => (p, p + q)
             end
  end.
Coercion Z_of_nat : nat >-> Z.

Theorem interp_reduced_fraction :
 forall w : Qpositive,
 exists a : Z,
   (exists b : Z, (a * fst (Qpositive_i w) + b * snd (Qpositive_i w))%Z = 1%Z).
intros w; elim w; clear w.
intros w Hrec; elim Hrec; intros a Hrec2; elim Hrec2; intros b; simpl in |- *;
 case (Qpositive_i w); simpl in |- *.
intros p q Heq; exists a; exists (b - a)%Z.
rewrite <- Heq; repeat rewrite Znat.inj_plus; ring.
intros w Hrec; elim Hrec; intros a Hrec2; elim Hrec2; intros b; simpl in |- *;
 case (Qpositive_i w); simpl in |- *.
intros p q Heq; exists (a - b)%Z; exists b.
rewrite <- Heq; repeat rewrite Znat.inj_plus; ring.
exists 1%Z; exists 0%Z; simpl in |- *; lia.
Qed.

Fixpoint Qpositive_inv (w : Qpositive) : Qpositive :=
  match w with
  | One => One
  | nR w' => dL (Qpositive_inv w')
  | dL w' => nR (Qpositive_inv w')
  end.

Theorem inv_correct :
 forall (w : Qpositive) (p q : nat),
 Qpositive_i w = (p, q) -> Qpositive_i (Qpositive_inv w) = (q, p).
 let T_local :=
  (intros w'; simpl in |- *; case (Qpositive_i w'); intros p' q' Hrec p q Heq;
    rewrite (Hrec p' q'); auto; injection Heq; intros H1 H2;
    rewrite <- H1; rewrite <- H2; rewrite Nat.add_comm;
    auto) in
 (intros w; elim w; clear w;
   [ T_local
   | T_local
   | simpl in |- *; intros p q Heq; injection Heq; intros H1 H2;
      rewrite <- H1; rewrite <- H2; auto with * ]).
Qed.

Theorem interp_non_zero :
 forall w : Qpositive,
 exists p : nat, (exists q : nat, Qpositive_i w = (S p, S q)).
simple induction w; simpl in |- *;
 (repeat exists 0; auto; fail) ||
   (intros w' Hrec; elim Hrec; intros p' Hex; elim Hex; intros q' Heq;
     rewrite Heq).
exists (p' + S q'); exists q'; auto.
exists p'; exists (p' + S q'); auto.
Qed.

Fixpoint Qpositive_c (p q n : nat) {struct n} : Qpositive :=
  match n with
  | O => One
  | S n' =>
      match p - q with
      | O => match q - p with
             | O => One
             | v => dL (Qpositive_c p v n')
             end
      | v => nR (Qpositive_c v q n')
      end
  end.

Theorem minus_O_le : forall n m : nat, n - m = 0 -> n <= m.
intros n; elim n; clear n.
auto with arith.
intros n Hrec m; case m; clear m.
simpl in |- *; intros Heq; discriminate Heq.
simpl in |- *; intros; apply le_n_S; apply Hrec; auto.
Qed.

Theorem le_minus_O : forall n m : nat, n <= m -> n - m = 0.
intros n; elim n; clear n.
simpl in |- *; auto.
intros n Hrec m; case m; clear m.
intros Hle; inversion Hle.
intros m' Hle; simpl in |- *; apply Hrec; auto with arith.
Qed.

Theorem minus_le : forall m n : nat, m - n <= m.
intros m; elim m.
simpl in |- *; auto.
intros m' Hrec n; case n; simpl in |- *; auto.
Qed.

Theorem mult_reg_l : forall n m p : nat, S n * m = S n * p -> m = p.
intros n m; elim m; clear m.
intros p; case p; simpl in |- *.
auto.
intros p'; rewrite <- mult_n_O.
intros H; discriminate H.
intros m' Hrec p; case p.
rewrite <- mult_n_O; simpl in |- *; intros H; discriminate H.
intros p'; repeat rewrite (Nat.mul_comm (S n)); simpl in |- *.
intros H; injection H.
intros H'; apply f_equal with (f := S).
apply Hrec.
repeat rewrite (Nat.mul_comm (S n)).
apply Nat.add_cancel_l with n.
exact H'.
Qed.

Theorem absolu_inj_nat : forall x : nat, Z.abs_nat (Z_of_nat x) = x.
intros x; case x.
auto.
simpl in |- *.
exact nat_of_P_o_P_of_succ_nat_eq_succ.
Qed.

Theorem absolu_mult :
 forall x y : Z, Z.abs_nat (x * y) = Z.abs_nat x * Z.abs_nat y.
intros x; case x; auto; intros p y; case y; auto; simpl in |- *; intros;
 apply nat_of_P_mult_morphism.
Qed.

Theorem Qpositive_c_unfold1 :
 forall p q n : nat,
 S p + S q + S q <= S n ->
 Qpositive_c (S p + S q) (S q) (S n) = nR (Qpositive_c (S p) (S q) n).
intros p q n Hle; simpl in |- *.
rewrite <- (plus_n_Sm p q).
rewrite Nat.sub_succ_l.
rewrite Nat.add_sub; auto with *.
auto with arith.
Qed.

Theorem Qpositive_c_unfold2 :
 forall p q n : nat,
 S p + (S p + S q) <= S n ->
 Qpositive_c (S p) (S p + S q) (S n) = dL (Qpositive_c (S p) (S q) n).
intros p q n Hle; simpl in |- *.
rewrite le_minus_O.
rewrite Nat.add_comm.
rewrite Nat.add_sub.
auto.
auto with arith.
Qed.

Theorem construct_correct :
 forall (w : Qpositive) (p q n : nat),
 Qpositive_i w = (p, q) -> p + q <= n -> Qpositive_c p q n = w.
intros w; elim w; clear w.
intros w'; simpl in |- *.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq.
rewrite Heq.
intros Hrec p q n Heq_pair.
injection Heq_pair; intros Heq2 Heq1; rewrite <- Heq2; rewrite <- Heq1.
case n.
simpl in |- *; intros Hle; inversion Hle.
clear n; intros n.
intros Hle.
 replace (Qpositive_c (S (p' + S q')) (S q') (S n)) with
  (nR (Qpositive_c (S p') (S q') n)).
apply f_equal with (f := nR).
apply Hrec; auto with *.
rewrite <- plus_Sn_m.
rewrite Qpositive_c_unfold1. auto with *.
auto with *.
intros w'; simpl in |- *.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq.
rewrite Heq.
intros Hrec p q n Heq_pair.
injection Heq_pair; intros Heq2 Heq1; rewrite <- Heq2; rewrite <- Heq1.
case n.
simpl in |- *; intros Hle; inversion Hle.
clear n; intros n.
intros Hle.
 replace (Qpositive_c (S p') (S (p' + S q')) (S n)) with
  (dL (Qpositive_c (S p') (S q') n)).
apply f_equal with (f := dL).
apply Hrec; auto with *.
rewrite <- plus_Sn_m.
rewrite Qpositive_c_unfold2; auto with *.

simpl in |- *; intros p q n Heq; injection Heq; intros Heq2 Heq1; case n.
rewrite <- Heq1; simpl in |- *; intros Hle; inversion Hle.
rewrite <- Heq1; rewrite <- Heq2; simpl in |- *; auto with *.

Qed.

Theorem construct_correct2 :
 forall n p q : nat,
 S p + S q <= n ->
 exists d : nat,
   S p = fst (Qpositive_i (Qpositive_c (S p) (S q) n)) * S d /\
   S q = snd (Qpositive_i (Qpositive_c (S p) (S q) n)) * S d.
intros n; elim n.
intros p q Hle; inversion Hle.
clear n; intros n.
intros Hrec p q Hle; case (le_gt_dec (S p) (S q)).
simpl in |- *.
intros Hle'; rewrite (le_minus_O p q).
CaseEq (q - p).
intros Heq_minus; exists p.
simpl in |- *; split; auto with arith.
rewrite <- plus_n_O.
apply Nat.le_antisymm; auto with arith.
apply minus_O_le.
auto.
intros q' Heq_minus; elim (Hrec p q').
intros d; simpl in |- *; case (Qpositive_i (Qpositive_c (S p) (S q') n));
 repeat rewrite <- (Nat.mul_comm (S d)); intros p'' q'' (Heq1, Heq2).
exists d; split.
exact Heq1.
rewrite <- (Nat.sub_add (S p) (S q)).
simpl in |- *.
rewrite Heq_minus; rewrite Heq2.
simpl in |- *.
replace (S (p + q'' * S d)) with (S p + q'' * S d).
rewrite Heq1.
simpl in |- *.
ring.
simpl in |- *; auto.
auto with arith.
apply le_S_n.
rewrite plus_n_Sm.
apply Nat.le_trans with (S p + S q).
apply Nat.add_le_mono_l.
apply le_n_S.
rewrite <- Heq_minus; apply minus_le.
exact Hle.
auto with arith.
intros Hgt; simpl in |- *; CaseEq (p - q).
intros H; apply Nat.lt_nge in Hgt.
contradict Hgt.
apply le_n_S.
apply minus_O_le.
exact H.
intros p'.
intros Heq_minus; simpl in |- *; elim (Hrec p' q).
intros d; case (Qpositive_i (Qpositive_c (S p') (S q) n)).
simpl in |- *; intros p'' q'' (Heq1, Heq2).
exists d; split; auto.
rewrite <- (Nat.sub_add (S q) (S p)); simpl in |- *.
rewrite Heq_minus.
replace (S (q + S p')) with (S q + S p').
rewrite Heq2; rewrite Heq1; ring.
simpl in |- *; auto.
auto with arith.
rewrite <- Heq_minus.
replace (p - q) with (S p - S q).
rewrite (Nat.sub_add (S q) (S p)).
apply Nat.le_trans with (S p + q).
auto with arith.
apply le_S_n; rewrite plus_n_Sm.
exact Hle.
auto with arith.
auto.
Qed.

Theorem construct_correct2' :
 forall n p q : nat,
 1 <= p ->
 1 <= q ->
 p + q <= n ->
 exists d : nat,
   p = fst (Qpositive_i (Qpositive_c p q n)) * S d /\
   q = snd (Qpositive_i (Qpositive_c p q n)) * S d.
intros n p; case p.
intros q H; inversion H.
intros p' q; case q.
intros Hle H; inversion H.
intros q' Hle Hle2; exact (construct_correct2 n p' q').
Qed.

Theorem construct_correct3 :
 forall n n' p q p' q' d : nat,
 S p = S d * p' ->
 S q = S d * q' ->
 S p + S q <= S n ->
 p' + q' <= S n' -> Qpositive_c (S p) (S q) (S n) = Qpositive_c p' q' (S n').
intros n; elim n; clear n.
intros n' p q p' q' d; rewrite <- plus_n_Sm.
simpl in |- *.
intros H1 H2 H3; inversion H3.
inversion H0.
intros n0 Hrec n' p q p' q' d Heqd1 Heqd2 Hle1 Hle2.
simpl in |- *.
CaseEq (p - q).
CaseEq (q - p).
intros H H0.
cut (p' = q').
intros Heq'; rewrite Heq'; rewrite (Nat.sub_diag q').
auto.
apply mult_reg_l with d.
rewrite <- Heqd2; rewrite <- Heqd1.
apply Nat.le_antisymm; apply minus_O_le; assumption.
intros q2 Heq2 Heqp.
cut (p' <= q').
intros H; generalize (le_minus_O _ _ H).
intros Heq3; rewrite Heq3.
CaseEq (q' - p').
intros Heq4; cut (q' = p').
intros Heq5; generalize Heq2; replace (q - p) with (S q - S p).
rewrite Heqd2; rewrite Heqd1; rewrite Heq5.
rewrite Nat.sub_diag; intros Heq6; discriminate Heq6.
auto.
apply Nat.le_antisymm; apply minus_O_le; assumption.
intros q'2.
generalize Hle2; case n'.
generalize Heqd1 Heqd2; case p'; case q'.
simpl in |- *; intros H'1 H'2 H'3 H'4; discriminate H'4.
intros x; rewrite <- (Nat.mul_comm 0); simpl in |- *; intros Dummy;
 discriminate Dummy.
simpl in |- *; intros x H'1 H'2 H'3 H'4; discriminate H'4.
simpl in |- *; intros n n1 H'1 H'2; rewrite <- plus_n_Sm; intros H'3;
 inversion H'3.
inversion H1.
intros n''.
intros Hle3 Heq4.
simpl in |- *.
CaseEq p'.
intros Heqp'; generalize Heqd1; rewrite Heqp'.
rewrite <- (Nat.mul_comm 0); simpl in |- *; intros Dummy; discriminate Dummy.
intros p'2 Heqp'2.
change
  (dL (Qpositive_c (S p) (S q2) (S n0)) =
   dL (Qpositive_c (S p'2) (S q'2) (S n''))) in |- *.
apply f_equal with (f := dL).
apply Hrec with d.
- rewrite <- Heqp'2; assumption.
- rewrite <- Heq4; rewrite <- Heq2; rewrite (Nat.mul_comm (S d)).
  rewrite Nat.mul_sub_distr_r.
  repeat rewrite <- (Nat.mul_comm (S d)).
  rewrite <- Heqd2; rewrite <- Heqd1.
  simpl in |- *; auto.
- auto with zarith.
- auto with zarith.
- apply Nat.mul_le_mono_pos_l with (S d); auto with arith.
  rewrite <- Heqd2; rewrite <- Heqd1.
  apply le_n_S.
  apply minus_O_le; assumption.
- intros p2 Heqp2.
  CaseEq (p' - q').
  intros Heqm'; cut (S p - S q = 0).
  simpl in |- *; rewrite Heqp2; intros Dummy; discriminate Dummy.
  rewrite Heqd2; rewrite Heqd1.
  repeat rewrite (Nat.mul_comm (S d)).
  rewrite <- Nat.mul_sub_distr_r.
  rewrite Heqm'; simpl in |- *; auto.
  intros p'2.
  generalize Hle2; case n'.
  generalize Heqd1 Heqd2; case p'; case q'.
  simpl in |- *; intros H'1 H'2 H'3 H'4; discriminate H'4.
  intros x; rewrite <- (Nat.mul_comm 0); simpl in |- *; intros Dummy;
   discriminate Dummy.
  intros x; rewrite <- (Nat.mul_comm 0); simpl in |- *; intros Dummy1 Dummy2;
   discriminate Dummy2.
  simpl in |- *; intros n n1 H'1 H'2; rewrite <- plus_n_Sm; intros H'3;
   inversion H'3.
  inversion H0.
  intros n''.
  intros Hle3 Heq4.
  CaseEq q'.
  intros Heq5; generalize Heqd2; rewrite Heq5; simpl in |- *.
  rewrite <- (Nat.mul_comm 0); simpl in |- *; intros Dummy; discriminate Dummy.
  intros q'2 Heqq'2.
  change
    (nR (Qpositive_c (S p2) (S q) (S n0)) =
     nR (Qpositive_c (S p'2) (S q'2) (S n''))) in |- *.
  apply f_equal with (f := nR).
  apply Hrec with d.
  * rewrite <- Heq4; rewrite <- Heqp2; rewrite (Nat.mul_comm (S d)).
    rewrite Nat.mul_sub_distr_r.
    repeat rewrite <- (Nat.mul_comm (S d)).
    rewrite <- Heqd2; rewrite <- Heqd1.
    simpl in |- *; auto.
  * rewrite <- Heqq'2; assumption.
  * auto with zarith.
  * auto with zarith.
Qed.

Theorem construct_correct4 :
 forall p q p' q' n n' : nat,
 S p + S q <= S n ->
 S p' + S q' <= S n' ->
 S p * S q' = S p' * S q ->
 Qpositive_c (S p) (S q) (S n) = Qpositive_c (S p') (S q') (S n').
intros p q p' q' n n' H H0 H1.
elim (construct_correct2 _ _ _ H).
intros d (Heq1, Heq2).
elim (construct_correct2 _ _ _ H0).
intros d' (Heq3, Heq4).
elim (interp_non_zero (Qpositive_c (S p) (S q) (S n))).
intros p0 Hex1; elim Hex1; intros q0 Heq5; clear Hex1.
elim (interp_non_zero (Qpositive_c (S p') (S q') (S n'))).
intros p'0 Hex1; elim Hex1; intros q'0 Heq6; clear Hex1.
elim (interp_reduced_fraction (Qpositive_c (S p) (S q) (S n))); intros a Hex1;
 elim Hex1; intros b; clear Hex1.
rewrite Heq6 in Heq4; rewrite Heq6 in Heq3; rewrite Heq5 in Heq2;
 rewrite Heq5 in Heq1; rewrite Heq5; unfold fst, snd in |- *;
 intros Heq7.
generalize H1; rewrite Heq1; rewrite Heq2; rewrite Heq3; rewrite Heq4;
 unfold fst, snd in |- *; clear H1; intros H1.
unfold fst, snd in Heq1, Heq2, Heq3, Heq4.
cut (S p0 * S q'0 = S p'0 * S q0).
intros Heq8.
cut (S p'0 = Z.abs_nat (a * S p'0 + b * S q'0) * S p0).
intros Heq9.
cut (S q'0 = Z.abs_nat (a * S p'0 + b * S q'0) * S q0).
intros Heq10.
cut (exists d'' : nat, Z.abs_nat (a * S p'0 + b * S q'0) = S d'').
intros Hex; elim Hex; intros d'' Heq11; rewrite Heq11 in Heq9;
 rewrite Heq11 in Heq10.
replace (S p0 * S d) with (S (d + p0 * S d)).
replace (S q0 * S d) with (S (d + q0 * S d)).
rewrite
 (construct_correct3 n n (d + p0 * S d) (d + q0 * S d) (S p0) (S q0) d).
replace (S p'0 * S d') with (S (d' + p'0 * S d')).
replace (S q'0 * S d') with (S (d' + q'0 * S d')).
symmetry  in |- *.
apply construct_correct3 with (d := d' + d'' * S d').
replace (S (d' + p'0 * S d')) with (S p'0 * S d').
rewrite Heq9; ring.
auto.
replace (S (d' + q'0 * S d')) with (S q'0 * S d').
rewrite Heq10; ring.
auto.
replace (S (d' + q'0 * S d')) with (S q'0 * S d').
replace (S (d' + p'0 * S d')) with (S p'0 * S d').
rewrite <- Heq3; rewrite <- Heq4.
exact H0.
auto.
auto.
apply Nat.le_trans with (S p + S q).
rewrite Heq1; rewrite Heq2.
rewrite <- Nat.mul_add_distr_r.
rewrite Nat.mul_comm; simpl in |- *; auto with arith.
assumption.
auto.
auto.
rewrite (Nat.mul_comm (S d)); auto.
rewrite (Nat.mul_comm (S d)); auto.
replace (S (d + q0 * S d)) with (S q0 * S d).
replace (S (d + p0 * S d)) with (S p0 * S d).
rewrite <- Heq1; rewrite <- Heq2.
exact H.
auto.
auto.
apply Nat.le_trans with (S p + S q).
rewrite Heq1; rewrite Heq2.
rewrite <- Nat.mul_add_distr_r.
rewrite Nat.mul_comm; simpl in |- *; auto with arith.
assumption.
auto.
auto.
CaseEq (Z.abs_nat (a * S p'0 + b * S q'0)).
intros Dummy; rewrite Dummy in Heq10; simpl in Heq10; discriminate Heq10.
intros d'' Heq; exists d''; auto.
rewrite <- (absolu_inj_nat (S q0)).
pattern (S q'0) at 1 in |- *; rewrite <- (absolu_inj_nat (S q'0)).
rewrite <- absolu_mult.
apply f_equal with (f := Z.abs_nat).
pattern (Z_of_nat (S q'0)) at 1 in |- *; rewrite <- Zmult_1_r.
rewrite <- Heq7.
replace (S q'0 * (a * S p0 + b * S q0))%Z with
 (S p0 * S q'0 * a + S q'0 * (b * S q0))%Z.
rewrite <- (Znat.inj_mult (S p0)).
rewrite Heq8.
rewrite Znat.inj_mult; ring.
ring.
rewrite <- (absolu_inj_nat (S p0)).
pattern (S p'0) at 1 in |- *; rewrite <- absolu_inj_nat.
rewrite <- absolu_mult.
apply f_equal with (f := Z.abs_nat).
pattern (Z_of_nat (S p'0)) at 1 in |- *; rewrite <- Zmult_1_r.
rewrite <- Heq7.
replace (S p'0 * (a * S p0 + b * S q0))%Z with
 (S p'0 * S q0 * b + S p'0 * (a * S p0))%Z.
rewrite <- (Znat.inj_mult (S p'0)).
rewrite <- Heq8.
rewrite Znat.inj_mult; ring.
ring.
apply mult_reg_l with (d' + d * S d').
replace (S (d' + d * S d')) with (S d * S d').
transitivity (S p0 * S d * (S q'0 * S d')).
ring.
rewrite H1.
ring.
auto.
Qed.

Theorem construct_correct4' :
 forall p q p' q' n n' : nat,
 1 <= p ->
 1 <= q ->
 1 <= p' ->
 1 <= q' ->
 p + q <= n ->
 p' + q' <= n' -> p * q' = p' * q -> Qpositive_c p q n = Qpositive_c p' q' n'.
intros p; case p.
intros q p' q' n n' H; inversion H.
intros p0 q; case q.
intros p' q' n n' H H1; inversion H1.
intros q0 p'; case p'.
intros q' n n' H H1 H2; inversion H2.
intros p'0 q'; case q'.
intros n n' H H1 H2 H3; inversion H3.
intros q'0 n; case n.
simpl in |- *; intros n' H H1 H2 H3 H4; inversion H4.
intros n0 n'; case n'.
simpl in |- *; intros H H1 H2 H3 H4 H5; inversion H5.
intros; apply construct_correct4; auto.
Qed.

Theorem interp_inject :
 forall w w' : Qpositive, Qpositive_i w = Qpositive_i w' -> w = w'.
intros w w' H; CaseEq (Qpositive_i w).
intros p q Heq.
rewrite <- construct_correct with (1 := Heq) (n := p + q).
apply construct_correct; auto.
rewrite <- H; auto.
auto.
Qed.

Theorem minus_decompose :
 forall a b c d : nat, a = b -> c = d -> a - c = b - d.
intros a b c d H H1; rewrite H; rewrite H1; auto.
Qed.

Theorem Qpositive_c_equiv :
 forall n p q n' p' q' : nat,
 S p + S q <= n ->
 S p' + S q' <= n' ->
 Qpositive_c (S p) (S q) n = Qpositive_c (S p') (S q') n' ->
 S p * S q' = S p' * S q.
intros n; elim n.
simpl in |- *; intros p q n' p' q' H; inversion H.
intros n0 Hrec p q n'.
case n'.
simpl in |- *; intros p' q' H H1; inversion H1.
unfold Qpositive_c in |- *.
CaseEq (S p - S q).
CaseEq (S q - S p).
intros Heq1 Heq2 n1 p' q'; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros Heq3 Heq4; cut (p = q).
intros Heq5; rewrite Heq5.
cut (p' = q').
intros Heq6; rewrite Heq6.
intros; apply Nat.mul_comm.
apply eq_add_S; apply Nat.le_antisymm; apply minus_O_le; auto with *.
apply eq_add_S; apply Nat.le_antisymm; apply minus_O_le; auto with *.
intros p2 H H1 H2 H3 H4; discriminate H4.
intros n2 H H1 H2 H4; discriminate H4.
intros q2 Heq1 Heq2 n2 p' q'; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros H3 H4 H H1 H2; discriminate H2.
intros q'2 H H1 H2 H3 H4; injection H4; intros H5.
rewrite <- (Nat.sub_add (S p) (S q)).
rewrite Nat.add_comm.
rewrite <- (Nat.sub_add (S p') (S q')).
rewrite Nat.add_comm.
rewrite (Nat.mul_comm (S p)); rewrite (Nat.mul_comm (S p')).
repeat rewrite Nat.mul_add_distr_r; repeat rewrite <- (Nat.mul_comm (S p)).
apply f_equal with (f := fun x : nat => S p * S p' + x).
rewrite Heq1; rewrite H.
rewrite <- (Nat.mul_comm (S p')).
apply Hrec with n2.
rewrite <- Heq1.
rewrite Nat.add_comm.
rewrite Nat.sub_add.
apply Nat.le_trans with (p + S q).
auto with arith.
apply le_S_n; exact H2.
apply minus_O_le; auto.
rewrite <- H.
rewrite Nat.add_comm.
rewrite Nat.sub_add.
apply Nat.le_trans with (p' + S q').
auto with arith; fail.
apply le_S_n; exact H3.
apply minus_O_le; auto.
exact H5.
apply minus_O_le; auto.
apply minus_O_le; auto.
intros n1 dummy1 Dummy2 Dummy3 Dummy; discriminate Dummy.
intros n1 Heq1 n2 p' q' Hle1 Hle2; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros Dummy3 Dummy1 Dummy2; discriminate Dummy2.
intros n3 Dummy Dummy1 Dummy2; discriminate Dummy2.
intros p'2 Heq2 Heq3.
injection Heq3; clear Heq3; intros Heq3.
rewrite <- (Nat.sub_add (S q) (S p)).
rewrite Nat.add_comm.
rewrite Heq1.
rewrite <- (Nat.sub_add (S q') (S p')).
rewrite <- (Nat.add_comm (S q')).
rewrite Heq2.
repeat rewrite Nat.mul_add_distr_r; repeat rewrite (Nat.mul_comm (S q')).
apply f_equal with (f := fun x : nat => S q * S q' + x).
apply Hrec with n2.
rewrite Nat.add_comm; rewrite <- Heq1.
rewrite Nat.add_comm.
rewrite Nat.sub_add.
apply Nat.le_trans with (p + S q).
rewrite <- plus_n_Sm.
auto with arith.
apply le_S_n; assumption.
lia.
rewrite <- Heq2.
rewrite Nat.sub_add.
apply Nat.le_trans with (p' + S q').
rewrite <- plus_n_Sm; auto with arith.
apply le_S_n; exact Hle2.
lia.
exact Heq3.
lia.
lia.
Qed.

Theorem Qpositive_c_equiv' :
 forall n p q n' p' q' : nat,
 1 <= p ->
 1 <= q ->
 1 <= p' ->
 1 <= q' ->
 p + q <= n ->
 p' + q' <= n' -> Qpositive_c p q n = Qpositive_c p' q' n' -> p * q' = p' * q.
intros n p q n' p' q'; case p.
intros H; inversion H.
clear p; intros p Hlp.
case q; [ intros H; inversion H | clear q; intros q Dummy; clear Dummy ].
case p'; [ intros H; inversion H | clear p'; intros p' Dummy; clear Dummy ].
case q'; [ intros H; inversion H | clear q'; intros q' Dummy; clear Dummy ].
intros; apply Qpositive_c_equiv with n n'; auto.
Qed.


Require Import Extractions.
Require Import syntax lang Integers.
Open Scope hdl_type_scope.
Open Scope hdl_exp_scope.
Open Scope hdl_stmt_scope.

Definition shiftsAndBitStuff : prog :=
  Local vec "h0" ::== Int.repr 100;;;
        Input vec "sdf" ::== Int.zero;;;
        Output vec "s" ::== Int.zero;;;
        "h0" <= (EVar "h0") rightshift (EVal (Int.repr 3));;;
       "s" <= (EVar "h0") rightrotate (EVal (Int.repr 3));;;
       "s" <= (EVar "h0") and (EVar "s");;;
       "s" <= (EVar "h0") xor (EVar "s");;;
       "s" <= (EVar "h0") plus (EVar "s");;;
       "s" <= not (EVar "s");;;
       "s" ::= not (EVal Int.zero);;;
        done.

Definition print_shifts : verilog :=
  pretty_print_tb_results "shiftsAndBitStuff" "Some shifts" shiftsAndBitStuff.
(* Definition loop_print : verilog :=  *)
(*   pretty_print "looper" loop. *)

Extract Constant main => "Prelude.putStrLn print_shifts".

Extraction "shifts.hs" print_shifts main.

Program Definition array : prog :=
  Input arr "w" <<<(tarr 64 <<<tvec32>>>), 64>>>;;;
  Output arr "m" <<<(tarr 64 <<<tvec32>>>), 64>>>;;;
  iter 0 64 (fun i => "m"@'i <- "w"[[i]]);;;
  done.
Next Obligation.
apply 64.
Defined.
Next Obligation.
  unfold array_obligation_1.
  destruct (Fin.to_nat i).
  auto.
Defined.
Definition print_array : verilog :=
  pretty_print_tb "array" array.

Extract Constant main => "Prelude.putStrLn print_array".

Extraction "array.hs" print_array main.