Require Import Coq.Sets.Ensembles.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Equivalence.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.ModalLogic.Model.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.Extensions.Semantics.SemanticStable.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.ModalLogic.Semantics.Flat.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Class ModalBisJoin (worlds: Type) {R2: KM.Relation worlds} {J: Join worlds} := {
  KM_join_bis: forall m n, R2 m n ->
    (forall n1 n2, join n1 n2 n ->
       exists m1 m2, join m1 m2 m /\ R2 m1 n1 /\ R2 m2 n2) /\
    (forall m1 m2, join m1 m2 m ->
       exists n1 n2, join n1 n2 n /\ R2 m1 n1 /\ R2 m2 n2)
}.

Instance prod_KM_bis_J (A B: Type) (RA: KM.Relation A) (RB: KM.Relation B) (JA: Join A) (JB: Join B) {KM_bis_JA: ModalBisJoin A} {KM_bis_JB: ModalBisJoin B}: @ModalBisJoin (A * B) (RelProd RA RB) (@prod_Join _ _ JA JB).
Proof.
  constructor.
  intros [m1 m2] [n1 n2] [? ?].
  pose proof (@KM_join_bis A _ _ KM_bis_JA m1 n1 H).
  pose proof (@KM_join_bis B _ _ KM_bis_JB m2 n2 H0).
  split.
  + intros [n11 n12] [n21 n22] [? ?].
    destruct H1 as [? _].
    destruct H2 as [? _].
    specialize (H1 _ _ H3).
    destruct H1 as [m11 [m21 [? [? ?]]]].
    specialize (H2 _ _ H4).
    destruct H2 as [m12 [m22 [? [? ?]]]].
    exists (m11, m12), (m21, m22).
    split; [| split]; split; auto.
  + intros [m11 m12] [m21 m22] [? ?].
    destruct H1 as [_ ?].
    destruct H2 as [_ ?].
    specialize (H1 _ _ H3).
    destruct H1 as [n11 [n21 [? [? ?]]]].
    specialize (H2 _ _ H4).
    destruct H2 as [n12 [n22 [? [? ?]]]].
    exists (n11, n12), (n21, n22).
    split; [| split]; split; auto.
Qed.

Instance eq_bis_J (A: Type) (J: Join A): @ModalBisJoin A eq J.
Proof.
  constructor.
  intros; subst.
  split; intros.
  + exists n1, n2; auto.
  + exists m1, m2; auto.
Qed.

Lemma sound_sepcon_boxp {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: KM.Relation (Kworlds M)} {J: Join (Kworlds M)} {KM_bis_J: ModalBisJoin (Kworlds M)} {SM: Semantics L MD} {kminSM: KripkeMinimumSemantics L MD M SM} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {fm: FlatModalSemantics L MD M SM} {fsepconSM: SepconSemantics L MD M SM}:
  forall x y: expr,
    forall m: Kworlds M, KRIPKE: M, m |= boxp x * boxp y --> boxp (x * y).
Proof.
  intros.
  rewrite !sat_impp.
  intros.
  clear m H.
  rewrite sat_sepcon in H0.
  destruct H0 as [n1 [n2 [? [? ?]]]].
  rewrite sat_boxp in H0, H1 |- *.
  intros m ?.
  pose proof KM_join_bis _ _ H2.
  destruct H3 as [_ ?].
  specialize (H3 _ _ H).
  destruct H3 as [m1 [m2 [? [? ?]]]].
  rewrite sat_sepcon; exists m1, m2.
  auto.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_lib.
Require Export sequents_tacs.
Require Export sequents_equality.
Require Export per_props_uni.
Require Export per_props_halts.

Lemma int_in_uni {p} :
  forall lib i, @member p lib mkc_int (mkc_uni i).
Proof.
  introv.
  unfold member, equality.
  exists (fun A A' => {eqa : per , close lib (univi lib i) A A' eqa}).
  unfold nuprl.
  dands.

  { apply mkc_uni_in_nuprl. }

  { exists (equality_of_int lib).
    apply CL_int.
    unfold per_int; dands; spcast; auto;
      apply computes_to_valc_refl; eauto 3 with slow. }
Qed.

(*
   H |- n = n in Int

     By natural_numberEquality
 *)
Definition rule_natural_number_equality {o}
           (H : @bhyps o)
           (i : Z) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_integer i) (mk_integer i) mk_int)))
    []
    [].

Lemma rule_natural_number_equality_true3 {o} :
  forall lib (H : @bhyps o) i,
    rule_true3 lib (rule_natural_number_equality H i).
Proof.
  intros.
  unfold rule_natural_number_equality, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  { unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.
  pose proof (teq_and_eq_if_equality
                lib mk_int (mk_integer i) (mk_integer i)
                s1 s2 H wT w1 w1 c1 c0 cT cT0 cT cT0) as q.
  lsubst_tac.
  apply q; auto; clear q.

  { apply tequality_int. }

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.

  apply @equality_in_int.
  exists i; dands; spcast; apply computes_to_valc_refl; eauto 3 with slow.
Qed.

Definition rule_int_equality_concl {o} (H : @bhyps o) i :=
  mk_baresequent H (mk_conclax (mk_equality mk_int mk_int (mk_uni i))).

(*
   H |- Int = Int in Type(i)

     By intEquality
 *)
Definition rule_int_equality {o}
           (H : @bhyps o)
           (i : nat) :=
  mk_rule
    (rule_int_equality_concl H i)
    []
    [].

Lemma rule_int_equality_true3 {o} :
  forall lib (H : @bhyps o) i,
    rule_true3 lib (rule_int_equality H i).
Proof.
  intros.
  unfold rule_int_equality, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  { unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.
  pose proof (teq_and_eq_if_equality
                lib (mk_uni i) mk_int mk_int
                s1 s2 H wT w1 w1 c1 c0 cT cT0 cT cT0) as q.
  lsubst_tac.
  apply q; auto; clear q.

  { apply tequality_mkc_uni. }

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
  apply int_in_uni.
Qed.

Lemma rule_int_equality_true_ext_lib {o} :
  forall lib (H : @bhyps o) i,
    rule_true_ext_lib lib (rule_int_equality H i).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_int_equality_true3.
Qed.

Lemma rule_int_equality_wf2 {o} :
  forall (H : @bhyps o) i,
    wf_rule2 (rule_int_equality H i).
Proof.
  introv wf m; allsimpl; tcsp.
Qed.

(*
   H |- halts(t)

     By callbyvalueInt

     H |- t in Int
 *)
Definition rule_callbyvalue_int {o}
           (H : @bhyps o)
           (t : NTerm) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_halts t)))
    [
      mk_baresequent H (mk_conclax (mk_member t mk_int))
    ]
    [].

Lemma rule_callbyvalue_int_true3 {o} :
  forall lib (H : @bhyps o) t,
    rule_true3 lib (rule_callbyvalue_int H t).
Proof.
  intros.
  unfold rule_callbyvalue_int, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  { clear hyp1.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; clear hyp1; exrepnd.
  lsubst_tac.

  rw <- @member_member_iff in h1.
  repeat (rw <- @fold_mkc_member in h0).
  apply equality_commutes in h0; auto.
  clear h1.
  apply equality_in_int in h0.
  unfold equality_of_int in h0; exrepnd; spcast.

  rw @equality_in_mkc_halts_ax.
  eapply teq_and_eq_if_halts; eauto; spcast;
    eapply computes_to_valc_implies_hasvaluec; eauto.
Qed.


(*****************************************************************************)
(*                                                                           *)
(*  Operations.v                                                             *)
(*                                                                           *)
(*  This file contains definitions of common array operations.               *)
(*                                                                           *)
(*****************************************************************************)

Require Import TensorIR.Equations.Shallow.Domain.
Require Import TensorIR.Equations.Shallow.Vectors.
Require Import TensorIR.Arrays.Array.

Import VectorNotations.

Definition map {a b : Type} {r : nat} {sh : NVect r} :
  (a -> b) -> Array sh a -> Array sh b :=
  fun f x i => f (x i).

Definition zipWith {a b c : Type} {r : nat} {sh : NVect r} :
  (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c :=
  fun f x y i => f (x i) (y i).

Definition zip {a b : Type} {r : nat} {sh : NVect r} :
  Array sh a -> Array sh b -> Array sh (a * b) :=
  fun x y => let p := fun eltx elty => (eltx, elty) in
             zipWith p x y.

(* General reshaping with a function (f : DomainT sh' -> DomainT sh): *)

Definition reshape {a : Type} {r s : nat} {sh : NVect r} {sh' : NVect s} :
  (DomainT sh' -> DomainT sh) -> Array sh a -> Array sh' a :=
  fun f x i => x (f i).

(* Append two arrays along their first dimensions (subsequent dimensions *)
(* must match, i.e. must be of shape 'sh'):                              *)

Definition append {a : Type} {r : nat} {sh : NVect r} {m n : nat} :
                  Array (m::sh) a -> Array (n::sh) a ->
                  Array ((m+n)::sh) a :=
  fun x y i => let (i0,i') := i in
               match sep i0 with
                 | inl j => x (j,i')
                 | inr j => y (j,i')
               end.

(* Split an array into two arrays, along the first dimension: *)

Definition split {a : Type} {r : nat} {sh : NVect r} {m n : nat} :
                 Array ((m+n)::sh) a ->
                 (Array (m::sh) a) * (Array (n::sh) a) :=
  fun x => (fun (i : DomainT (m::sh)) => let (i0,i') := i in
                                         x (join (inl i0),i'),
            fun (i : DomainT (n::sh)) => let (i0,i') := i in
                                         x (join (inr i0),i')).

(* Extract the first slice of an array (equivalently, project *)
(* an array onto the first index in the first dimension):     *)

Definition head {a : Type} {m : nat} {r : nat} {sh : NVect r} :
  Array ((S m)::sh) a -> Array sh a :=
  fun x i => x (Fin.F1, i).

(* Extract all slices but the first one from an array: *)

Definition behead {a : Type} {m : nat} {r : nat} {sh : NVect r} :
  Array ((S m)::sh) a -> Array (m::sh) a :=
  fun x i => let (i0,i') := i in
             x (Fin.FS i0, i').

(* Extract the last slice of an array: *)

Fixpoint tail {a : Type} {m : nat} {r : nat} {sh : NVect r} :
  Array ((S m)::sh) a -> Array sh a :=
  match m with
    | 0    => fun x i => x (Fin.F1,i)
    | S m' => fun x i => tail (behead x) i
  end.

(* Extract all slices but the last one: *)

Definition curtail {a : Type} {m : nat} {r : nat} {sh : NVect r} :
  Array ((S m)::sh) a -> Array (m::sh) a :=
  fun x i => let (i0,i') := i in
             x (wkS i0, i').

(* Prop up an array by giving it constant *)
(* elements along the first dimension:    *)

Definition prop {a : Type} {r : nat} {sh : NVect r} :
  forall (k : nat), Array sh a -> Array ((S k)::sh) a :=
  fun _ x i => let (i0, i') := i in
               x i'.

Fixpoint foldr {a b : Type} {m : nat} {r : nat} {sh : NVect r} :
  (Array sh a -> Array sh b -> Array sh b) ->
  Array sh b -> Array (m::sh) a -> Array sh b :=
  fun f init => match m with
                  | 0    => fun _ => init
                  | S m' => fun x => f (head x) (foldr f init (behead x))
                end.

Definition foldr' {a b : Type} {m : nat} {r : nat} {sh : NVect r} :
  (a -> b -> b) ->
  Array sh b -> Array (m::sh) a -> Array sh b :=
  fun f => foldr (zipWith f).

Fixpoint foldl {a b : Type} {m : nat} {r : nat} {sh : NVect r} :
  (Array sh b -> Array sh a -> Array sh b) ->
  Array sh b -> Array (m::sh) a -> Array sh b :=
  fun f init => match m with
                  | 0    => fun _ => init
                  | S m' => fun x => foldl f (f init (head x)) (behead x)
                end.

Definition foldl' {a b : Type} {m : nat} {r : nat} {sh : NVect r} :
  (b -> a -> b) ->
  Array sh b -> Array (m::sh) a -> Array sh b :=
  fun f => foldl (zipWith f).


Theorem hoare_if_wp : forall P1 P2 Q (b:bexp) c1 c2,
    {{ P1 }} c1 {{ Q }} ->
    {{ P2 }} c2 {{ Q }} ->
    {{ (b -> P1) /\ (~ b -> P2) }} if b then c1 else c2 end {{ Q }}.
Proof.
  intros P1 P2 Q b c1 c2 HTrue HFalse st st' HE [HP1 HP2].
  inversion HE; subst; eauto.
Qed.

Ltac hauto_vc :=
  eauto;
  unfold "->>", assn_sub, t_update, bassn;
  intros; simpl in *;
  repeat
    match goal with
    | [H: _ <> true |- _] => apply not_true_iff_false in H
    | [H: _ <> false |- _] => apply not_false_iff_true in H
    | [H: _ /\ _ |- _] => destruct H
    | [H: _ && _ = true |- _] => apply andb_true_iff in H
    | [H: _ && _ = false |- _] => apply andb_false_iff in H
    | [H: _ || _ = true |- _] => apply orb_true_iff in H
    | [H: _ || _ = false |- _] => apply orb_false_iff in H
    | [H: negb _ = true |- _] => eapply negb_true_iff in H
    | [H: negb _ = false |- _] => eapply negb_false_iff in H
    | [H: (_ =? _) = true |- _] => eapply beq_nat_true in H
    | [H: (_ =? _) = false |- _] => eapply beq_nat_false in H
    end;
  repeat (
    try rewrite -> eqb_eq in *;
    try rewrite -> leb_le in *;
    try rewrite leb_iff in *;
    try rewrite leb_iff_conv in *
  );
  try discriminate; try contradiction; eauto; try nia.

Ltac hauto_split1 :=
  try match goal with
      | [|- {{_}} skip {{_}}] =>
        first [eapply hoare_skip; fail | eapply hoare_consequence_pre; [eapply hoare_skip|]]
      | [|- {{_}} _ := _ {{_}}] =>
        first [eapply hoare_asgn;[] | eapply hoare_consequence_pre; [eapply hoare_asgn|]]
      | [|- {{_}} _; _ {{_}}] =>
        eapply hoare_seq
      | [|- {{_}} if _ then _ else _ end {{_}}] =>
        first [eapply hoare_if_wp;[|] | eapply hoare_consequence_pre; [eapply hoare_if_wp|]]
      end.

Ltac hauto :=
  match goal with
  | [|- {{_}} _ {{_}}] => repeat hauto_split1
  | _ => idtac
  end;
  try (hauto_vc; fail).

Ltac hauto_while P :=
  first[
      eapply (hoare_while P) |
      eapply hoare_consequence_post; [eapply (hoare_while P)|] |
      eapply hoare_consequence_post; [eapply hoare_consequence_pre; [eapply (hoare_while P)|]|]
    ];
  hauto.


From Undecidability.Synthetic Require Import Definitions.
From Undecidability.Shared Require Import Dec.

Require Import Vector.
Import VectorNotations.

Require Import ConstructiveEpsilon.

From Equations Require Import Equations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Ltac first s := only 1: s.
Ltac last s := cycle -1; only 1: (s + fail).
Derive Signature for t.

(* Utilities for vectors *)
Lemma vec_0_nil X (v : Vector.t X 0) : v = [].
Proof.
  now depelim v.
Qed.
Lemma vec_1_inv X (v : Vector.t X 1) : {a & v = [a]}.
Proof.
  repeat depelim v. eauto.
Qed.

Lemma vec_2_inv X (v : Vector.t X 2) : { a & { b & v = [a; b]} }.
Proof.
  repeat depelim v. eauto.
Qed.

Lemma vec_singleton {X} (a b : X) : Vector.In a [b] -> a = b.
Proof.
  inversion 1; now inversion H2.
Qed.

(* * Synthetic computability *)
(* Partial functions **)

Definition core_valid {Y : Type} (core : nat -> option Y) :=
  forall y1 y2 k1 k2, core k1 = Some y1 -> core k2 = Some y2 -> y1 = y2.

Record part (Y : Type) : Type := mkPart {
  core : nat -> option Y;
  valid : core_valid core
}.
Arguments mkPart {_} _ _.
Arguments valid [_] _.
Definition part_eval {Y : Type} (p : part Y) (y : Y) :=
  exists k, (core p) k = Some y.
(* Notation for evaluation *)
Notation "p ▷ y" := (part_eval p y) (at level 30).
(* Print only notation to avoid printing validity proofs *)
Notation "'partial' f " := ({| core := f; valid := _ |}) (at level 30, only printing).
(* Notation for partial functions *)
Notation "A -\ B" := (A -> part B) (at level 30).

(* Totalisation of total partial functions *)
Definition mu (p : nat -> Prop) :
  (forall x, dec (p x)) -> ex p -> sig p.
Proof.
  apply constructive_indefinite_ground_description_nat_Acc.
Qed.

Lemma totalise_part X (p : part X) : (exists y, p ▷ y) -> {y & p ▷ y}.
Proof.
  intros H.
  assert (exists k, exists y, p.(core) k = Some y) as H'%mu by firstorder.
  - destruct H' as [k H'']. destruct (p.(core) k) as [x|] eqn:Heq.
    + firstorder.
    + exfalso. now destruct H''.
  - intros k. destruct (p.(core) k) as [x|] eqn:H''.
    + left. eauto.
    + right. now intros [y Hy].
Qed.

Theorem totalise X Y (f : X -\ Y) : (forall x, exists y, f x ▷ y) -> forall x, {y & f x ▷ y}.
Proof.
  intros H x. apply totalise_part, H.
Qed.
Definition partialise X Y (f : X -> Y) : X -\ Y.
Proof.
  intros x. exists (fun _ => Some (f x)). congruence.
Defined.

(* Utilities for working with partial functions *)
Lemma part_functional {X : Type} (p : part X) (x y : X) : p ▷ x -> p ▷ y -> x = y.
Proof.
  intros [k1 H1] [k2 H2].
  eapply (p.(valid)); eassumption.
Qed.

(* Composition of parts with total or partial functions *)
Program Definition comp_part_total Y Z (f : Y -> Z) (g : part Y) : part Z.
Proof.
  unshelve eexists.
  { intros k. exact (match g.(core) k with Some y => Some (f y) | None => None end). }
  intros z1 z2 k1 k2 H1 H2.
  destruct (core _ k1) as [y1|] eqn:Hk1, (core _ k2) as [y2|] eqn:Hk2; try congruence.
  enough (y1 = y2) by congruence.
  eapply part_functional; eexists; eassumption.
Defined.
Program Definition comp_part_partial Y Z (f : Y -\ Z) (g : part Y) : part Z.
Proof.
  unshelve eexists.
  { intros k. exact (match g.(core) k with Some y => (f y).(core) k | None => None end). }
  intros z1 z2 k1 k2 H1 H2.
  destruct (core _ k1) as [y1|] eqn:Hk1, (core _ k2) as [y2|] eqn:Hk2; try congruence.
  assert (y1 = y2) as ->.
  { eapply part_functional with (p := g); eexists; eassumption. }
  eapply part_functional; eexists; eassumption.
Defined.

(* Disjoint and semi-decidable predicates can be recursively separated *)
(* Note that enumerability and discreteness suffice for semi-decidability *)
Lemma enumerable_separable (X : Type) (P1 P2 : X -> Prop) :
  (forall x, P1 x -> P2 x -> False) ->
  semi_decidable P1 -> semi_decidable P2 -> exists f : X -\ bool,
  (forall x, P1 x <-> f x ▷ true) /\
  (forall x, P2 x <-> f x ▷ false).
Proof.
  intros Pdisjoint [f1 Hf1] [f2 Hf2].
  unshelve eexists.
  { intros x. unshelve eexists.
    { intros k. refine (if f1 x k then Some true else if f2 x k then Some false else None). }
    intros y1 y2 k1 k2 H1 H2.
    destruct (f1 x k1) eqn:H11, (f2 x k1) eqn:H21, (f1 x k2) eqn:H12, (f2 x k2) eqn:H22; try congruence.
    all: destruct (Pdisjoint x); apply Hf1+apply Hf2; eauto. }
 split; intros x; split.
 - intros [k Hk]%Hf1. exists k. cbn. now rewrite Hk.
 - intros [k Hk]. apply Hf1. exists k. cbn in Hk. now destruct (f1 x k), (f2 x k).
 - intros [k Hk]%Hf2. exists k. cbn. destruct (f1 x k) eqn:Hk'.
   + destruct (Pdisjoint x); apply Hf1 + apply Hf2; eauto.
   + now rewrite Hk.
 - intros [k Hk]. apply Hf2. exists k. cbn in Hk. now destruct (f1 x k), (f2 x k).
Qed.

(* Given two disjoint, semi-decidable predicates one can construct a partial decider. *)

Theorem general_post (X : Type) (P Q : X -> Prop) s1 s2 :
  semi_decider s1 P -> semi_decider s2 Q -> (forall x, P x -> Q x -> False)
  -> { f : X -\ bool | forall x, (P x <-> f x ▷ true) /\ (Q x <-> f x ▷ false) }.
Proof.
  intros H1 H2 HD. unshelve eexists. 2: split; split.
  - intros x. exists (fun n => if s1 x n then Some true else if s2 x n then Some false else None).
    intros b b' n n'. destruct (s1 x n) eqn:HS1, (s2 x n) eqn:HS2.
    all: destruct (s1 x n') eqn:HS1', (s2 x n') eqn:HS2'; try congruence.
    all: exfalso; apply (HD x); [ apply H1 | apply H2 ]; eauto.
  - intros [n Hn] % H1. exists n. cbn. now rewrite Hn.
  - intros [n Hn]. cbn in Hn. apply H1. exists n. destruct (s1 x n), (s2 x n); congruence.
  - intros [n Hn] % H2. exists n. cbn. rewrite Hn.
    enough (s1 x n = false) as -> by reflexivity.
    destruct (s1 x n) eqn:H; try reflexivity.
    exfalso. apply (HD x); [ apply H1 | apply H2 ]; eauto.
  - intros [n Hn]. cbn in Hn. apply H2. exists n. destruct (s1 x n), (s2 x n); congruence.
Qed.

Theorem general_post_dec (X : Type) (P Q : X -> Prop) s1 s2 :
  semi_decider s1 P -> semi_decider s2 Q -> (forall x, P x -> Q x -> False)
  -> (forall x, P x \/ Q x) -> decidable P.
Proof.
  intros H1 H2 HD HE. destruct (general_post H1 H2 HD) as [f Hf]. unshelve eexists.
  - intros x. unshelve edestruct (@totalise _ _ f) as [b Hb]; try exact x.
    + intros y. destruct (HE y) as [H|H].
      * exists true. now apply Hf.
      * exists false. now apply Hf.
    + exact b.
  - cbn. intros x. destruct totalise as [b Hb]. unfold reflects.
    destruct b; firstorder congruence.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

From Coq Require Import List.

Lemma map_in :
 forall (A B : Type) (f : A -> B) (b : B) (xs : list A),
 In b (map f xs) -> ex (fun a : A => b = f a /\ In a xs).
intros A B f b xs; elim xs; simpl in |- *; auto.
intros H'; elim H'; auto.
intros a l H' H'0; elim H'0;
 [ intros H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
exists a; split; auto.
elim H'; [ intros a0 E; elim E; intros H'2 H'3; clear E H' | clear H' ]; auto.
exists a0; split; auto.
Qed.

Lemma map_app :
 forall (A B : Type) (f : A -> B) (l1 l2 : list A),
 map f (l1 ++ l2) = map f l1 ++ map f l2.
intros A B f l1; elim l1; simpl in |- *; auto with datatypes.
intros a l H' l2; rewrite H'; auto.
Qed.

Lemma map_rev :
 forall (A B : Type) (f : A -> B) (l : list A), map f (rev l) = rev (map f l).
intros A B f l; elim l; simpl in |- *; auto.
intros a l0 H'; rewrite <- H'; simpl in |- *; auto.
apply trans_equal with (y := map f (rev l0) ++ map f (a :: nil)); auto.
apply map_app; auto.
Qed.

Lemma rev_in : forall (A : Type) (a : A) (l : list A), In a (rev l) -> In a l.
intros A a l; elim l; simpl in |- *; auto.
intros a0 l0 H' H'0.
case (in_app_or _ _ _ H'0); simpl in |- *; intros H'1; auto.
elim H'1; auto.
intros H'2; elim H'2.
Qed.

Lemma in_rev : forall (A : Type) (a : A) (l : list A), In a l -> In a (rev l).
intros A a l H'.
apply rev_in with (A := A); auto.
rewrite (rev_involutive l); auto.
Qed.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.

Require Import Embed.Theory.Utils.
Require Import Embed.Theory.Datatypes.Prod.
Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.
Require Import Embed.Theory.Btree.Monad.
Require Import Embed.Theory.Btree.Leaves.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Equations zip_btree {A B} (xs : @btree A) (ys : list B) (pf : num_leaves xs = length ys) : @btree (A * B) :=
zip_btree (bnil x) ys pf := bnil (pair x (dep_hd ys _)) ;
zip_btree (bcons x y) ys pf :=
  bcons
    (zip_btree
      x
      (firstn (num_leaves x) ys)
      (num_leaves_firstn pf))
    (zip_btree
      y
      (skipn  (num_leaves x) ys)
      (num_leaves_skipn pf)
    ).

(* Notation "zip_btree_eq" := (eq_zip_btree). *)
Fixpoint eq_zip_btree {A B} (xs ys : @btree A) (zs ws : list B)
  (pfx : num_leaves xs = length zs)
  (pfy : num_leaves ys = length ws)
  (eqxy : xs = ys)
  (eqzw : zs = ws) :
    zip_btree xs zs pfx = zip_btree ys ws pfy.
destruct eqxy, eqzw, xs.

destruct zs.

discriminate.

reflexivity.

repeat (rewrite zip_btree_equation_2).
refine (bcons_eq _ _).

exact (eq_zip_btree _ _ _ _ _ _ _ _ eq_refl eq_refl).

exact (eq_zip_btree _ _ _ _ _ _ _ _ eq_refl eq_refl).
Qed.

Fixpoint leaves_zip_btree {A B} (xs : @btree A) (ys : list B) (pf : num_leaves xs = length ys) :
  leaves (zip_btree xs ys pf) = combine (leaves xs) ys.
destruct xs.

rewrite leaves_equation_1.
destruct ys.

discriminate.

destruct ys.

rewrite zip_btree_equation_1.
reflexivity.

discriminate.

rewrite leaves_equation_2.
destruct ys.

pose (num_leaves_positive _ pf).
destruct f.

rewrite zip_btree_equation_2.
rewrite leaves_equation_2.
rewrite combine_app.
refine (list_app_eq _ _).

rewrite eq_num_leaves.
exact (leaves_zip_btree _ _ _ _ _).

rewrite eq_num_leaves.
exact (leaves_zip_btree _ _ _ _ _).
Defined.

(* TODO: Rewrite to use leaves_zip_btree *)
(* The same definition with 'fix' produces a known bug: https://github.com/coq/coq/issues/11013 *)
Fixpoint num_leaves_zip_btree {A B} (xs : @btree A) (ys : list B) (pf : num_leaves xs = length ys) :
  num_leaves (zip_btree xs ys pf) = num_leaves xs.
Proof.
destruct xs.

pose pf.
rewrite num_leaves_equation_1 in e.
destruct ys.

discriminate.

destruct ys.

rewrite num_leaves_equation_1.
rewrite zip_btree_equation_1.
rewrite num_leaves_equation_1.
reflexivity.

discriminate.

rewrite num_leaves_equation_2.
destruct ys.

pose (num_leaves_positive (bcons xs1 xs2) pf).
destruct f.

rewrite zip_btree_equation_2.
rewrite num_leaves_equation_2.
refine (nat_plus_eq _ _).

exact (num_leaves_zip_btree _ _ xs1 (firstn (num_leaves xs1) (b :: ys)) (num_leaves_firstn pf)).

exact (num_leaves_zip_btree _ _ xs2 (skipn (num_leaves xs1) (b :: ys)) (num_leaves_skipn pf)).
Defined.

Local Close Scope nat_scope.

Equations zip_btree_err {A B} (xs : @btree A) (ys : list B) : B -> @btree (A * B) :=
zip_btree_err (bnil x) nil := fun err => bnil (pair x err) ;
zip_btree_err (bnil x) (cons y _) := fun _ => bnil (pair x y) ;
zip_btree_err (bcons x y) ys := fun err =>
  bcons
    (zip_btree_err
      x
      (firstn (num_leaves x) ys)
      err
    )
    (zip_btree_err
      y
      (skipn  (num_leaves x) ys)
      err
    ).

Fixpoint zip_btree_err_correct {A B} (xs : @btree A) (ys : list B) : forall
  (pf : num_leaves xs = length ys)
  (z : B),
    zip_btree_err xs ys z = zip_btree xs ys pf.
intros.
destruct ys.
{
  destruct (num_leaves_positive xs pf).
}
{
  destruct xs.
  {
    rewrite zip_btree_err_equation_2.
    rewrite zip_btree_equation_1.
    refine (bnil_eq _).
    refine (pair_eq eq_refl _).
    rewrite dep_hd_equation_2.
    reflexivity.
  }
  {
    rewrite zip_btree_err_equation_3.
    rewrite zip_btree_equation_2.
    refine (bcons_eq _ _).
    {
      exact (zip_btree_err_correct _ _ _ _ _ _).
    }
    {
      exact (zip_btree_err_correct _ _ _ _ _ _).
    }
  }
}
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.

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

(*****************************************************************************)
(* Tuples, i.e., lists with a fixed (known) length. We define:               *)
(*   n.-tuple T   : the type of n-tuples of elements of type T.              *)
(*   [tuple of s] : the tuple whose underlying sequence (value) is s, which  *)
(*                  must have a known size; specifically, Coq must be able   *)
(*                  to infer a tuple whose Canonical Projection is s, e.g.,  *)
(*     [tuple]            is the empty tuple, and                            *)
(*     [tuple x1; ..; xn] the explicit n.-tuple <x1; ..; xn>.                *)
(* As n.-tuple T coerces to seq t, all operations for seq (size, nth, ...)   *)
(* can be applied to t : n.-tuple T; we provide a few specialized instances  *)
(* when this avoids the need for a default value.                            *)
(*   tsize t      : the size of t (the n in n.-tuple T)                      *)
(*   tnth t i     : the i'th component of t, where i : 'I_n.                 *)
(*   [tnth t i]   : the i'th component of t, where i : nat.                  *)
(*   thead t      : the first element of t, when n is canonically positive.  *)
(* Most seq constructors (behead, cat, belast, take, drop, rot, map, ...)    *)
(* can be used to build tuples via the [tuple of s] construct.               *)
(*   Tuples are actually a subType of seq, and inherit all combinatorial     *)
(* structures, including the finType structure.                              *)
(*   Some useful lemmas and definitions:                                     *)
(*     tuple0 : [tuple] is the only 0.-tuple                                 *)
(*     tupleP : elimination view for n.+1.-tuple                             *)
(*     ord_tuple n : the n.-tuple of all i : 'I_n                            *)
(*****************************************************************************)

Section Def.

Variables (n : nat) (T : Type).

Structure tuple_of : Type := Tuple {tval :> seq T; _ : size tval == n}.

Canonical Structure tuple_subType :=
  Eval hnf in [subType for tval by tuple_of_rect].

Implicit Type t : tuple_of.

Definition tsize of tuple_of := n.

Lemma size_tuple : forall t, size t = n.
Proof. move=> f; exact: (eqP (valP f)). Qed.

Lemma tnth_default : forall t (i : 'I_n), T.
Proof. by case=> [[|//]]; move/eqP <-; case. Qed.

Definition tnth t i := nth (tnth_default t i) t i.

Lemma tnth_nth : forall x t i, tnth t i = nth x t i.
Proof. by move=> x t i; apply: set_nth_default; rewrite size_tuple. Qed.

Lemma map_tnth_enum : forall t, map (tnth t) (enum 'I_n) = t.
Proof.
move=> t; case def_t: {-}(val t) => [|x0 t'].
  by rewrite [enum _]size0nil // -cardE card_ord -(size_tuple t) def_t.
apply: (@eq_from_nth _ x0) => [|i]; rewrite size_map.
  by rewrite -cardE size_tuple card_ord.
move=> lt_i_e; have lt_i_n: i < n by rewrite -cardE card_ord in lt_i_e.
by rewrite (nth_map (Ordinal lt_i_n)) // (tnth_nth x0) nth_enum_ord.
Qed.

Lemma eq_from_tnth : forall t1 t2, tnth t1 =1 tnth t2 -> t1 = t2.
Proof.
by move=> *; apply: val_inj; rewrite /= -!map_tnth_enum; exact: eq_map.
Qed.

Definition tuple t mkT : tuple_of :=
  mkT (let: Tuple _ tP := t return size t == n in tP).

Lemma tupleE : forall t, tuple (fun sP => @Tuple t sP) = t.
Proof. by case. Qed.

End Def.

Notation "n .-tuple" := (tuple_of n)
  (at level 2, format "n .-tuple") : type_scope.

Notation "{ 'tuple' n 'of' T }" := (n.-tuple T : predArgType)
  (at level 0, only parsing) : form_scope.

Notation "[ 'tuple' 'of' s ]" := (tuple (fun sP => @Tuple _ _ s sP))
  (at level 0, format "[ 'tuple'  'of'  s ]") : form_scope.

Notation "[ 'tnth' t i ]" := (tnth t (@Ordinal (tsize t) i (erefl true)))
  (at level 0, t, i at level 8, format "[ 'tnth'  t  i ]") : form_scope.

Canonical Structure nil_tuple T :=
   Tuple (erefl _ : @size T [::] == 0).
Canonical Structure cons_tuple n T x (t : n.-tuple T) :=
   Tuple (valP t : size (x :: t) == n.+1).

Notation "[ 'tuple' x1 ; .. ; xn ]" := [tuple of x1 :: .. [:: xn] ..]
  (at level 0, format "[ 'tuple' '['  x1 ; '/'  .. ; '/'  xn ']' ]")
  : form_scope.

Notation "[ 'tuple' ]" := [tuple of [::]]
  (at level 0, format "[ 'tuple' ]") : form_scope.

Section SeqTuple.

Variables (n : nat) (T rT : Type).
Notation tT := (n.-tuple T).

Lemma nseq_tupleP : forall x : T, size (nseq n x) == n.
Proof. by move=> x; rewrite size_nseq. Qed.
Canonical Structure nseq_tuple x := Tuple (nseq_tupleP x).

Lemma iota_tupleP : forall m, size (iota m n) == n.
Proof. by move=> m; rewrite size_iota. Qed.
Canonical Structure iota_tuple m := Tuple (iota_tupleP m).

Lemma behead_tupleP : forall t : tT, size (behead t) == n.-1.
Proof. by move=> t; rewrite size_behead size_tuple. Qed.
Canonical Structure behead_tuple t := Tuple (behead_tupleP t).

Lemma belast_tupleP : forall x (t : tT), size (belast x t) == n.
Proof. by move=> x t; rewrite size_belast size_tuple. Qed.
Canonical Structure belast_tuple x t := Tuple (belast_tupleP x t).

Lemma cat_tupleP : forall n1 n2 (t1 : n1.-tuple T) (t2 : n2.-tuple T),
  size (t1 ++ t2) == n1 + n2.
Proof. by move=> n1 n2 t1 t2; rewrite size_cat !size_tuple. Qed.
Canonical Structure cat_tuple n1 n2 t1 t2 := Tuple (@cat_tupleP n1 n2 t1 t2).

Lemma take_tupleP : forall m (t : tT), size (take m t) == minn m n.
Proof. by move=> m t; rewrite size_take size_tuple eqxx. Qed.
Canonical Structure take_tuple m t := Tuple (take_tupleP m t).

Lemma drop_tupleP : forall m (t : tT), size (drop m t) == n - m.
Proof. by move=> m t; rewrite size_drop size_tuple. Qed.
Canonical Structure drop_tuple m t := Tuple (drop_tupleP m t).

Lemma rev_tupleP : forall t : tT, size (rev t) == n.
Proof. by move=> t; rewrite size_rev size_tuple. Qed.
Canonical Structure rev_tuple t := Tuple (rev_tupleP t).

Lemma rot_tupleP : forall m (t : tT), size (rot m t) == n.
Proof. by move=> m t; rewrite size_rot size_tuple. Qed.
Canonical Structure rot_tuple m t := Tuple (rot_tupleP m t).

Lemma rotr_tupleP : forall m (t : tT), size (rotr m t) == n.
Proof. by move=> m t; rewrite size_rotr size_tuple. Qed.
Canonical Structure rotr_tuple m t := Tuple (rotr_tupleP m t).

Lemma map_tupleP : forall f (t : tT), @size rT (map f t) == n.
Proof. by move=> f t; rewrite size_map size_tuple. Qed.
Canonical Structure map_tuple f t := Tuple (map_tupleP f t).

Lemma scanl_tupleP : forall f x (t : tT), @size rT (scanl f x t) == n.
Proof. by move=> f x t; rewrite size_scanl size_tuple. Qed.
Canonical Structure scanl_tuple f x t := Tuple (scanl_tupleP f x t).

Lemma pairmap_tupleP : forall f x (t : tT), @size rT (pairmap f x t) == n.
Proof. by move=> f x t; rewrite size_pairmap size_tuple. Qed.
Canonical Structure pairmap_tuple f x t := Tuple (pairmap_tupleP f x t).

Lemma zip_tupleP : forall t1 t2 : tT, size (zip t1 t2) == n.
Proof. by move=> *; rewrite size1_zip !size_tuple. Qed.
Canonical Structure zip_tuple t1 t2 := Tuple (zip_tupleP t1 t2).

Definition thead n (t : n.+1.-tuple T) := tnth t ord0.

Lemma tnth0 : forall x n (t : n.-tuple T), tnth [tuple of x :: t] ord0 = x.
Proof. by []. Qed.

Lemma theadE : forall x n (t : n.-tuple T), thead [tuple of x :: t] = x.
Proof. by []. Qed.

Lemma tuple0 : @all_equal_to (0.-tuple T) [tuple].
Proof. by move=> t; apply: val_inj; case: t => [[]]. Qed.

CoInductive tuple1_spec : n.+1.-tuple T -> Type :=
  Tuple1spec x (t : tT) : tuple1_spec [tuple of x :: t].

Lemma tupleP : forall t, tuple1_spec t.
Proof.
move=> [[|x t] //= sz_t]; pose t' := Tuple (sz_t : size t == n).
rewrite (_ : Tuple _ = [tuple of x :: t']) //; exact: val_inj.
Qed.

Lemma tnth_map : forall f (t : tT) i,
  tnth [tuple of map f t] i = f (tnth t i) :> rT.
Proof. by move=> f t i; apply: nth_map; rewrite size_tuple. Qed.

End SeqTuple.

Lemma tnth_behead : forall n T (t : n.+1.-tuple T) i,
  tnth [tuple of behead t] i = tnth t (inord i.+1).
Proof.
by move=> n T; case/tupleP=> x t i; rewrite !(tnth_nth x) inordK ?ltnS.
Qed.

Lemma tuple_eta : forall n T (t : n.+1.-tuple T),
  t = [tuple of thead t :: behead t].
Proof. move=> n T; case/tupleP=> x t; exact: val_inj. Qed.

Section EqTuple.

Variables (n : nat) (T : eqType).

Definition tuple_eqMixin := Eval hnf in [eqMixin of n.-tuple T by <:].
Canonical Structure tuple_eqType :=
  Eval hnf in EqType (n.-tuple T) tuple_eqMixin.

Canonical Structure tuple_predType :=
  Eval hnf in mkPredType (fun t : n.-tuple T => mem_seq t).

Lemma memtE : forall t : n.-tuple T, mem t = mem (tval t).
Proof. by []. Qed.

End EqTuple.

Definition tuple_choiceMixin n (T : choiceType) :=
  [choiceMixin of n.-tuple T by <:].

Canonical Structure tuple_choiceType n (T : choiceType) :=
  Eval hnf in ChoiceType (n.-tuple T) (tuple_choiceMixin n T).

Definition tuple_countMixin n (T : countType) :=
  [countMixin of n.-tuple T by <:].

Canonical Structure tuple_countType n (T : countType) :=
  Eval hnf in CountType (n.-tuple T) (tuple_countMixin n T).

Canonical Structure tuple_subCountType n (T : countType) :=
  Eval hnf in [subCountType of n.-tuple T].

Module Type FinTupleSig.
Section FinTupleSig.
Variables (n : nat) (T : finType).
Parameter enum : seq (n.-tuple T).
Axiom enumP : Finite.axiom enum.
Axiom size_enum : size enum = #|T| ^ n.
End FinTupleSig.
End FinTupleSig.

Module FinTuple : FinTupleSig.
Section FinTuple.
Variables (n : nat) (T : finType).

Definition enum : seq (n.-tuple T) :=
  let extend e := flatten (map (fun x => map (cons x) e) (Finite.enum T)) in
  pmap insub (iter n extend [::[::]]).

Lemma enumP : Finite.axiom enum.
Proof.
case=> /= t t_n; rewrite -(count_map val (pred1 t)).
rewrite (pmap_filter (@insubK _ _ _)) count_filter -filter_predI -enumT.
rewrite -count_filter -(@eq_count _ (pred1 t)) => [|s /=]; last first.
  by rewrite isSome_insub; case: eqP=> // ->.
elim: n t t_n => [|m IHm] [|x t] //=.
move/IHm; move: (iter m _ _) => em {IHm} IHm.
transitivity (x \in T : nat); rewrite // -mem_enum.
have:= enum_uniq T; rewrite enumT.
elim: (Finite.enum T) => //= y e IHe; case/andP; move/negPf=> ney.
rewrite count_cat count_map inE /preim /= {1}/eq_op /= eq_sym; move/IHe->.
by case: eqP => [->|_]; rewrite ?(ney, count_pred0, IHm).
Qed.

Lemma size_enum : size enum = #|T| ^ n.
Proof.
rewrite /= cardE size_pmap_sub enumT; elim: n => //= m IHm.
rewrite expnS; elim: {2 3}(Finite.enum T) => //= x e IHe.
by rewrite count_cat {}IHe count_map IHm.
Qed.

End FinTuple.
End FinTuple.

Section UseFinTuple.

Variables (n : nat) (T : finType).
Notation tT := (n.-tuple T).

Canonical Structure tuple_finMixin :=
  Eval hnf in FinMixin (@FinTuple.enumP n T).
Canonical Structure tuple_finType := Eval hnf in FinType tT tuple_finMixin.
Canonical Structure tuple_subFinType := Eval hnf in [subFinType of tT].

Lemma card_tuple : #|{:n.-tuple T}| = #|T| ^ n.
Proof. by rewrite [#|_|]cardT enumT unlock FinTuple.size_enum. Qed.

Lemma enum_tupleP : forall A : pred T, size (enum A) == #|A|.
Proof. by move=> A; rewrite -cardE. Qed.
Canonical Structure enum_tuple A := Tuple (enum_tupleP A).

Definition ord_tuple : n.-tuple 'I_n := Tuple (introT eqP (size_enum_ord n)).
Lemma val_ord_tuple : val ord_tuple = enum 'I_n. Proof. by []. Qed.

Lemma tuple_map_ord : forall T' (t : n.-tuple T'),
  t = [tuple of map (tnth t) ord_tuple].
Proof. by move=> T' t; apply: val_inj => /=; rewrite map_tnth_enum. Qed.

Lemma tnth_ord_tuple : forall i, tnth ord_tuple i = i.
Proof.
move=> i; apply: val_inj; rewrite (tnth_nth i) -(nth_map _ 0) ?size_tuple //.
by rewrite /= enumT unlock val_ord_enum nth_iota.
Qed.

End UseFinTuple.


Require Import Coq.Array.PArray.
Require Import Coq.Numbers.Cyclic.Int63.Int63.
Require ZArith.

Class Field A : Type :=
  {
  plus : A -> A -> A;
  zero : A;
  add_inv: A -> A;
  add_0 : forall (a : A), plus zero a = a;
  add_comm : forall (a b : A), plus a b = plus b a;
  add_add_inv : forall (a : A), plus a (add_inv a) = zero;
  add_assoc : forall (a b c : A), plus a (plus b c) = plus (plus a b) c;
  mult : A -> A -> A;
  one : A;
  mult_inv: A -> A;
  mult_1 : forall (a : A), mult one a = a;
  mult_comm : forall (a b : A), mult a b = mult b a;
  mult_mult_inv : forall (a : A), mult a (mult_inv a) = one;
  mult_distr : forall (a b c : A), mult a (plus b c) = plus (mult a b) (mult b c);
  mult_assoc : forall (a b c : A), mult a (mult b c) = mult (mult a b) c
  }.

Fixpoint nat_int (n : nat) : int :=
  match n with
  | 0 => 0%int63
  | S k => 1%int63 + (nat_int k)
  end.

Inductive Vector (A : Type) : nat -> Type :=
| vect (arr : array A) {n : nat} {prf : n = BinInt.Z.to_nat((to_Z(length arr)))}  :
    Vector A n.

Definition vect_make {A : Type} (arr : array A) : Vector A (BinInt.Z.to_nat(to_Z(length arr))) :=
  @vect _ arr (BinInt.Z.to_nat((to_Z(length arr)))) (eq_refl).

Definition vect_default {A : Type} {n : nat} (v : Vector A n) :=
  match v with
  | vect _ arr => default arr
  end.

Definition vect_get {A : Type} {n : nat} (v : Vector A n) (idx : int) : A :=
  match v with
  | vect _ arr => arr.[idx]
  end.

Definition vect_set_lem (A : Type) (n : nat) (arr : array A) (idx : int) (a : A) :
  n = BinInt.Z.to_nat(to_Z(length arr)) ->
                      n = BinInt.Z.to_nat(to_Z(length (arr.[idx <- a]))) :=
                                                 match length_set A arr idx a with
                                                 | eq_refl => fun x => x
                                                 end.

Definition vect_set {A : Type} {n : nat} (v : Vector A n) (idx : int) (a : A) : Vector A n :=
  match v with
  | @vect _ arr n prf => @vect _ (arr.[idx<-a]) n (vect_set_lem A n arr idx a prf)
  end.

Notation "t .[ i ]" := (vect_get t i)
  (at level 2, left associativity, format "t .[ i ]").
Notation "t .[ i <- a ]" := (vect_set t i a)
  (at level 2, left associativity, format "t .[ i <- a ]").

Lemma vect_copy_lemma (A : Type) (n : nat) (arr : array A) : n = BinInt.Z.to_nat (to_Z(length arr)) ->
                       n = BinInt.Z.to_nat (to_Z(length (copy arr))).
Proof.
  intro.
  rewrite (length_copy A arr).
  apply H.
Qed.

Definition vect_copy {A : Type} {n : nat} (v : Vector A n) : Vector A n :=
  match v with
  | @vect _ arr n prf => match length_copy A arr with
                        | eq_refl => @vect _ (copy arr) n (vect_copy_lemma A n arr prf)
                        end
  end.

Definition vect_length {A : Type} {n : nat} : Vector A n -> nat :=
  fun v => n.

Definition vect_length_int {A : Type} {n : nat} (v : Vector A n) : int :=
  match v with
  | vect _ arr => length arr
  end.

Local Open Scope int63_scope.

Lemma vect_get_out_of_bounds : forall A (n : nat) (v : Vector A n) (i : int),
    (i <? vect_length_int v) = false -> v.[i] = vect_default v.
Proof.
  intros.
  destruct v.
  simpl.
  unfold vect_length_int in H.
  apply get_out_of_bounds.
  apply H.
Qed.

Lemma vect_default_set : forall A (n : nat) (v : Vector A n) (i : int) (a : A) ,
    vect_default v.[i <- a] = vect_default v.
Proof.
  intros.
  destruct v.
  simpl.
  apply default_set.
Qed.

Lemma vect_get_copy : forall A n (v : Vector A n) i,
    (vect_copy v).[i] = v.[i].
Proof.
  intros.
  destruct v.
  simpl.
  destruct (length_copy A arr).
  apply get_copy.
Qed.

Lemma vect_length_copy : forall A n (v : Vector A n),
    vect_length (vect_copy v) = vect_length v.
Proof.
  reflexivity.
Qed.

Lemma vect_length_copy_int : forall A n (v : Vector A n),
    vect_length_int (vect_copy v) = vect_length_int v.
Proof.
  intros.
  destruct v.
  simpl.
  destruct (length_copy A arr).
  reflexivity.
Qed.

Axiom vect_ext: forall A n (v1 v2: Vector A n),
    (forall i, i <? vect_length_int v1 = true -> v1.[i] = v2.[i]) ->
    v1 = v2.

Lemma vect_copy_eq : forall A n (v : Vector A n), vect_copy v = v.
Proof.
  intros.
  apply vect_ext.
  intros.
  apply vect_get_copy.
Qed.

Lemma vect_ext_default: forall A n (v1 v2 : Vector A n),
    vect_length_int v1 = vect_length_int v2 ->
    (forall i, i <? vect_length_int v1 = true -> v1.[i] = v2.[i]) ->
    vect_default v1 = vect_default v2 ->
    v1 = v2.
Proof.
  intros.
  destruct v1 as [t1 n prf1].
  destruct v2 as [t2 n prf2].
  simpl in H.
  simpl in H0.
  assert (t1 = t2).
  - apply array_ext.
    apply H.
    apply H0.
    apply H1.
  - subst.
    replace prf2 with (@eq_refl nat (BinInt.Z.to_nat(to_Z(length t2)))).
    reflexivity.
    symmetry.
    apply Eqdep_dec.UIP_refl_nat.
Qed.

Lemma vect_default_copy : forall A n (v : Vector A n),  vect_default (vect_copy v) = vect_default v.
Proof.
  intros.
  destruct v.
  simpl.
  destruct (length_copy A arr).
  simpl.
  apply default_copy.
Qed.

Lemma vect_default_make : forall A (t : array A), vect_default (vect_make t) = default t.
Proof.
  intros.
  reflexivity.
Qed.

Lemma vect_get_set_same_default : forall A n (v : Vector A n) (i : int),
    v.[i <- vect_default v].[i] = vect_default v.
Proof.
  intros.
  destruct v.
  apply get_set_same_default.
Qed.

Lemma vect_get_not_default_lt : forall A n (v : Vector A n) (i : int),
    v.[i] <> vect_default v -> (i <? vect_length_int v = true).
Proof.
  intros A n v.
  destruct v.
  simpl.
  apply get_not_default_lt.
Qed.

Lemma vect_get_set_same: forall (A : Type) (n : nat) (vect : Vector A n) (i : int) (a : A), (i <? (vect_length_int vect)) = true -> vect.[i <- a].[i] = a.
Proof.
  intros.
  unfold vect_set, vect_get.
  destruct vect0.
  apply get_set_same.
  simpl in H.
  assumption.
Qed.

Lemma vect_get_set_other: forall A n (vect: Vector A n) i j (a:A), i <> j -> vect.[i<-a].[j] = vect.[j].
  intros.
  unfold vect_set, vect_get.
  destruct vect0.
  apply get_set_other.
  assumption.
Qed.

Lemma vect_set_get_id: forall A n (vect: Vector A n) i j, (i <? vect_length_int vect = true) -> vect.[i <- vect.[i]].[j] = vect.[j].
Proof.
  intros.
  destruct (i =? j) eqn:Eq.
  + apply eqb_spec in Eq.
    subst.
    apply vect_get_set_same.
    assumption.
  + apply eqb_false_spec in Eq.
    apply vect_get_set_other.
    assumption.
Qed.

Lemma vect_get_make: forall A (a : A) size i, (vect_make (make size a)).[i] = a.
Proof.
  intros.
  unfold vect_make, vect_get.
  apply get_make.
Qed.

Lemma vect_leb_length:  forall A n (vect: Vector A n), vect_length_int vect <=? max_length = true.
Proof.
  intros.
  unfold vect_length_int.
  destruct vect0.
  apply leb_length.
Qed.

Lemma vect_make_length_arr: forall A (arr: array A), vect_length_int (vect_make arr) = length arr.
Proof.
  easy.
Qed.

Lemma vect_length_make: forall A (a: A) size, vect_length_int (vect_make (make size a)) = if size <=? max_length then size else max_length.
Proof.
  intros.
  unfold vect_length_int, vect_make.
  apply length_make.
Qed.

Lemma vect_length_set : forall (A : Type) n (vect : Vector A n) (i : int) (a : A), vect_length_int vect = vect_length_int (vect.[i <- a]).
Proof.
  intros.
  unfold vect_length_int.
  destruct vect0.
  destruct (vect A arr).[i <- a] eqn:H'.
  unfold vect_set in H'.
  injection H'.
  intros.
  rewrite <- H.
  rewrite length_set.
  reflexivity.
Qed.

Lemma make_length : forall (A : Type) (arr : array A) (a: A), length arr = length (make (length arr) a).
Proof.
  intros.
  rewrite length_make.
  rewrite leb_length.
  reflexivity.
Qed.

Lemma vect_make_length: forall A n (vect: Vector A n) (a : A), vect_length_int vect = vect_length_int (vect_make (make (vect_length_int vect) a)).
Proof.
  intros.
  rewrite vect_make_length_arr.
  unfold vect_length_int.
  destruct vect0.
  apply make_length.
Qed.

Lemma vect_length_int_vect_length: forall A B n m (v1: Vector A n) (v2: Vector B m), vect_length_int v1 = vect_length_int v2 -> vect_length v1 = vect_length v2.
Proof.
  intros;
  destruct v1, v2.
  unfold vect_length, vect_length_int in *; subst.
  rewrite H.
  reflexivity.
Qed.

Lemma vect_length_vect_length_type: forall A B n m (v1: Vector A n) (v2: Vector B m), vect_length v1 = vect_length v2 -> n = m.
Proof.
  intros.
  destruct v1, v2; subst.
  assumption.
Qed.

Axiom arr_length_positive: forall A (arr: array A), 0 <=? length arr = true.

Lemma vect_length_type_vect_length_int: forall A B n m (v1: Vector A n) (v2: Vector B m), n = m -> vect_length_int v1 = vect_length_int v2.
Proof.
  intros.
  destruct v1, v2.
  subst.
  simpl.
  apply Znat.Z2Nat.inj in H.
  apply to_Z_inj in H.
  assumption.
  replace BinNums.Z0 with (to_Z 0).
  apply leb_spec.
  apply arr_length_positive.
  reflexivity.
  replace BinNums.Z0 with (to_Z 0).
  apply leb_spec.
  apply arr_length_positive.
  reflexivity.
Qed.

Lemma vect_length_vect_length_int: forall A B n m (v1 : Vector A n) (v2 : Vector B m), vect_length v1 = vect_length v2 -> vect_length_int v1 = vect_length_int v2.
Proof.
  intros.
  apply vect_length_vect_length_type in H.
  apply vect_length_type_vect_length_int.
  exact H.
Qed.

Lemma vect_length_type_vect_length: forall A B n m (v1: Vector A n) (v2: Vector B m), n = m -> vect_length v1 = vect_length v2.
Proof.
  intros.
  unfold vect_length.
  assumption.
Qed.

Lemma vect_length_int_vect_length_type : forall A B n m (v1 : Vector A n) (v2 : Vector B m), vect_length_int v1 = vect_length_int v2 -> n = m.
Proof.
  intros.
  apply vect_length_int_vect_length in H.
  apply vect_length_vect_length_type in H.
  exact H.
Qed.

Local Close Scope int63_scope.

Fixpoint fold_vect_helper {A B : Type} {n: nat} (v : Vector A n) (f : A -> B -> B) (acc : B) (cnt : nat) (idx:int) : B :=
  match cnt with
  | S k => fold_vect_helper v f (f v.[idx] acc) k (idx+1%int63)
  | O   => acc
  end.

Definition fold_vect {A B: Type} {n: nat} (v: Vector A n) (f: A -> B -> B) (base: B) :=
  fold_vect_helper v f base n (0%int63).

Fixpoint zip_with_vect_helper {A B C: Type} {n: nat} (v1: Vector A n) (v2: Vector B n) (f: A -> B -> C) (tgt: Vector C n) (cnt: nat) (idx: int) : Vector C n :=
  match cnt with
  |  0 => tgt
  | S k =>
      let el := f (v1.[idx]) (v2.[idx]) in
      zip_with_vect_helper v1 v2 f (tgt.[idx <- el]) k (idx + 1%int63)
  end.

Fixpoint map_vect_helper {A B: Type} {n: nat} (v: Vector A n) (f: A -> B ) (tgt: Vector B n) (cnt: nat) (idx: int) : Vector B n :=
  match cnt with
  |  0 => tgt
  | S k =>
      let el := f (v.[idx]) in
      map_vect_helper v f (tgt.[idx <- el]) k (idx + 1%int63)
  end.

Definition zip_with_vect_on {A B C: Type} {n: nat} (v1: Vector A n) (v2: Vector B n) (f: A -> B -> C) (tgt: Vector C n) :=
  zip_with_vect_helper v1 v2 f tgt n (0%int63).

Definition map_vect_on {A B: Type} {n: nat} (v: Vector A n) (f: A -> B) (tgt: Vector B n) :=
  map_vect_helper v f tgt n (0%int63).

Theorem nRect : forall (A : Type) (n n0 : nat) (v : Vector A n), n0 = BinInt.Z.to_nat(to_Z(vect_length_int v)) ->
                                                          n = BinInt.Z.to_nat(to_Z(vect_length_int v)) ->
                                                          n0 = n.
Proof.
  intros.
  destruct v.
  rewrite H0.
  easy.
Qed.

Theorem zip_with_vect_init : forall {A B C : Type} {n : nat}
          (v1 : Vector A n)
          (v2 : Vector B n)
          (f : A -> B -> C),
          Vector C n.
Proof.
  intros.
  destruct v1 eqn:E.
  eapply (@vect C
              (make (vect_length_int v1)
                    (f (vect_default v1) (vect_default v2)))).
  rewrite length_make.
  rewrite vect_leb_length.
  rewrite E.
  simpl.
  apply prf.
Qed.

Theorem map_vect_init : forall {A B : Type} {n : nat}
          (v : Vector A n)
          (f : A -> B),
          Vector B n.
Proof.
  intros.
  destruct v eqn:E.
  eapply (@vect B
              (make (vect_length_int v)
                    (f (vect_default v)))).
  rewrite length_make.
  rewrite vect_leb_length.
  rewrite E.
  simpl.
  apply prf.
Qed.

Definition zip_with_vect {A B C : Type} {n : nat} (v1 : Vector A n) (v2 : Vector B n) (f : A -> B -> C) : Vector C n :=
  zip_with_vect_on v1 v2 f (zip_with_vect_init v1 v2 f).

Definition map_vect {A B : Type} {n : nat} (v: Vector A n) ( f: A -> B) : Vector B n :=
  map_vect_on v f (map_vect_init v f).

Definition vect_plus {n : nat} {A: Type} `{F: Field A} (v1 : Vector A n) (v2 : Vector A n) : Vector A n :=
  zip_with_vect v1 v2 plus.

Definition vect_elem_mult {n : nat} {A : Type} `{F: Field A} (v1 : Vector A n) (v2 : Vector A n) : Vector A n :=
  zip_with_vect v1 v2 mult.

Definition vect_dot_product {n : nat} {A : Type} `{F : Field A} (v1 : Vector A n) (v2 : Vector A n) : A :=
  fold_vect (zip_with_vect v1 v2 mult) plus zero.

Definition vect_add_inv {n : nat} {A : Type} `{F : Field A} (v : Vector A n) : Vector A n :=
  map_vect v add_inv.

Definition vect_mult_inv {n : nat} {A : Type} `{F : Field A} (v : Vector A n) : Vector A n :=
  map_vect v mult_inv.

Definition vect_sub {n : nat} {A : Type} `{F : Field A} (v1 : Vector A n) (v2: Vector A n) : Vector A n :=
  vect_plus v1 (vect_add_inv v2).

Notation "< A , B >" := (vect_dot_product A B) (at level 70, no associativity).
Notation "A +@ B" := (vect_plus A B) (at level 50, left associativity).
Notation "A -@ B" := (vect_sub A B) (at level 50, left associativity).
Notation "A *@ B" := (vect_elem_mult A B) (at level 40, left associativity).
Notation "-@ A" := (vect_add_inv A) (at level 35, right associativity).

Local Open Scope int63_scope.
Lemma vect_make_make_length: forall A n i (i_bnd: i <=? max_length = true) (prf: n = BinInt.Z.to_nat(to_Z(i))) (a : A), vect_length(vect_make (make i a)) = n.
Proof.
  intros.
  rewrite prf.
  unfold vect_length.
  rewrite length_make.
  rewrite i_bnd.
  easy.
Qed.

Lemma leb_trans: forall (a b c : int), (a <=? b = true) /\ (b <=? c =true) -> (a <=? c = true).
Proof.
  intros.
  destruct H as [Hab Hbc].
  Search "lebP".
  assert (Bool.reflect (BinInt.Z.le (to_Z a) (to_Z b)) true) as Hab'.
  rewrite <- Hab.
  apply lebP.
  assert (Bool.reflect (BinInt.Z.le (to_Z b) (to_Z c)) true) as Hbc'.
  rewrite <- Hbc.
  apply lebP.
  inversion Hab'.
  inversion Hbc'.
  assert (BinInt.Z.le (to_Z a) (to_Z c)).
  eapply BinInt.Z.le_trans.
  apply H.
  apply H0.
  assert (Bool.reflect (BinInt.Z.le (to_Z a) (to_Z c)) true).
  constructor.
  assumption.
  assert (Bool.reflect (BinInt.Z.le (to_Z a) (to_Z c)) (a <=? c)).
  apply lebP.
  inversion H3.
  reflexivity.
  inversion H2.
  auto.
Qed.

Lemma posint_natint_undoes_binint : forall (i : int), (0 <=? i = true) -> nat_int(BinInt.Z.to_nat(to_Z(i))) = i.
Proof.
  Admitted.

Theorem vect_nat_int : forall {A : Type} {n : nat} (v : Vector A n), vect_length_int v = nat_int n.
Proof.
  intros.
  destruct v.
  simpl.
  subst.
  rewrite posint_natint_undoes_binint.
  - reflexivity.
  - apply arr_length_positive.
Qed.

Local Close Scope int63_scope.


(** ** Substitutivity proofs of reduction. *)

(** *** Substitutivity for the Lambda Calculus with Pairs *)

Module polyadic.
Section polyadic.
  Require Import core fintype.
  Import ScopedNotations.
  From Chapter6 Require Export utlc_pairs.

  Inductive step {m} : tm m -> tm m -> Prop :=
  | beta s t t' : t' = (s[t..]) -> step (app (lam s) t) t'
  | beta_match s1 s2 t t' : t' = (t[s1 .: s2..]) -> step (matchpair (pair s1 s2) t) t'.

  Lemma step_substitutive m m' (s: tm m) t (sigma: fin m -> tm m')  :
    step s t -> step (s[sigma]) (t[sigma]).
  Proof.
    induction 1; subst.
    - cbn. constructor. now asimpl.
    - cbn. constructor. now asimpl.
Qed.

End polyadic.
End polyadic.

(** *** Substitutivity for Call-by-Value System F *)

Module sysf_cbv.
Section sysf_cbv.
  Require Import core fintype.
  Import ScopedNotations.
  From Chapter6 Require Export sysf_cbv.

  Inductive step {m n} : tm m n -> tm m n -> Prop :=
  | beta A s v t : t = (s[ids;v..]) -> step (app (vt (lam A s)) (vt v)) t
  | Beta s A t: t = (s[A..;ids]) ->  step (tapp (vt (tlam s)) A) t.

  Lemma step_substitutive m n m' n' (s: tm m n) t sigma (tau: fin n -> vl m' n'):
    step s t -> step (s[sigma;tau]) (t[sigma;tau]).
  Proof.
    induction 1; subst.
    - cbn. constructor. now asimpl.
    - cbn. constructor. now asimpl.
  Qed.

End sysf_cbv.
End sysf_cbv.


From CoqMTL Require Export Control.Functor.

(** Haskell-style applicative functors. The intended categorical semantics
    is a (strong) monoidal functor in the category of Coq's types and
    functions (see Control.Monoidal for more).

    Currently there are 5 laws, four of which ([identity], [composition],
    [homomorphism] and [interchange]) are standard and the fifth one,
    [fmap_pure_ap], ensures compatibility with the given [Functor] instance.
    These laws are redundant: [identity] follows from [fmap_pure_ap]. *)
Class Applicative (F : Type -> Type) : Type :=
{
  is_functor :> Functor F;
  pure : forall {A : Type}, A -> F A;
  ap : forall {A B : Type}, F (A -> B) -> F A -> F B;
  identity :
    forall (A : Type) (ax : F A), ap (pure id) ax = ax;
  composition :
    forall
      (A B C : Type)
      (f : F (A -> B)) (g : F (B  -> C)) (x : F A),
        ap (ap (ap (pure compose) g) f) x = ap g (ap f x);
  homomorphism :
    forall (A B : Type) (f : A -> B) (x : A),
      ap (pure f) (pure x) = pure (f x);
  interchange :
    forall (A B : Type) (f : F (A -> B)) (x : A),
      ap f (pure x) = ap (pure (fun f => f x)) f;
  fmap_pure_ap :
    forall (A B : Type) (f : A -> B) (x : F A),
      fmap f x = ap (pure f) x;
}.

Coercion is_functor : Applicative >-> Functor.

#[global] Hint Rewrite @composition @homomorphism @fmap_pure_ap : CoqMTL.
#[global] Hint Rewrite <- @interchange : CoqMTL.

Module ApplicativeNotations.

(** A custom notation that is meant to replace both ordinary function
    application (denoted $ in Haskell) and applicative functor's [ap]
    (denoted <*> in Haskell and here too — see below). Note that these
    two coincide for the [Applicative] instance of the [Identity] functor.
    However, it is not currently used and awaits a better future. *)
Notation "f $$ x" := (ap f x)
  (left associativity, at level 40, only parsing).

Notation "f <*> x" := (ap f x)
  (left associativity, at level 40).

Notation "x <**> f" := (ap f x)
  (left associativity, at level 40, only parsing).

Definition constlA
  {F : Type -> Type} {inst : Applicative F} {A B : Type} (a : F A) (b : F B)
    : F A := const <$> a <*> b.

Definition constrA
  {F : Type -> Type} {inst : Applicative F} {A B : Type} (a : F A) (b : F B)
    : F B := (const .> fmap) id a <*> b.

(** In Haskell [constlA] and [constrA] are called <* and *> respectively and
    << and >> are their monadic counterparts. Here we get rid of the doubled
    [Applicative]/[Monad] versions and of the ugly *> and <* notations and
    use << and >> in all contexts. This has some technical consequences
    (we will need a few lemmas for dealing with [>>] in monadic contexts. *)
Infix "<<" := constlA (right associativity, at level 42).
Infix ">>" := constrA (right associativity, at level 42).

End ApplicativeNotations.

Export ApplicativeNotations.

Section DerivedApplicativeLaws.

Variables
  (F : Type -> Type)
  (inst : Applicative F).

Lemma fmap_pure :
  forall (A B : Type) (f : A -> B) (x : A),
    fmap f (pure x) = pure (f x).
Proof. hs. Qed.

Lemma constrA_pure_l :
  forall (A B : Type) (a : A) (fb : F B),
    pure a >> fb = fb.
Proof.
  intros. unfold constrA, compose.
  rewrite fmap_pure_ap, homomorphism, identity.
  reflexivity.
Qed.

Hint Rewrite @fmap_pure constrA_pure_l : CoqMTL.

End DerivedApplicativeLaws.

(** Utility functions for applicative functors. In Haskell, most of these
    require the [F] to be a monad, but in this library they require only
    an [Applicative]. They are consistently named with "A" at the end and
    the ones with "M" at the end you can find in Haskell don't exist here. *)
Section ApplicativeFuns1.

Variable F : Type -> Type.
Variable inst : Applicative F.
Variables A B C D E : Type.

Definition liftA2
  (f : A -> B -> C)
  (fa : F A) (fb : F B) : F C :=
    pure f <*> fa <*> fb.

Definition liftA3
  (f : A -> B -> C -> D)
  (fa : F A) (fb : F B) (fc : F C) : F D :=
    pure f <*> fa <*> fb <*> fc.

Definition liftA4
  (f : A -> B -> C -> D -> E)
  (fa : F A) (fb : F B) (fc : F C) (fd : F D) : F E :=
    pure f <*> fa <*> fb <*> fc <*> fd.

Fixpoint filterA (p : A -> F bool) (la : list A) : F (list A) :=
match la with
| [] => pure []
| h :: t =>
    let f :=
      fmap (fun b : bool => if b then (cons h) else id) (p h)
    in f <*> filterA p t
end.

Fixpoint sequenceA (lma : list (F A)) : F (list A) :=
match lma with
| [] => pure []
| h :: t => cons <$> h <*> sequenceA t
end.

Fixpoint replicateA (n : nat) (x : F A) : F (list A) :=
match n with
| 0 => pure []
| S n' => cons <$> x <*> replicateA n' x
end.

Fixpoint zipWithA (f : A -> B -> F C) (la : list A) (lb : list B)
    : F (list C) :=
match la, lb with
| [], _ => pure []
| _, [] => pure []
| ha :: ta, hb :: tb =>
    cons <$> f ha hb <*> zipWithA f ta tb
end.

Definition when (cond : bool) (a : F unit) : F unit :=
  if cond then a else pure tt.

Definition unless (cond : bool) (a : F unit) : F unit :=
  if cond then pure tt else a.

End ApplicativeFuns1.

Arguments liftA2 {F inst A B C} _ _ _.
Arguments liftA3 {F inst A B C D} _ _ _ _.
Arguments liftA4 {F inst A B C D E} _ _ _ _ _.

Arguments filterA {F inst A} _ _.
Arguments sequenceA {F inst A} _.
Arguments replicateA {F inst A} _ _.
Arguments zipWithA {F inst A B C} _ _ _.
Arguments when {F inst} _ _.
Arguments unless {F inst} _ _.

Section ApplicativeFuns2.

Variable F : Type -> Type.
Variable inst : Applicative F.
Variables A B C D E : Type.

Definition mapA (f : A -> F B) (la : list A) : F (list B) :=
  sequenceA (map f la).

Definition forA (la : list A) (f : A -> F B) : F (list B) :=
  mapA f la.

End ApplicativeFuns2.


From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality.

Lemma Zge_refl: forall (n: Z), (n >= n)%Z.
intros. lia. Qed.

Lemma ge_refl: forall (n: nat), n >= n.
intros. lia. Qed.

Lemma ge_diff: forall {n m : nat}, n >= m -> exists k, n = m + k.
Proof.
  induction 1.
  - exists 0. lia.
  - destruct IHle. exists (S x). lia.
Qed.

Example ge_diff_example1: exists k, 7 = 3 + k.
Proof.
  assert (Hge: 7 >= 3) by omega.
  destruct (ge_diff Hge) as [k Hk].
  exists k; assumption.
Qed.

(* COMPCERT *)
Ltac inv H := inversion H; clear H; subst.

Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q.
Proof. auto. Qed.

Ltac exploit x :=
    refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _) _)
 || refine (modusponens _ _ (x _ _) _)
 || refine (modusponens _ _ (x _) _).


(** This module defines the logical relation (cf. Figure 7 in the
paper). *)

From Rattus Require Export Reduction.

From Rattus Require Import Tactics.

From Coq Require Import Arith Lia Program.
From Equations Require Import Equations.

Fixpoint tsize (A : type) : nat :=
  match A with
  | Unit => 1
  | Nat => 1
  | TypeVar _ => 1
  | Arrow B C => S (tsize B + tsize C)
  | Plus B C => S (tsize B + tsize C)
  | Times B C => S (tsize B + tsize C)
  | Delay B => 1
  | Box B => S (tsize B)
  | Fix B => S (tsize B)
  end.

Lemma tsize_subst i A B :  tsize (tsubst i A (Delay B)) = tsize A.
Proof.
  generalize dependent i. generalize dependent B. induction A;intros;simpl; eauto.
  - destruct (i0 =? i); eauto.
Qed.

Equations vrel (nu : nat) (A : type) : heapseq -> store ->  term -> Prop
  by wf (nu ,tsize A)  :=
vrel nu (Plus A B) Hs s t :=
    (exists v, t = in1 v /\ vrel nu A Hs s v)
    \/ (exists v, t = in2 v /\ vrel nu B Hs s v);
vrel nu (Times A B) Hs s t :=
    exists v1 v2, t = pair v1 v2 /\ vrel nu A Hs s v1
                  /\ vrel nu B Hs s v2;
                    vrel nu (Arrow A B) Hs s t :=
      exists t', t = abs t' /\
                 forall d, d <= nu -> forall Hs' s', heapseq_le Hs Hs' -> store_le (gc s) s' -> closed_heapseq Hs' -> closed_store s' ->
                                                     forall v, vrel (nu - d) A  Hs' s' v -> closed_term v ->
      forall s'', tick_le s' s'' -> closed_store s'' ->
      exists w s''', {sub_term t' v, s''} ⇓ {w, s'''} /\
                           vrel (nu-d) B Hs' s''' w;

vrel 0 (Delay B) Hs s t := exists l, t = ref l;
vrel (S nu) (Delay B) Hs s t :=
         exists l , t = ref l /\
                    exists u, store_mapsto l u s /\
                    forall s', tick_le (store_tick s (hd Hs)) s' -> closed_store s' ->
                               exists w s'', {u, s'} ⇓ {w, s''} /\ vrel nu B (tl Hs) s'' w;
vrel nu (Fix B) Hs s t := exists v, t = into v /\
                                   vrel nu (tsubst 0 B (Delay (Fix B))) Hs s v;
vrel nu (Box B) Hs s t := exists t', t = box t' /\ forall Hs', closed_heapseq Hs' ->
   forall s', closed_store s' ->
      exists w s'', {t', s'} ⇓ {w, s''} /\
                     vrel nu B Hs' s'' w;
vrel nu Unit Hs s t := t = unit;
vrel nu Nat Hs s t := exists n, t = natlit n;
vrel _ _ _ _ _ := False
.

Next Obligation.
  apply Subterm.right_lex. lia.
Qed.
Next Obligation.
  apply Subterm.right_lex. lia.
Qed.
Next Obligation.
  apply Subterm.right_lex. lia.
Qed.
Next Obligation.
  apply Subterm.right_lex. lia.
Qed.
Next Obligation.
  destruct d.
  + rewrite Nat.sub_0_r. apply Subterm.right_lex. lia.
  + destruct nu.
  - apply Subterm.right_lex. lia.
  - apply Subterm.left_lex. lia.
Qed.
Next Obligation.
  destruct d.
  + rewrite Nat.sub_0_r. apply Subterm.right_lex. lia.
  + destruct nu.
  - apply Subterm.right_lex. lia.
  - apply Subterm.left_lex. lia.
Qed.

Next Obligation.
  rewrite tsize_subst. apply Subterm.right_lex. lia.
Qed.

Definition trel (nu : nat) (A : type) (Hs : heapseq) (s : store) (t : term) : Prop :=
  forall s', tick_le s s' -> closed_store s' -> exists v s'',
                     {t, s'} ⇓ {v, s''} /\ vrel nu A Hs s'' v.

(* Below we give characterisations of vrel so that we don't need to
   work with vreln. *)

Lemma vrel_arrow A B nu Hs s t :
  vrel nu (Arrow A B) Hs s t <-> (exists u, t = abs u /\
     forall nu' Hs' s', nu' <= nu -> heapseq_le Hs Hs' -> store_le (gc s) s' -> closed_heapseq Hs'
                    -> closed_store s' ->
                    forall v, vrel nu' A Hs' s' v -> closed_term v -> trel nu' B Hs' s' (sub_term u v)).

Proof.
  simp vrel. split;intros.
  - autodest. exists x. split. reflexivity. intros.
    assert (nu - nu' <= nu) as D by lia.
    assert (nu - (nu - nu') = nu') as N by lia. rewrite <- N in H5.
    unfold trel. intros.
    remember (H0 (nu - nu') D Hs' s' H1 H2 H3 H4 v H5 H6 s'0 H7 H8) as As.
    clear HeqAs. autodest. exists x0. exists x1. subst. rewrite N in *. eauto.
  - autodest. exists x. split. reflexivity. intros.
    assert (nu - d <= nu) as D by lia.
    assert (nu - (nu - d) = d) as N by lia.
    unfold trel. intros.
    remember (H0 (nu - d) Hs' s' D H1 H2 H3 H4 v H5 H6 s'' H7 H8) as As.
    clear HeqAs. autodest.
Qed.

Lemma vrel_plus A B nu Hs s t : vrel nu (Plus A B) Hs s t <->
                               (exists v, t = in1 v /\ vrel nu A Hs s v)
                               \/ (exists v, t = in2 v /\ vrel nu B Hs s v).
Proof.
  simp vrel. tauto.
Qed.

Lemma vrel_times A B nu Hs s t : vrel nu (Times A B) Hs s t <->
                                exists v1 v2, t = pair v1 v2 /\ vrel nu A Hs s v1
                                       /\ vrel nu B Hs s v2.
Proof.
    simp vrel. tauto.
Qed.

Lemma vrel_mu A nu Hs s t : vrel nu (Fix A) Hs s t <->
                           exists v, t = into v /\ vrel nu (tsubst 0 A (Delay (Fix A))) Hs s v.
Proof.
    simp vrel. tauto.
Qed.

Lemma vrel_val : forall A nu Hs s t, vrel nu A Hs s t -> isvalue t.
Proof.
  intro A. remember (tsize A) as N. generalize dependent A.
  induction (lt_wf N) as [N _ IH]. intro A.
  destruct A;intros; simp vrel in *; subst; autodest.
  - constructor.
    + eapply IH in H0;eauto. simpl. lia.
    + eapply IH in H1;eauto. simpl. lia.
  - constructor. eapply IH in H0;eauto. simpl. lia.
  - constructor. eapply IH in H0;eauto. simpl. lia.
  - destruct nu; simp vrel in *; autodest.
  - constructor. eapply IH in H0;eauto. simpl. rewrite tsize_subst. lia.
Qed.

Lemma vrel_delay A nu Hs s t :
  vrel (S nu) (Delay A) Hs s t <->
  exists l u, t = ref l /\ store_mapsto l u s /\ trel nu A (tl Hs) (store_tick s (hd Hs)) u.
Proof.
  simp vrel. split;intros;autodest.
Qed.

Lemma vrel_box A nu Hs s t :
  vrel nu (Box A) Hs s t <-> (exists t', t = box t' /\
                          forall Hs', closed_heapseq Hs' -> trel nu A Hs' (None, heap_empty) t').
Proof.
  simp vrel. split;simpl;intros;autodest.
  - exists x. split. auto. unfold trel. intros.
    remember (H0 Hs' H s' H2) as T. autodest.
  - exists x. split. auto. unfold trel in *. intros.
    remember (H0 Hs' H s' (tick_le_empty s') H1) as T. autodest.
Qed.

Lemma vrel_unit Hs nu s t :
  vrel nu Unit Hs s t <-> t = unit.
Proof.
  simp vrel. auto.
Qed.

Lemma vrel_nat Hs nu s t :
  vrel nu Nat Hs s t <-> exists n, t = natlit n.
Proof.
  simp vrel. auto.
Qed.

Lemma vrel_var nu i Hs s t :
  vrel nu (TypeVar i) Hs s t <-> False.
Proof.
  simp vrel. auto.
Qed.

Lemma vrel_delay_nil A Hs s t :
  vrel 0 (Delay A) Hs s t <-> exists l, t = ref l.
Proof.
  simp vrel. auto.
Qed .

Hint Rewrite vrel_delay_nil vrel_delay vrel_var vrel_nat vrel_unit vrel_times vrel_plus vrel_arrow vrel_box vrel_mu : vrel'.

Import ListNotations.

Inductive crel : forall {ty}, nat -> ctx ty -> heapseq -> store -> sub -> Prop :=
| crel_empty nu Hs s : crel nu ctx_empty Hs s nil
| crel_var nu ty (G : ctx ty) Hs s g A t : vrel nu A Hs s t -> crel nu G Hs s g ->
                           crel nu (ctx_var G A) Hs s (Some t :: g)
| crel_skip nu ty (G : ctx ty) Hs s g : crel nu G Hs s g ->
                              crel nu (ctx_skip G) Hs s (None :: g)
| crel_tick nu G Hs g hn h:
    crel (S nu) G (cons h Hs) (None, hn) g ->
    crel nu (ctx_tick G) Hs (Some hn, h) g
.

#[global] Hint Constructors crel : core.


 Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.
Open Scope list_scope.

(* ErrorNat encapsulates the constructor error_nat
   which is useful in the case of arithmetic operations like division by 0*)

Inductive ErrorNat :=
  | error_nat : ErrorNat
  | num : nat -> ErrorNat.

Inductive ErrorBool :=
  | error_bool : ErrorBool
  | boolean : bool -> ErrorBool.

Coercion num: nat >-> ErrorNat.
Coercion boolean: bool >-> ErrorBool.

(* A general type which includes all kind of types *)
Inductive Result :=
  | err_undecl : Result
  | err_assign : Result
  | default : Result
  | res_nat : ErrorNat -> Result
  | res_bool : ErrorBool -> Result
  | code : Result.

Scheme Equality for Result.

(* An environment which maps variable names (strings) to the Result type  *)
Definition Env := string -> Result.
(* Initial environment *)
Definition env : Env := fun x => err_undecl.

(* Section for AExp *)
Inductive AExp :=
  | avar: string -> AExp (* Var ~> string *)
  | anum: ErrorNat -> AExp
  | aplus: AExp -> AExp -> AExp
  | asub: AExp -> AExp -> AExp
  | amul: AExp -> AExp -> AExp
  | adiv: AExp -> AExp -> AExp
  | amod: AExp -> AExp -> AExp.

Coercion anum: ErrorNat >-> AExp.
Coercion avar: string >-> AExp. (* Var ~> string *)

Inductive BreakContinue :=
  | break : BreakContinue
  | defaultS : BreakContinue
  | continue : BreakContinue.

(* Section for BExp *)
Inductive BExp :=
  | berror
  | btrue
  | bfalse
  | bvar: string -> BExp
  | blt : AExp -> AExp -> BExp
  | bnot : BExp -> BExp
  | band : BExp -> BExp -> BExp
  | bor : BExp -> BExp -> BExp.

Inductive LstElement :=
  | natElem: AExp -> LstElement
  | stringElem: string -> LstElement
  | boolElem: BExp -> LstElement
  | lstSequence : LstElement -> LstElement -> LstElement.

Coercion natElem: AExp >-> LstElement.
Coercion stringElem : string >-> LstElement.
Coercion boolElem : BExp >-> LstElement.

(*
Inductive Vector :=
  | vector_decl : string -> LstElement -> Vector
  | vector_assign : string -> LstElement -> Vector.

Inductive Define :=
  | define_nat : AExp -> string -> Define
  | define_string : string -> string -> Define.
*)

Inductive FuncAExp :=
  | amax: AExp -> AExp -> FuncAExp
  | amin: AExp -> AExp -> FuncAExp
  | apow: AExp -> AExp -> FuncAExp.

Inductive SwitchValue :=
  | nCase : AExp -> SwitchValue
  | sCase : string -> SwitchValue
  | dCase : BreakContinue -> SwitchValue.

Coercion nCase: AExp >-> SwitchValue.
Coercion sCase : string >-> SwitchValue.
Coercion dCase : BreakContinue >-> SwitchValue.

(* Section for Statements *)
Inductive Stmt :=
  | nat_decl: string -> AExp -> Stmt
  | bool_decl: string -> BExp -> Stmt
  | nat_assign : string -> AExp -> Stmt
  | bool_assign : string -> BExp -> Stmt
  | sequence : Stmt -> Stmt -> Stmt
  | while : BExp -> Stmt -> Stmt
  | ifthenelse : BExp -> Stmt -> Stmt -> Stmt
  | ifthen : BExp -> Stmt -> Stmt
  | switchSeq : SwitchValue -> Stmt -> BreakContinue -> Stmt
  | switchNat : AExp -> Stmt -> Stmt
  | switchString : string -> Stmt -> Stmt
  | fordo : Stmt -> BExp -> Stmt -> Stmt -> Stmt
  | define_nat : AExp -> string -> Stmt
  | define_string : string -> string -> Stmt
  | vector_decl : string -> LstElement -> Stmt
  | vector_assign : string -> LstElement -> Stmt
  | break_loop : Stmt.

(*  SEMANTICA   *)

Definition plus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 + v2)
    end.

Definition sub_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num n1, num n2 => if Nat.ltb n1 n2
                        then error_nat
                        else num (n1 - n2)
    end.

Definition mul_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 * v2)
    end.

Definition div_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, num 0 => error_nat
    | num v1, num v2 => num (Nat.div v1 v2)
    end.

Definition mod_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, num 0 => error_nat
    | num v1, num v2 => num (v1 - v2 * (Nat.div v1 v2))
    end.

Definition lt_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => boolean (Nat.ltb v1 v2)
    end.

Definition not_ErrorBool (n :ErrorBool) : ErrorBool :=
  match n with
    | error_bool => error_bool
    | boolean v => boolean (negb v)
    end.

Definition and_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean (andb v1 v2)
    end.

Definition or_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean (orb v1 v2)
    end.

Definition max_fun (n1 n2 : AExp) : ErrorNat :=
  match n1, n2 with
    | num a, num b => if Nat.ltb a b
                      then b
                      else a
    | _, _ => error_nat
end.

Definition min_fun (n1 n2 : AExp) : ErrorNat :=
  match n1, n2 with
    | num a, num b => if Nat.ltb a b
                      then a
                      else b
    | _, _ => error_nat
end.

Definition check_eq_over_types (t1 : Result)(t2 : Result) : bool :=
  match t1 with
  | err_undecl => match t2 with
                   | err_undecl => true
                   | _ => false
                   end
  | err_assign => match t2 with
                   | err_assign => true
                   | _ => false
                   end
  | default => match t2 with
                   | default => true
                   | _ => false
                   end
  | code => match t2 with
                   | code => true
                   | _ => false
                   end
  | res_nat ErrorNat => match t2 with
                   | res_nat ErrorNat => true
                   | _ => false
                   end
  | res_bool ErrorBool => match t2 with
                   | res_bool ErrorBool => true
                   | _ => false
                   end
  end.

Inductive Mem :=
  | mem_default : Mem
  | offset : nat -> Mem.

Scheme Equality for Mem.

Definition EnvM := string -> Mem.
Definition MemLayer := Mem -> Result.
Definition Stack := list Env.

Inductive Config :=
  | config : nat -> Env -> MemLayer -> Stack -> Config.

Definition update_env (env: EnvM) (x: string) (n: Mem) : EnvM :=
  fun y =>
      if (andb (string_beq x y ) (Mem_beq (env y) mem_default))
      then
        n
      else
        (env y).

Definition env1 : EnvM := fun x => mem_default.

Definition update_mem (mem : MemLayer) (env : EnvM) (x : string) (type : Mem) (v : Result) : MemLayer :=
  fun y =>
    if (Mem_beq y type)
      then
        if (Mem_beq (env x) mem_default)
        then err_undecl
        else
          if (Mem_beq (env x) y)
          then
            if (check_eq_over_types (mem y) v)
            then v
            else err_assign
          else mem y
      else mem y.

(*Predefined functions.*)
Notation "'fMaxim' A ~ B" := (max_fun A B) (at level 60).
Notation "'fMinim' A ~ B" := (min_fun A B) (at level 60).
Notation "'fPow' A ~ B" := (apow A B) (at level 60).

(*Break & Continue*)
Notation "Break!" := (break) (at level 50).
Notation "Default!" := (defaultS) (at level 50).
Notation "Continue!" := (continue) (at level 50).
Notation "'BreakLoop'" := (break_loop) (at level 40).
(*Define*)
Notation "A #defineNat B" := (define_nat A B) (at level 50).
Notation "A #defineString B" := (define_string A B) (at level 50).

(*Declarations*)
Notation "'iNat' X ::= A" := (nat_decl X A)(at level 90).
Notation "'iBool' X ::= A" := (bool_decl X A)(at level 90).
Notation "'iVector' X ::= A " := (vector_decl X A)(at level 90).

(*Assigns*)
Notation "X :n= A" := (nat_assign X A)(at level 90).
Notation "X :b= A" := (bool_assign X A)(at level 90).
Notation "X :v= A" := (vector_assign X A)(at level 90).

Notation "S1 ;; S2" := (sequence S1 S2) (at level 93, right associativity).
Notation "S1 .-> S2" := (lstSequence S1 S2) (at level 93, right associativity).

(*Notation for *)
Notation "'fors' ( A ~ B ~ C ) '{' S '}'" := (A ;; while B ( S ;; C )) (at level 97).
Notation "'Ifs' '(' A ')' '{' B '}'" := (ifthen A B) (at level 70).
Notation "'Ifd' '(' A ')' '{' B '}' 'Else' '{' C '}'" := (ifthenelse A B C) (at level 70).
Notation "'While' '(' A ')' '{' B '}'" := (while A B) (at level 90).
(*Switch*)

Notation "'SwitchNat' ( A ) { S }" := (switchNat A S) (at level 80).
Notation "'case:' A --> B C" := (switchSeq A B C)(at level 80).

Notation "'SwitchString' ( A ) { S }" := (switchString A S) (at level 80).

(* Notations used for arithmetic operations *)
Notation "A +' B" := (aplus A B)(at level 50, left associativity).
Notation "A -' B" := (asub A B)(at level 50, left associativity).
Notation "A *' B" := (amul A B)(at level 48, left associativity).
Notation "A /' B" := (adiv A B)(at level 48, left associativity).
Notation "A %' B" := (amod A B)(at level 45, left associativity)  .

(* Notations used for boolean operations *)
Notation "A <' B" := (blt A B) (at level 70).
Notation "!' A" := (bnot A)(at level 51, left associativity).
Notation "A &&' B" := (band A B)(at level 52, left associativity).
Notation "A ||' B" := (bor A B)(at level 53, left associativity).

(* Notatations used for the Big-Step semantics *)
Reserved Notation "A =[ S ]=> N" (at level 60).
Reserved Notation "B ={ S }=> B'" (at level 70).

(* Big-Step semantics for arithmetic operations *)
Inductive aeval : AExp -> Env -> ErrorNat -> Prop :=
| const : forall n sigma, anum n =[ sigma ]=> n
| var : forall v sigma, avar v =[ sigma ]=>  match (sigma v) with
                                              | res_nat x => x
                                              | _ => error_nat
                                              end
| add : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (plus_ErrorNat i1 i2) ->
    a1 +' a2 =[sigma]=> n
| times : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (mul_ErrorNat i1 i2) ->
    a1 *' a2 =[sigma]=> n
| substract : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (sub_ErrorNat i1 i2) ->
    a1 -' a2 =[sigma]=> n
| division : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (div_ErrorNat  i1 i2) ->
    a1 /' a2 =[sigma]=> n
| modulo : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (mod_ErrorNat i1 i2) ->
    a1 %' a2 =[sigma]=> n
where "a =[ sigma ]=> n" := (aeval a sigma n).

(*
Reserved Notation "A =[ S ]=> N" (at level 60).
Inductive feval : FuncAExp -> Env -> AExp -> Prop :=
  | f_max : forall a1 a2 i1 i2 sigma,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    if(i1 >' i2) then (amax a1 a2) =[ sigma ]=> i1
    else amax(a1 a2) =[ sigma ]=> i2
  | f_min : forall a1 a2 i1 i2 sigma,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    if(i1 <' i2) then (amin a1 a2) =[ sigma ]=> i1
    else amin(a1 a2) =[ sigma ]=> i2
where "F =[ sigma ] => A" := (feval a sigma n).
*)

Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval : BExp -> Env -> ErrorBool -> Prop :=
| b_error: forall sigma, berror  ={ sigma }=> error_bool
| b_true : forall sigma, btrue ={ sigma }=> true
| b_false : forall sigma, bfalse ={ sigma }=> false
| b_var : forall v sigma, bvar v ={ sigma }=>  match (sigma v) with
                                                | res_bool x => x
                                                | _ => error_bool
                                               end
| b_lessthan : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = (lt_ErrorBool i1 i2) ->
    a1 <' a2 ={ sigma }=> b
| b_not : forall a1 i1 sigma b,
    a1 ={ sigma }=> i1 ->
    b = (not_ErrorBool i1) ->
    !'a1 ={ sigma }=> b
| b_and : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (and_ErrorBool i1 i2) ->
    (a1 &&' a2) ={ sigma }=> b
| b_or : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (or_ErrorBool i1 i2) ->
    (a1 ||' a2) ={ sigma }=> b
where "B ={ S }=> B'" := (beval B S B').

Reserved Notation "S -{ Sigma }-> Sigma'" (at level 60).

Definition update (env : Env) (x : string) (v : Result) : Env :=
  fun y =>
    if (eqb y x)
    then v
    else (env y).

Notation "S [ V /' X ]" := (update S X V) (at level 0).

Inductive eval : Stmt -> Env -> Env -> Prop :=
| e_nat_decl: forall a i x sigma sigma',
   a =[ sigma ]=> i ->
   sigma' = (update sigma x (res_nat i)) ->
   (iNat x ::= a) -{ sigma }-> sigma'
| e_nat_assign: forall a i x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x (res_nat i)) ->
    (x :n= a) -{ sigma }-> sigma'
| e_bool_decl: forall a i x sigma sigma',
   a ={ sigma }=> i ->
   sigma' = (update sigma x (res_bool i)) ->
   (x :b= a) -{ sigma }-> sigma'
| e_bool_assign: forall a i x sigma sigma',
    a ={ sigma }=> i ->
    sigma' = (update sigma x (res_bool i)) ->
    (x :b= a) -{ sigma }-> sigma'
| e_seq : forall s1 s2 sigma sigma1 sigma2,
    s1 -{ sigma }-> sigma1 ->
    s2 -{ sigma1 }-> sigma2 ->
    (s1 ;; s2) -{ sigma }-> sigma2
| e_if_then : forall b s sigma,
    ifthen b s -{ sigma }-> sigma
| e_if_then_elsetrue : forall b s1 s2 sigma sigma',
    b ={ sigma }=> true ->
    s1 -{ sigma }-> sigma' ->
    ifthenelse b s1 s2 -{ sigma }-> sigma'
| e_if_then_elsefalse : forall b s1 s2 sigma sigma',
    b ={ sigma }=> false ->
    s2 -{ sigma }-> sigma' ->
    ifthenelse b s1 s2 -{ sigma }-> sigma'
| e_whilefalse : forall b s sigma,
    b ={ sigma }=> false ->
    while b s -{ sigma }-> sigma
| e_whiletrue : forall b s sigma sigma',
    b ={ sigma }=> true ->
    (s ;; while b s) -{ sigma }-> sigma' ->
    while b s -{ sigma }-> sigma'
| e_forfalse : forall e1 e2 e3 s sigma,
    e2 ={ sigma }=> false ->
    fordo e1 e2 e3 s -{ sigma }-> sigma
| e_fortrue : forall e1 e2 e3 s sigma sigma',
    e2 ={ sigma }=> true ->
    (e1 ;; while e2 (s ;; e3)) -{ sigma }-> sigma' ->
    fordo e1 e2 e3 s -{ sigma }-> sigma'
| e_break_loop : forall stmt sigma,
    stmt -{ sigma }-> match stmt with
                        | while b s => sigma
                        | _ => sigma
                       end
where "s -{ sigma }-> sigma'" := (eval s sigma sigma').

Definition Exemplu1 :=
  15 #defineNat "PunctajMaxim";;
  "PanzariuAdi" #defineString "nume";;

  iNat "age" ::= 21 ;;
  iBool "major" ::= btrue ;;
  iVector "note" ::= (6 .-> 7 .-> 8 .-> 9 .-> 10) ;;
  iVector "prieteni" ::= ("Andrei" .-> "Emi" .-> "Bogdan") ;;

  iNat "contor" ::= 0 ;;

  Ifs ( "contor" <' 5) {
    "contor" :n= 6
  }
  ;;
  While( "contor" <' 100) {
    "contor" :n= "contor" +' 1 ;;
    BreakLoop
  }
  ;;
  SwitchNat (2) {
        case: 1 -->
          "n1" :n= 1
        Break!
        ;;
        case: 2 -->
          "n1" :n= 2
        Break!
        ;;
        case: Default! -->
          "n1" :n= 3;;
          "n2" :n= 5
        Break!
  }.

Example Exemplu2 :
  exists sigma',
  (
    iNat "i" ::= 0;;
    While ("i" <' 20)
    {
      "i" :n= ("i" +' 2);;
      BreakLoop
    }
  )-{ env }-> sigma'   /\ sigma' "i" = res_nat 2.

Proof.
 eexists.
 split.
  - eapply e_seq; eauto.
    + eapply e_nat_decl. eauto.


Require Import Hask.Ltac.
Require Import Hask.Data.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Class Foldable (t : Type -> Type) := {
  foldr : forall a b, (a -> b -> b) -> b -> t a -> b
}.

Arguments foldr {t _ a b} _ _ _.

Axiom foldr_parametricity :
  forall `{Foldable t} `{Functor t}
         A B (f : A -> B -> B) (u : B)
         A' B' (g : A' -> B' -> B') (u' : B')
         (a : A -> A') (b : B -> B'),
    b u = u'
      -> (forall x y, b (f x y) = g (a x) (b y))
      -> b \o @foldr t _ A B f u = @foldr t _ A' B' g u' \o fmap a.

Import FunctorLaws.

Theorem foldr_fmap_fusion `{Foldable t} `{FunctorLaws t} :
  forall A B (f : A -> B -> B) C (g : C -> A) (z : B) (xs : t C),
    foldr f z (fmap g xs) = foldr (f \o g) z xs.
Proof.
  intros.
  pose proof (foldr_parametricity C B (f \o g) z A B f z g id
                                  eq_refl (fun _ _ => eq_refl)).
  replace (foldr f z (fmap[ t] g xs))
     with ((foldr f z \o fmap[ t] g) xs) by trivial.
  rewrite <- H2.
  reflexivity.
Qed.


Require Import QWIRE.Prelim.
Require Import VectorStates.
Require Export ConnectivityGraph.
Require Export StandardGateSet.
From Coq Require Import Lists.List.

Local Close Scope R_scope.
Local Close Scope Q_scope.

(** Definition of layouts for mapping. **)

(* We will represent a layout with two functions: one that maps from
   logical qubits to physcial qubits, and one that maps from physical
   qubits to logical qubits. We use two functions instead of one to
   make lookup in either direction efficient. However, this requires
   some extra machinery to describe well-formed layouts.

   In general, the logical qubit register may be smaller than the physical
   qubit register, so it could also make sense to have the type of phys2log
   be (nat -> option nat). However, it makes the proof easier to use a pair
   of (nat -> nat) functions. This just means that we need to associate
   every "unused" physical qubit with a fresh logical qubit.
 *)
Definition qmap (dim : nat) : Type := (nat -> nat) * (nat -> nat).

Definition log2phys {dim} (m : qmap dim) q :=
  match m with
  | (m, _) => m q
  end.

Definition phys2log {dim} (m : qmap dim) q :=
  match m with
  | (_, m) => m q
  end.

(*********** begin mapper via matching *************)
Definition matching : Type := list (nat*nat).
Definition layer : Type := list (nat*nat).

Definition fst_tuple (l : layer) : list nat := map fst l.
Definition snd_tuple (l : layer) : list nat := map snd l.
Fixpoint elem_in (a : nat)(l : list nat) : bool :=
  match l with
  | [] => false
  | h :: t => if a =? h then true else elem_in a t
  end.

Fixpoint first_layer {dim} (l : standard_ucom_l dim) (la : layer): layer :=
  match l with
  | [] => la
  | App2 U_CX n1 n2 :: t => if (orb (elem_in n1 (fst_tuple la)) (elem_in n2 (snd_tuple la))) then la
                          else (first_layer t ((n1, n2)::la))
  | _ :: t => first_layer t la
  end.

Fixpoint qmapper dim (mat : matching) (la : layer) : qmap dim :=
  match la with
  | [] =>
    let m1 q := 0 in
    let m2 q := 0 in
    (m1, m2)
  | [(q1, q2)] =>
    match (hd (0,0) mat) with
    | (v1, v2) =>
      let m1 q := if q =? q1 then v1 else v2 in
      let m2 q := if q =? v1 then q1 else q2 in
      (m1, m2)
    end
  | ((q1, q2) :: t) =>
    match (qmapper dim (tl mat) t) with
    | (m1, m2) =>
      match (hd (0,0) mat) with
      | (v1, v2) =>
        let m1' q := if q =? q1 then v1
                     else if q =? q2 then v2
                          else m1 q in
        let m2' q := if q =? v1 then q1
                     else if q =? v2 then q2
                          else m2 q in
        (m1', m2')
      end
    end
  end.

Definition initial_qmap {dim} (l : standard_ucom_l dim) (mat : matching) : qmap dim :=
  qmapper dim mat (first_layer l []).

(****************end of mapper via matching******************)

(* Swap the logical qubits associated with physical qubits phys1 and phys2. *)
Definition swap_in_map {dim} (m : qmap dim) phys1 phys2 : qmap dim :=
  match m with
  | (m1, m2) =>
      let log1 := m2 phys1 in
      let log2 := m2 phys2 in
      let m1' q := if q =? log1 then phys2
                   else if q =? log2 then phys1
                   else m1 q in
      let m2' q := if q =? phys1 then log2
                   else if q =? phys2 then log1
                   else m2 q in
      (m1', m2')
  end.

Definition layout_well_formed dim (m : qmap dim) :=
  forall x, x < dim ->
    log2phys m x < dim /\
    phys2log m x < dim /\
    phys2log m (log2phys m x) = x /\
    log2phys m (phys2log m x) = x.

Fixpoint layout_well_formed_b' dim n (m : qmap dim) :=
  match n with
  | O => true
  | S n' =>
      (log2phys m n' <? dim) &&
      (phys2log m n' <? dim) &&
      (phys2log m (log2phys m n') =? n') &&
      (log2phys m (phys2log m n') =? n') &&
      (layout_well_formed_b' dim n' m)
  end.
Definition layout_well_formed_b dim (m : qmap dim) :=
  layout_well_formed_b' dim dim m.

Lemma layout_well_formed_b_equiv : forall dim (m : qmap dim),
  layout_well_formed_b dim m = true -> layout_well_formed dim m.
Proof.
  intros.
  assert (forall x, layout_well_formed_b' dim x m = true ->
          forall x0, x0 < x -> log2phys m x0 < dim /\
                         phys2log m x0 < dim /\
                         phys2log m (log2phys m x0) = x0 /\
                         log2phys m (phys2log m x0) = x0).
  { intros x Hx x0 Hx0.
    induction x.
    lia.
    simpl in Hx.
    apply andb_prop in Hx as [Hx Hx5].
    apply andb_prop in Hx as [Hx Hx4].
    apply andb_prop in Hx as [Hx Hx3].
    apply andb_prop in Hx as [Hx1 Hx2].
    apply Nat.ltb_lt in Hx1.
    apply Nat.ltb_lt in Hx2.
    apply beq_nat_true in Hx3.
    apply beq_nat_true in Hx4.
    specialize (IHx Hx5).
    bdestruct (x0 =? x).
    subst.
    repeat split; assumption.
    apply IHx.
    lia. }
  specialize (H0 dim H).
  assumption.
Qed.

Lemma well_formed_log2phys_bij : forall {dim} (m : qmap dim),
  layout_well_formed dim m ->
  finite_bijection dim (log2phys m).
Proof.
  intros dim m WF.
  exists (phys2log m).
  apply WF.
Qed.

Lemma well_formed_phys2log_bij : forall {dim} (m : qmap dim),
  layout_well_formed dim m ->
  finite_bijection dim (phys2log m).
Proof.
  intros dim m WF.
  exists (log2phys m).
  intros x Hx.
  specialize (WF x Hx) as [? [? [? ?]]].
  auto.
Qed.

Lemma swap_in_map_well_formed : forall {dim} (m : qmap dim) n1 n2,
  n1 < dim -> n2 < dim -> layout_well_formed dim m ->
  layout_well_formed dim (swap_in_map m n1 n2).
Proof.
  unfold layout_well_formed, swap_in_map, log2phys, phys2log.
  intros dim m n1 n2 Hn1 Hn2.
  destruct m as [m1 m2].
  intros H x Hx.
  destruct (H x Hx) as [? [? [? ?]]].
  destruct (H n1 Hn1) as [? [? [? ?]]].
  destruct (H n2 Hn2) as [? [? [? ?]]].
  repeat split.
  - bdestruct_all; auto.
  - bdestruct_all; auto.
  - bdestruct (x =? m2 n1); bdestruct (x =? m2 n2); subst; auto.
    all: bdestruct_all; subst; auto.
    symmetry in H2. contradiction.
    symmetry in H2. contradiction.
  - bdestruct (x =? n1); bdestruct (x =? n2); bdestruct_all; subst; auto.
    assert (m1 (m2 n2) = m1 (m2 n1)) by auto.
    rewrite H3, H11 in H12.
    symmetry in H12. contradiction.
    assert (m1 (m2 x) = m1 (m2 n1)) by auto.
    rewrite H3, H7 in H15.
    contradiction.
    assert (m1 (m2 x) = m1 (m2 n2)) by auto.
    rewrite H3, H11 in H16.
    contradiction.
Qed.

(* Represent a layout as a list where element l at index p indicates that
   logical qubit l is stored at physcial qubit p. (Makes printing nicer.)  *)
Fixpoint layout_to_list' {dim} x (m : qmap dim) :=
  match x with
  | O => []
  | S x' => (layout_to_list' x' m) ++ [phys2log m x']
  end.
Definition layout_to_list dim (m : qmap dim) :=
  layout_to_list' dim m.

(* Produce a layout from its list representation. *)
Fixpoint list_to_layout' {dim} l acc : qmap dim :=
  match l with
  | [] => (fun x => x, fun x => x) (* default mapping *)
  | h :: t =>
      let m' := @list_to_layout' dim t (S acc) in
      (fun x => if x =? h then acc else fst m' x,
       fun x => if x =? acc then h else snd m' x)
  end.
Definition list_to_layout l : qmap (length l) :=
  list_to_layout' l 0.

(* TODO: May be useful to prove that layout_to_list and list_to_layout are inverses. *)

(* Examples *)
Definition trivial_layout dim : qmap dim :=
  (fun x => x, fun x => x).
Definition test_layout : qmap 5 :=
  let l2p q := if q =? 0 then 4
               else if q =? 1 then 2
                    else if q =? 2 then 3
                         else if q =? 3 then 0
                              else 1 in
  let p2l q := if q =? 0 then 3
               else if q =? 1 then 4
                    else if q =? 2 then 1
                         else if q =? 3 then 2
                              else 0 in
  (l2p, p2l).

Compute (layout_to_list 5 (trivial_layout 5)).
Compute (layout_to_list 5 test_layout).
Compute (layout_to_list 5 (list_to_layout (0 :: 1 :: 2 :: 3 :: 4 :: []))).
Compute (layout_to_list 5 (list_to_layout (3 :: 4 :: 1 :: 2 :: 0 :: []))).

(* The trivial layout is always well formed. *)
Lemma trivial_layout_well_formed : forall dim,
  layout_well_formed dim (trivial_layout dim).
Proof.
  intros dim.
  unfold layout_well_formed, trivial_layout, log2phys, phys2log.
  intros x Hx.
  auto.
Qed.

(* Most things that are true of log2phys will be true of phys2log too --
   there is not an important conceptual difference between the two functions
   (except in the swap_in_map function). The qmap construct is largely just
   a way to store a function with its inverse. So it's typically fine to
   switch the order of log2phys and phys2log. *)
Definition invert_layout {dim} (m : qmap dim) : qmap dim := (snd m, fst m).

Lemma invert_layout_well_formed : forall {dim} (m : qmap dim),
  layout_well_formed dim m ->
  layout_well_formed dim (invert_layout m).
Proof.
  intros dim m H.
  intros x Hx.
  specialize (H x Hx) as [? [? [? ?]]].
  unfold invert_layout.
  destruct m; simpl in *.
  repeat split; auto.
Qed.