(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Lia.
From mathcomp Require Import ssreflect ssrbool.
Require while.
Require Import goto sgoto.

(** * Hoare Logic of %\sgoto%#SGoto#

   %\label{sec:sgoto_hoare}%

   This corresponds to Section 3.2 of %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#.
   The type %\coqdockw{assert}%#assert# was defined in
   %Section \ref{sec:while}%#the module for the While language#.
*)

Declare Scope sgoto_hoare_scope.

Module SGoto_Hoare (while_hoare_deter_m : while.WHILE_HOARE_DETER).

Module Import sgoto_m := SGoto while_hoare_deter_m.
Import goto_deter_m.
Import goto_m.
Import while_hoare_deter_m.

(** printing //\\ %\ensuremath{\land}%*)

Definition assn := label -> assert.

Local Open Scope while_assert_scope.

Definition restrict (P : assn) d : assn := fun l => P l //\\ (fun _ _ => List.In l d).

Definition restrict_cplt (P : assn) d : assn := fun l => while.Not (fun _ _ => List.In l d) //\\ P l.

Lemma restrict_dom : forall l d (P : assn) s h, List.In l d -> P l s h -> restrict P d l s h.
Proof. done. Qed.

Lemma restrict_cplt_dom : forall (P : assn) l s h d, P l s h -> ~ List.In l d -> restrict_cplt P d l s h.
Proof. done. Qed.

Reserved Notation "'[^' P '^]' c '[^' Q '^]'" (at level 82, no associativity).

(** printing ===> %\ensuremath{\Longrightarrow}%*)

(** Figure 3 (%\figurethree%#Hoare rules of SGoto#) in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#.
   %\coqdocvar{wp0} is explained in Section \ref{sec:while}.%
   %$\Longrightarrow$ used in the rule \coqdocvar{hoare\_sgoto\_conseq} is the entailment for \coqdockw{assert}.% *)

Local Open Scope sgoto_scope.

Notation "'_assn'" := assn : sgoto_hoare_scope. (* dummy *)
Local Open Scope sgoto_hoare_scope.

Inductive hoare_sgoto : assn -> scode -> assn -> Prop :=
| hoare_cmd : forall l c P,
  [^ fun pc => fun s h => pc = l /\ (wp0 c (P (S l))) s h \/ pc <> l /\ P pc s h ^]
     sC l c [^ P ^]
| hoare_jmp : forall l j Q,
  [^ fun pc => fun s h => pc = l /\ (Q j s h \/ j = l) \/ pc <> l /\ Q pc s h ^]
     sB l (jmp j) [^ Q ^]
| hoare_branch : forall l b j Q,
  [^ fun pc => fun s h =>
     pc = l /\ (~~ eval_b b (s, h) /\ Q (S l) s h \/ eval_b b (s, h) /\ ( Q j s h \/ j = l)) \/
     pc <> l /\ Q pc s h ^]
     sB l (cjmp b j) [^ Q ^]
| hoare_sO : forall P, [^ P ^] sO [^ P ^]
| hoare_sS : forall sc0 sc1 P,
  [^ restrict P (sdom sc0) ^] sc0 [^ P ^] -> [^ restrict P (sdom sc1) ^] sc1 [^ P ^] ->
  [^ P ^] sc0 [+] sc1 [^ restrict_cplt P (sdom (sc0 [+] sc1)) ^]
| hoare_sgoto_conseq : forall sc (P Q P' Q': assn),
  (forall l, P l ===> P' l) -> (forall l, Q' l ===> Q l) ->
  [^ P' ^] sc [^ Q' ^] -> [^ P ^] sc [^ Q ^]
where "'[^' P '^]' c '[^' Q '^]'" := (hoare_sgoto P c Q) : sgoto_hoare_scope.

(** Theorem 10 (%\theoremten%#Soundness#) in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#: *)

Module while_semop_prop_m := while.While_Semop_Prop while_hoare_deter_m.

Lemma hoare_sgoto_sound : forall sc P Q, [^ P ^] sc [^ Q ^] ->
  forall l s h, P l s h -> ~ (Some (l, (s, h)) >- sc ---> None) /\
    forall l' s'  h', Some (l, (s, h)) >- sc ---> Some (l', (s', h')) -> Q l' s' h'.
Proof.
move=> sc Pi Pi'; elim=> //=; clear sc Pi Pi'.
- move=> l c Pi l0 s0 h0 [ [l0_l X2] | [l0_l X2] ]; split.
  + subst l0 => X.
    inversion X; subst.
    inversion H3; subst.
    by move: (wp0_no_err _ _ _ _ X2).
  + move=> l' s' h' Hexec; subst l0.
    case/(exec_sgoto_inv_cmd _ _ _ _ _) : Hexec => X; subst.
    move/while_semop_prop_m.exec_cmd0_inv => Hexec.
    by eapply exec0_wp0; [apply Hexec | exact X2].
  + move=> X; inversion X; by subst.
  + move=> l' s'  h'.
    move/(exec_sgoto_inv_refl _ _ _ _) => H.
    have : ~ List.In l0 (sdom (sC l c)) by rewrite /=; intuition.
    by case/H => ? ?; subst => <-.
- move=> l j Q l0 s0 h0 [ [l0_l [X2 | X2] ] | [l0_l X2] ]; split.
  + by move=> X; inversion X.
  + move=> l' s' h' Hexec; subst l.
    by case/(exec_sgoto_inv_jmp _ _ _ _) : Hexec; case=> ? ? ? _; subst.
  + by move=> X; inversion X.
  + move=> l' s' h' Hexec; subst.
    inversion Hexec; subst => //.
    rewrite /= in H1; tauto.
  + by move=> X; inversion X.
  + move=> l' s' h' Hexec.
    apply exec_sgoto_inv_refl in Hexec.
    * case: Hexec => K1 K2 K3; by subst.
    * rewrite /=; contradict l0_l; by case: l0_l.
- move=> l b j Q l0 s0 h0 [[l0_l [ [X3 HQ] | [X2 [X3|j_l] ] ] ] | [l0_l HQ] ]; split.
  + by move=> X; inversion X.
  + move=> l' s' h' Hexec; subst l.
    by case: {Hexec}(exec_sgoto_inv_cjmp_false _ _ _ _ _ Hexec X3) => ? ? ?; subst.
  + by move=> X; inversion X.
  + move=> l' s' h' Hexec; subst l.
    case: {Hexec}(exec_sgoto_inv_cjmp_true _ _ _ _ _ Hexec X2); case => X Y Z _; by subst.
  + by move=> X; inversion X.
  + move=> l' s' h' Hexec; subst.
    inversion Hexec; subst => //.
    by rewrite X2 in H0.
    rewrite /= in H1; tauto.
  + by move=> X; inversion X.
  + move=> l' s' h'  Hexec.
    move: (exec_sgoto_inv_refl _ _ _ _ Hexec) => H.
    have : ~ List.In l0 (sdom (sB l (cjmp b j))) by rewrite /=; intuition.
    case/H=> K1 K2 K3; by subst.
- move=> Pi l0 s0 h0 HPil0; split.
  + by move=> X; inversion X.
  + move=> l' s' h'.
    move/(exec_sgoto_inv_refl _ _ _ _) => /= X.
    have : ~ False by tauto.
    case/X => Y Z V; by subst.
- move=> sc1 sc2 P Hsc0 IHsc0 Hsc1 IHsc1 l0 s0 h0 HP_l0; split.
  + move Hst0 : (Some (l0, (s0, h0))) => st0.
    move Hst' : None => st'.
    move Hsc : (sc1 [+] sc2) => sc.
    move=> Hexec.
    move: Hexec sc1 sc2 P Hsc0 IHsc0 Hsc1 IHsc1 Hsc l0 s0 h0 HP_l0 Hst0 Hst'.
    elim => //; move=> {sc st0 st'}.
    + move=> sc1 sc2 l0 st0 s' s'' HInl0sc1 Hexec_sc1 _(*IHsc1*) Hsc IHsc sc1' sc2' Pi.
      move=> Hressc1 IHsc1' Hressc2 IHsc2 Hsc'; subst.
      case: Hsc' => X Y; subst sc1' sc2'.
      move=> l0' s0 h0 HPi_l0 [? ?]; subst.
      move=> Y; subst s''.
      move: (restrict_dom _ _ _ _ _ HInl0sc1 HPi_l0) => X.
      destruct s' as [ [l' [s' h'] ] | ].
      - move: (proj2 (IHsc1' _ _ _ X) _ _ _ Hexec_sc1).
        move/(IHsc _ _ _ Hressc1 IHsc1' Hressc2 IHsc2 (refl_equal _) _ _ _); tauto.
      - move: {IHsc1'}(proj1 (IHsc1' _ _ _ X)); tauto.
    + move=> sc1 sc2 l0 st0 s' s'' HInl0sc2 Hexec_sc2 _(*IHsc2*) Hexec_sc IHsc sc1' sc2' Pi.
      move=> Hressc1 IHsc1' Hressc2 IHsc2 Hsc'; subst.
      case: Hsc' => X Y; subst sc1' sc2'.
      move=> l0' s0 h0 HPi_l0 [? ?]; subst.
      destruct s' as [ [ l' [s' h'] ] | ].
      - move=> Y; subst s''.
        move: (restrict_dom _ _ _ _ _ HInl0sc2 HPi_l0) => X.
        move: (proj2 (IHsc2 _ _ _ X) _ _ _ Hexec_sc2).
        move/(IHsc _ _ _ Hressc1 IHsc1' Hressc2 IHsc2 (refl_equal _) _ _ _); tauto.
      - move: (restrict_dom _ _ _ _ _ HInl0sc2 HPi_l0) => X.
        move: {IHsc2}(proj1 (IHsc2 _ _ _ X)); tauto.
  + move=> l' s' h' Hexec .
    move Hst0 : (Some (l0, (s0, h0))) => st0.
    move Hst' : (Some (l', (s', h'))) => st'.
    move Hsc : (sc1[+]sc2) => sc.
    rewrite Hst0 Hst' Hsc in Hexec.
    move: Hexec sc1 sc2 P Hsc0 IHsc0 Hsc1 IHsc1 Hsc l0 s0 h0 l' s' h' HP_l0 Hst0 Hst'.
    elim => //; move=> {sc st0 st'}.
    + move=> sc1 sc2 l0 st0 s' s'' HInl0sc1 Hexec_sc1 _(*IHsc1*) Hsc IHsc sc1' sc2' Pi.
      move=> Hressc1 IHsc1' Hressc2 IHsc2 Hsc'; subst.
      case: Hsc' => X Y; subst sc1' sc2'.
      move=> l0' s0 h0 l'_ s'0 h' HPi_l0 [? ?]; subst => Y.
      move: (restrict_dom _ _ _ _ _ HInl0sc1 HPi_l0) => X.
      destruct s'' as [ [l'' [s'' h'']] | ] => //.
      case: Y => ? ? ?; subst.
      destruct s' as [ [l' [s' h']] | ].
      - move: ((proj2 (IHsc1' _ _ _ X)) _ _ _ Hexec_sc1) => H.
        by move: {IHsc1' IHsc2 IHsc} (IHsc _ _ _ Hressc1 IHsc1' Hressc2 IHsc2 (refl_equal _) _ _ _ _ _ _  H (refl_equal _) (refl_equal _)).
      - by inversion Hsc.
    + move=> sc1 sc2 l0 st0 s' s'' HInl0sc2 Hexec_sc2 _(*IHsc2*) Hexec_sc IHsc sc1' sc2' Pi.
      move=> Hressc1 IHsc1' Hressc2 IHsc2 Hsc'; subst.
      case: Hsc' => X Y; subst sc1' sc2'.
      move=> l0' s0 h0 l'_ s'_ h'_ HPi_l0 [? ?]; subst.
      destruct s' as [ [l' [s' h']] | ].
      - destruct s'' as [ [l'' [s'' h'']] | ] => //.
        case=> ? ? ?; subst.
        move: (restrict_dom _ _ _ _ _ HInl0sc2 HPi_l0) => X.
        move: (proj2 (IHsc2 _ _ _ X) _ _ _ Hexec_sc2) => H.
        by move: {IHsc1' IHsc2 IHsc} (IHsc _ _ _ Hressc1 IHsc1' Hressc2 IHsc2 (refl_equal _) _ _ _ _ _ _ H (refl_equal _) (refl_equal _)).
      - by inversion Hexec_sc.
    + move=> sc l st HnotInlsc sc1 sc2 Pi Hressc1 IHsc1 Hressc2 IHsc2 Hsc l0 s0 h0 l' s' h' HP_l0 [? ?]; subst.
      case=> ? ? ?; by subst.
- move=> sc P Q P' Q' HP HQ Hsc IH l0 s0 h0 HP_l0; split.
  + move=> X.
    move: (HP _ _ _ HP_l0) => H2.
    by move: (proj1 (IH _ _ _ H2) X).
  + move=> l' s' h' Hexec .
    move: (HP _ _ _ HP_l0) => H2.
    move: (proj2 (IH _ _ _ H2) _ _ _ Hexec) => H4.
    by apply HQ.
Qed.

(** The semantic definition of the weakest precondition from %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#.
   The additional conjunct is to take errors into account.
*)

Definition wlp_semantics (sc : scode) (Pi : assn) : assn := fun l s h =>
  ~ (Some (l, (s, h)) >- sc ---> None) /\
  forall l' s' h', Some (l, (s, h)) >- sc ---> Some (l', (s', h')) -> Pi l' s' h'.

(** Lemma 11 in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#: *)

Lemma wlp_completeness : forall sc (Hwf : wellformed sc) Q, [^ wlp_semantics sc Q ^] sc [^ Q ^].
Proof.
elim .
- move=> Hwf Q.
  apply hoare_sgoto_conseq with (P':=wlp_semantics sO Q) (Q':=wlp_semantics sO Q); last by apply hoare_sO.
  + by move=> *.
  + move=> l s0 h0 Hwlp; by apply (proj2 Hwlp), exec_sgoto_refl.
- move=> l c Hwf Q.
  apply hoare_sgoto_conseq with (P':= fun pc s h =>
    pc = l /\ (wp0 c (Q (S l))) s h \/
    pc <> l /\ Q pc s h) (Q' := Q); last by apply hoare_cmd.
  + move=> l0 s0 h0 Hwlp.
    have [l0_l | l_l0] : l0 = l \/ l <> l0 by unfold label; lia.
    * left; subst; split => //.
      rewrite /wlp_semantics in Hwlp.
      case: (cmd0_terminate c (s0, h0)) => s' Hs'.
      destruct s' as [[s h]|].
      - eapply exec0_wp0; [by apply Hs' | idtac].
        apply (proj2 Hwlp).
        eapply exec_sgoto_cmd0; eauto.
        by constructor.
      - case: Hwlp => H H0.
        have : Some (l, (s0, h0)) >- sC l c ---> None by do 2 constructor.
        contradiction.
    * right; split; auto.
      rewrite /wlp_semantics in Hwlp.
      apply (proj2 Hwlp), exec_sgoto_refl => /=; tauto.
  + by rewrite /while.entails.
- move=> l [].
  + (* jmp *) move=> j Hwf Q.
    apply hoare_sgoto_conseq with (P' := fun pc s h =>
        pc = l /\ (Q j s h \/ j = l) \/
        pc <> l /\ Q pc s h) (Q' := Q); last by apply hoare_jmp.
    * move=> l0 s0 h0 Hwlp.
      have [l0_l | l_l0] : l0 = l \/ l <> l0 by unfold label; lia.
      - subst; left; split => //.
        rewrite /wlp_semantics in Hwlp.
        have [j_l | j_l] : j = l \/ j <> l by unfold label; lia.
        + by subst; auto.
        + left; apply (proj2 Hwlp).
          by eapply exec_sgoto_jmp; eauto.
      - right; split; auto.
        rewrite /wlp_semantics in Hwlp.
        apply (proj2 Hwlp), exec_sgoto_refl => /=; tauto.
    * by rewrite /while.entails.
  + (* cjmp *) move=> t j Hwf Q.
    apply hoare_sgoto_conseq with (P':= fun pc s h => pc = l /\
        (~~ eval_b t (s, h) /\ Q (S l) s h \/
          eval_b t (s, h) /\ ( Q j s h \/ j = l)) \/
        pc <> l /\ Q pc s h) (Q' := Q); last by apply hoare_branch.
    + move=> l0 s0 h0 Hwlp.
      have [l0_l | l_l0] : l0 = l \/ l <> l0 by unfold label; lia.
      * subst; left; split => //.
        case/boolP : (eval_b t (s0, h0)) => Heval.
        - right; split => //.
          have [j_l | j_l] : j = l \/ j <> l by unfold label; lia.
          - subst; by right.
          - left; apply (proj2 Hwlp).
            by eapply exec_sgoto_cjmp_true; eauto.
        - left; split; first by [].
          rewrite /wlp_semantics in Hwlp.
          apply (proj2 Hwlp).
          by eapply exec_sgoto_cjmp_false; eauto.
      * right; split; first by auto.
        apply (proj2 Hwlp), exec_sgoto_refl => /=; tauto.
    + by rewrite /while.entails.
- move=> sc0 IHsc0 sc2 IHsc1 Hwf Q.
  apply hoare_sgoto_conseq with (P' := wlp_semantics (sc0 [+] sc2) Q)
    (Q' := restrict_cplt (wlp_semantics (sc0 [+] sc2) Q) (sdom (sc0 [+] sc2))).
  + by rewrite /while.entails.
  + move=> l s h.
    rewrite /restrict_cplt /wlp_semantics; case=> Hres1 Hres2.
    by apply (proj2 Hres2), exec_sgoto_refl.
  + apply hoare_sS.
    * apply hoare_sgoto_conseq with (P' := wlp_semantics sc0 (wlp_semantics (sc0 [+] sc2) Q))
      (Q' := wlp_semantics (sc0 [+] sc2) Q).
      - move=> l s h.
        rewrite /restrict /while.And; case=> H2 l_sc0; split.
        + rewrite /wlp_semantics in H2.
          case: H2 => H H0.
          contradict H.
          eapply exec_sgoto_seq0; eauto.
          by constructor.
        + move=> l' s' h' Hsc0; split.
          * rewrite /wlp_semantics in H2.
            case: H2 => H H0.
            contradict H.
            by eapply exec_sgoto_seq0; eauto.
          * move=> l'' s'' h'' Hsc.
            apply (proj2 H2).
            by eapply exec_sgoto_seq0; eauto.
      - by rewrite /while.entails.
      - apply IHsc0.
        by eapply wellformed_inv_L; eauto.
    * apply hoare_sgoto_conseq with (P' := wlp_semantics sc2 (wlp_semantics (sc0 [+] sc2) Q))
      (Q' := wlp_semantics (sc0 [+] sc2) Q).
      - move=> l s h.
        rewrite /restrict /while.And; case=> H2 l_sc2; split.
        + rewrite /wlp_semantics in H2.
          case : H2 => H H0.
          contradict H.
          eapply exec_sgoto_seq1; eauto.
          by constructor.
        + move=> l' s' h' Hsc2; split.
          * rewrite /wlp_semantics in H2.
            case: H2 => H H0.
            contradict H.
            by eapply exec_sgoto_seq1; eauto.
          * move=> l'' s'' h'' Hsc.
            apply (proj2 H2).
            by eapply exec_sgoto_seq1; eauto.
      - by rewrite /while.entails.
      - apply IHsc1.
        by eapply wellformed_inv_R; eauto.
Qed.

(** Theorem 12 (%\theoremtwelve%#Completeness#) in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#. *)

Lemma hoare_sgoto_complete : forall (P Q : assn) sc (Hwf : wellformed sc),
  (forall l s h, P l s h ->
    ~  Some (l, (s, h)) >- sc ---> None  /\
    (forall l' s' h', Some (l,(s,h)) >- sc ---> Some (l',(s',h')) -> Q l' s' h')) ->
  [^ P ^] sc [^ Q ^].
Proof.
move=> P Q sc Hwf Hsemax.
apply hoare_sgoto_conseq with (P' := wlp_semantics sc Q) (Q' := Q).
- move=> l s h HP.
  rewrite /wlp_semantics; split.
  + by apply (proj1 (Hsemax _ _ _ HP)).
  + move=> l' s' h' Hexec.
    by apply (proj2 (Hsemax _ _ _ HP)).
- by rewrite /while.entails.
- by apply wlp_completeness.
Qed.

End SGoto_Hoare.


(* Celsius project *)
(* Clément Blaudeau - Lamp@EPFL & Inria 2020-2022 *)
(* ------------------------------------------------------------------------ *)
(* This files describes the semantic authority that our calculus enjoys. It is not used for
soundness *)

From Celsius Require Export Semantics.
Implicit Type (σ: Store) (ρ ω: Env) (l: Loc).

(* ------------------------------------------------------------------------ *)
(** ** Definition *)

Definition authority σ σ' :=
  forall l C ω, getObj σ l = Some(C, ω) -> exists ω', getObj σ' l = Some(C, ω') /\ dom ω >= dom ω'.
Global Instance notation_authority_store : notation_authority Store :=
  { authority_ := authority }.
Local Hint Unfold notation_authority_store: notations.
Local Hint Unfold authority : aty.

(* ------------------------------------------------------------------------ *)
(** ** Basic results *)
(** The relation is trivially reflexive and transitive *)

Lemma aty_refl: forall σ,
    σ ▷ σ.
Proof.
  intros ? ? ; eauto with aty.
Qed.
Global Hint Resolve aty_refl: aty.

Lemma aty_trans : forall σ1 σ2 σ3,
    σ1 ▷ σ2 ->
    σ2 ▷ σ3 ->
    σ1 ▷ σ3.
Proof.
  intros. intros ?; intros.
  specialize (H l C ω); steps.
  specialize (H0 l C ω'); steps; eauto with aty lia.
Qed.
Global Hint Resolve aty_trans: aty.

Ltac aty_trans :=
  repeat match goal with
         | H:_ |- ?σ ▷ ?σ => apply aty_refl
         | H: ?σ1 ▷ ?σ2 |- ?σ1 ▷ ?σ3 => apply aty_trans with σ2 ; [ assumption | ]
         | H: ?σ2 ▷ ?σ3 |- ?σ1 ▷ ?σ3 => apply aty_trans with σ2 ; [ | assumption ]
         end.
Global Hint Extern 1 => aty_trans: aty.

(** We have a result on the store sizes *)
Lemma aty_domains:
  forall σ σ',
    σ ▷ σ' -> dom σ <= dom σ'.
Proof.
  intros.
  destruct σ eqn:Σ; simpl; [lia |].
  destruct o as [C ω].
  specialize (H (dom s)).
  destruct (getObj ((C, ω)::s) (dom s)) eqn: H__e.
  - destruct o as [D ω'].
    apply H in H__e; steps.
    apply getObj_dom in H1; auto.
  - unfold getObj in H__e.
    apply nth_error_None in H__e.
    simpl in H__e; lia.
Qed.
Global Hint Resolve aty_domains: aty.

(* ------------------------------------------------------------------------ *)
(** ** Authority theorem *)
(** We start with two technical results on authority for assignment (update) and fresh
location *)

Lemma aty_assignment :
  forall σ l C ω ω',
    getObj σ l = Some (C, ω) ->
    length ω >= length ω' ->
    σ ▷ [l ↦ (C, ω')]σ.
Proof.
  intros. introv ?.
  lets: getObj_dom H.
  destruct_eq (l = l0); subst;
    updates; eauto with lia.
Qed.
Global Hint Resolve aty_assignment: aty.

Lemma aty_freshness :
  forall σ c ρ,
    σ ▷ (σ ++ [(c, ρ)]).
Proof.
  intros. introv ?.
  lets: getObj_dom H.
  exists ω; steps;
    try rewrite getObj_last2;
    eauto with updates.
Qed.
Global Hint Resolve aty_freshness: aty.

(** Then we have the main result *)
Theorem aty_theorem:
  (forall e σ ρ ψ v σ',
      ⟦e⟧ (σ, ρ, ψ) --> (v, σ') -> σ ▷ σ') /\
    (forall el σ ρ ψ vl σ',
        ⟦_ el _⟧p (σ, ρ, ψ) --> (vl, σ') -> σ ▷ σ') /\
    (forall C ψ x ρ σ σ',
        initP C ψ x ρ σ σ' ->
        [ψ ↦ (C,[])]σ ▷ [ψ ↦ (C, [])]σ').

Proof with (updates; cross_rewrites; eauto 3 with aty updates lia).
  eapply evalP_multi_ind;
    unfold assign; intros;
    repeat destruct_match; eval_dom;
    flatten; aty_trans; try discriminate ...

  - (* e_new *)
    intros l D ?ω H__get; steps.
    specialize (IH__init l D ω).
    lets: getObj_dom H__get...
    repeat rewrite getObj_update_diff in IH__init...
    rewrite getObj_last2 in IH__init...

  - (* init_cons *)
    lets: assign_new_dom H__assign.
    intros l ?D ?ω H__obj...
    destruct (getObj σ I) as [[?D ?ω]|] eqn:H2.
    + lets: IH__e I H2; steps.
      rewrite /assign_new H4 in H__assign...
      destruct_if_eqb; inverts H__assign;
        destruct_eq (I = l); subst...
    + destruct_eq (I = l); subst...
      destruct (getObj σ1 I) as [[?D ?ω]|] eqn:H4;
        rewrite /assign_new H4 in H__assign;
        try destruct_if_eqb; inverts H__assign...
Qed.

Corollary aty_theorem_expr:
  forall e σ ρ ψ v σ',
      ⟦e⟧ (σ, ρ, ψ) --> (v, σ') -> σ ▷ σ'.
Proof.
  apply aty_theorem.
Qed.
Global Hint Resolve aty_theorem: aty.

Corollary aty_theorem_list:
  forall el σ ρ ψ vl σ',
      ⟦_ el _⟧p (σ, ρ, ψ) --> (vl, σ') -> σ ▷ σ'.
Proof.
  apply aty_theorem.
Qed.
Global Hint Resolve aty_theorem_list: aty.


Require Import List.
Require Import Coq.Arith.Arith.
From Coq Require Import Strings.String.
Open Scope string_scope.
Require Export Strings.String.

Inductive ty : Type :=
| Bool : ty
| Arrow : ty -> ty -> ty
| Monad : ty -> ty
| NT : string -> ty.

(*We treat multiple-argument functions as taking single arguments--the end
  effect is the same, but the implementation here is easier.*)
Inductive tm : Type :=
| attraccess : tm -> string -> tm (*tm and attr name*)
| tt : tm
| ff : tm
  (*should include and because of short circuitng's effects*)
| and : tm -> tm -> tm
| var : string -> tm
| lam : string -> ty -> tm -> tm
| app : tm -> tm -> tm
| ifthenelse : tm -> tm -> tm -> tm
| ifthen : tm -> tm -> tm
| mreturn : tm -> tm
| mfail : string -> tm (*use a string as a "generic" argument*)
| mbind : tm -> tm -> tm
| mzero : tm
| mplus : tm -> tm -> tm
| letexpr : string -> ty -> tm -> tm -> tm
| caseexpr : tm -> clauses -> tm
| mcase : tm -> clauses -> tm

with clauses : Type :=
| singleclause : patt -> tm -> clauses
| addclause : patt -> tm -> clauses -> clauses

(*It's fine to ignore pattern-matching bindings because they don't add
  anything interesting to monadification.  Any name bound by matching
  will have a set type under our scheme.  If it is a monad type, it
  may be used monadically within the particular clause, and the
  binding may be treated in the same manner as a let.*)
with patt : Type :=
| allpatt : patt
| otherpatt : ty -> patt.

Inductive equation : Type :=
(*tree reference -> attr name -> equation body*)
| basic_equ : string -> string -> tm -> equation
(*tree reference -> attr name*)
| empty_equ : string -> string -> equation.

(*For identifying trees in evaluation*)
Definition tree_identifier : Type := nat.

Definition trid_eq (n1 n2 : nat) : bool := beq_nat n1 n2.

Inductive value : Type :=
| v_tt : value
| v_ff : value
| v_closure : evalctx -> string -> ty -> tm -> value
| v_return : value -> value
| v_fail : value
| v_tree : tree_identifier -> value
(*Evaluation contexts holding results for other names.  If we want, we
  can pretend we are working in an AG that pushes all attributes down
  and pulls all attributes up as you go, and that attribute accesses
  can only be done directly, so they can be treated as vars (e.g. var
  "t.a"), in which case this also holds the results for other
  attributes.*)
with evalctx : Type :=
| emptyeval : evalctx
| addeval : string -> value -> evalctx -> evalctx.

(*Look up a value in an evaluation context.*)
Inductive lookup : evalctx -> string -> value -> Prop :=
| LKP_Here : forall x v rest,
    lookup (addeval x v rest) x v
| LKP_Later : forall y v rest x vx,
    lookup rest x vx -> x <> y ->
    lookup (addeval y v rest) x vx.
Theorem lookup_unique : forall G x v1 v2,
    lookup G x v1 -> lookup G x v2 -> v1 = v2.
Proof.
  intros G x v1 v2 lkp1. induction lkp1; intros lkp2; inversion lkp2.
  - auto.
  - contradiction.
  - symmetry in H0. contradiction.
  - auto.
Qed.

(*Whether a value matches a pattern.*)
Inductive matchpatt : patt -> value -> Prop := .

Inductive inhsyn : Type :=
| inh : inhsyn
| syn : inhsyn.

Inductive decl : Type :=
(*production name -> top name and type -> child names and types ->
  list of equations*)
| prod : string -> (string * ty) -> list (string * ty) ->
         list equation -> decl
(*attribute name -> attribute type -> inherited or synthesized*)
| attrdecl : string -> ty -> inhsyn -> decl
(*attribute name -> nonterminal name it occurs on*)
| occurson : string -> string -> decl
(*nonterminal name*)
| ntdecl : string -> decl.

Definition grammar : Type := list decl.

(*A context holding the information about things in the grammar.*)
Definition grammarctx : Type := grammar.

(*A context for the nodes in the tree the evaluation is over.*)
Definition treectx : Type :=
  (*this tree, production building it, children, parent of this tree*)
  list (tree_identifier * string * list value * tree_identifier).

Fixpoint build_evalctx (sig : list (string * ty))
         (children : list value) : evalctx :=
  match sig, children with
  | nil, _ => emptyeval
  | _, nil => emptyeval
  | (name, ty)::sig', tid::children' =>
    addeval name tid (build_evalctx sig' children')
  end.

Fixpoint find_eq (eqs : list equation) (tree : string)
         (attr : string) : option equation :=
  match eqs with
  | nil => None
  | (basic_equ tr a tm)::eqs' =>
    if string_dec tr tree
    then if string_dec a attr
         then Some (basic_equ tr a tm)
         else find_eq eqs' tree attr
    else find_eq eqs' tree attr
  | (empty_equ tr a)::eqs' =>
    if string_dec tr tree
    then if string_dec a attr
         then Some (empty_equ tr a)
         else find_eq eqs' tree attr
    else find_eq eqs' tree attr
  end.

Fixpoint find_prod (GC : grammarctx) (pname : string) :
         (*(top, top ty), child names and types, equations*)
  option ((string * ty) * list (string * ty) * list equation) :=
  match GC with
  | nil => None
  | (prod name top children eqs)::GC' =>
    if string_dec name pname
    then Some (top, children, eqs)
    else find_prod GC' pname
  | d::GC' => find_prod GC' pname
  end.

(*Find the production that built a tree and its children's identifiers*)
Fixpoint find_tree (tc : treectx) (tr : tree_identifier) :
  option (string * list value * tree_identifier) :=
  match tc with
  | nil => None
  | (tid, p, c, pid)::tc' => if trid_eq tid tr
                             then Some (p, c, pid)
                             else find_tree tc' tr
  end.

Fixpoint attr_ty (GC : grammarctx) (a : string) :
  option (ty * inhsyn) :=
  match GC with
  | nil => None
  | (attrdecl aname t inh_or_not)::GC' =>
    if string_dec aname a
    then Some (t, inh_or_not)
    else attr_ty GC' a
  | d::GC' => attr_ty GC' a
  end.

Fixpoint find_id_name (sig : list (string * ty))
         (children : list value) (id : tree_identifier) :
  option string :=
  match sig, children with
  | nil, _ => None
  | _, nil => None
  | (name, ty)::sig', (v_tree tid)::children' =>
    if trid_eq tid id
    then Some name
    else find_id_name sig' children' id
  | (name, ty)::sig', v::children' =>
    find_id_name sig' children' id
  end.

Inductive basic_eval :
  treectx -> grammarctx -> evalctx -> tm -> value -> Prop :=
| BE_SynAttr :
    forall TC GC G t a aty trid prod chil parentid top ty
           ch eqs e G' v,
      basic_eval TC GC G t (v_tree trid) ->
      (*look up attribute to find inherited or synthesized*)
      attr_ty GC a = Some (aty, syn) ->
      (*look up tree to get prod name and child ID's*)
      find_tree TC trid = Some (prod, chil, parentid) ->
      (*look up prod to get equations and production signature*)
      find_prod GC prod = Some ((top, ty), ch, eqs) ->
      (*get the equation*)
      find_eq eqs top a = Some e ->
      (*build a ctx based on the production*)
      build_evalctx ((top, ty)::ch) ((v_tree trid)::chil) = G' ->
      (*evaluate the equation*)
      basic_eval_equation TC GC G' e v ->
      basic_eval TC GC G (attraccess t a) v
| BE_InhAttr :
    forall TC GC G t a trid cprod cchil parentid prod chil pparentid
           top ty ch eqs e aty trname G' v,
      basic_eval TC GC G t (v_tree trid) ->
      (*look up attribute to find inherited or synthesized*)
      attr_ty GC a = Some (aty, inh) ->
      (*look up tree to get parent*)
      find_tree TC trid = Some (cprod, cchil, parentid) ->
      (*look up parent to get prod and child ID's*)
      find_tree TC parentid = Some (prod, chil, pparentid) ->
      (*look up prod to get equations and production signature*)
      find_prod GC prod = Some ((top, ty), ch, eqs) ->
      (*look up the name for the current tree in this production*)
      find_id_name ch chil trid = Some trname ->
      (*get the equation*)
      find_eq eqs trname a = Some e ->
      (*build a ctx based on the production*)
      build_evalctx ((top, ty)::ch) ((v_tree parentid)::chil) = G' ->
      (*evaluate the equation*)
      basic_eval_equation TC GC G' e v ->
      basic_eval TC GC G (attraccess t a) v
| BE_TT : forall TC GC G, basic_eval TC GC G tt v_tt
| BE_FF : forall TC GC G, basic_eval TC GC G ff v_ff
| BE_And_TT : forall TC GC G t1 t2,
    basic_eval TC GC G t1 v_tt -> basic_eval TC GC G t2 v_tt ->
    basic_eval TC GC G (and t1 t2) v_tt
| BE_And_FF1 : forall TC GC G t1 t2,
    basic_eval TC GC G t1 v_ff -> basic_eval TC GC G (and t1 t2) v_ff
| BE_And_FF2 : forall TC GC G t1 t2,
    basic_eval TC GC G t1 v_tt -> basic_eval TC GC G t2 v_ff ->
    basic_eval TC GC G (and t1 t2) v_ff
| BE_Var : forall TC GC G x v,
    lookup G x v -> basic_eval TC GC G (var x) v
| BE_Lam : forall TC GC G x ty t,
    basic_eval TC GC G (lam x ty t) (v_closure G x ty t)
| BE_App : forall TC GC G t1 t2 cG x ty t v2 v,
    basic_eval TC GC G t1 (v_closure cG x ty t) ->
    basic_eval TC GC G t2 v2 ->
    basic_eval TC GC (addeval x v2 cG) t v ->
    basic_eval TC GC G (app t1 t2) v
| BE_IfThenElse_TT : forall TC GC G c t1 t2 v,
    basic_eval TC GC G c v_tt -> basic_eval TC GC G t1 v ->
    basic_eval TC GC G (ifthenelse c t1 t2) v
| BE_IfThenElse_FF : forall TC GC G c t1 t2 v,
    basic_eval TC GC G c v_ff -> basic_eval TC GC G t2 v ->
    basic_eval TC GC G (ifthenelse c t1 t2) v
| BE_Return : forall TC GC G t v,
    basic_eval TC GC G t v ->
    basic_eval TC GC G (mreturn t) (v_return v)
| BE_Fail : forall TC GC G s,
    basic_eval TC GC G (mfail s) v_fail
| BE_Bind_Return : forall TC GC G t1 t2 v cG x ty t vfinal,
    basic_eval TC GC G t1 (v_return v) ->
    basic_eval TC GC G t2 (v_closure cG x ty t) ->
    basic_eval TC GC (addeval x v cG) t vfinal ->
    basic_eval TC GC G (mbind t1 t2) vfinal
| BE_Bind_Fail : forall TC GC G t1 t2,
    basic_eval TC GC G t1 v_fail ->
    basic_eval TC GC G (mbind t1 t2) v_fail
| BE_MZero : forall TC GC G, basic_eval TC GC G mzero v_fail
| BE_MPlus_Return : forall TC GC G t1 t2 v,
    basic_eval TC GC G t1 (v_return v) ->
    basic_eval TC GC G (mplus t1 t2) (v_return v)
| BE_MPlus_Fail : forall TC GC G t1 t2 v2,
    basic_eval TC GC G t1 v_fail -> basic_eval TC GC G t2 v2 ->
    basic_eval TC GC G (mplus t1 t2) v2
| BE_Let : forall TC GC G x ty t1 t2 v1 v2,
    basic_eval TC GC G t1 v1 ->
    basic_eval TC GC (addeval x v1 G) t2 v2 ->
    basic_eval TC GC G (letexpr x ty t1 t2) v2
| BE_Case : forall TC GC G t cs vt v,
    basic_eval TC GC G t vt -> basic_eval_cs TC GC G cs vt v ->
    basic_eval TC GC G (caseexpr t cs) v

with basic_eval_cs : treectx -> grammarctx -> evalctx -> clauses ->
                     value -> value -> Prop :=
| BE_CS_Single_Match : forall TC GC G p t vm v,
    matchpatt p vm -> basic_eval TC GC G t v ->
    basic_eval_cs TC GC G (singleclause p t) vm v
| BE_CS_Add_NoMatch : forall TC GC G p t cs vm v,
    ~(matchpatt p vm) -> basic_eval_cs TC GC G cs vm v ->
    basic_eval_cs TC GC G (addclause p t cs) vm v
| BE_CS_Add_Match : forall TC GC G p t cs vm v,
    matchpatt p vm -> basic_eval TC GC G t v ->
    basic_eval_cs TC GC G (addclause p t cs) vm v

with basic_eval_equation : treectx -> grammarctx -> evalctx ->
                           equation -> value -> Prop :=
| BEEQ_Basic : forall TC GC G tr a body v,
    basic_eval TC GC G body v ->
    basic_eval_equation TC GC G (basic_equ tr a body) v.

Theorem basic_eval_unique : forall TC GC G t v1 v2,
    basic_eval TC GC G t v1 -> basic_eval TC GC G t v2 -> v1 = v2
with basic_eval_cs_unique : forall TC GC G cs vm v1 v2,
    basic_eval_cs TC GC G cs vm v1 ->
    basic_eval_cs TC GC G cs vm v2 -> v1 = v2
with basic_eval_equation_unique : forall TC GC G eq v1 v2,
    basic_eval_equation TC GC G eq v1 ->
    basic_eval_equation TC GC G eq v2 -> v1 = v2.
Proof.
{
  intros TC GC G t ve1 ve2 be1 be2. generalize dependent ve2.
  induction be1; intros ve2 be2; inversion be2.
  (*attr*)
  - apply basic_eval_unique with
        TC GC G t (v_tree trid) (v_tree trid0) in be1; auto.
    injection be1. intros trids_eq. rewrite trids_eq in H0.
    rewrite H9 in H0. injection H0. intros pids_eq chils_eq prods_eq.
    rewrite prods_eq in H10. rewrite H10 in H1. injection H1.
    intros eqs_eq chs_eq tys_eq tops_eq.
    rewrite tops_eq in H15. rewrite tys_eq in H15.
    rewrite chs_eq in H15. rewrite <- trids_eq in H15.
    rewrite chils_eq in H15. rewrite H15 in H3. rewrite H3 in H17.
    rewrite eqs_eq in H11. rewrite tops_eq in H11. rewrite H11 in H2.
    injection H2. intros es_eq.
    apply basic_eval_equation_unique with TC GC G' e; auto.
    rewrite <- es_eq. assumption.
  - rewrite H8 in H. injection H. intros  ihns. inversion ihns.
  - rewrite H10 in H. injection H. intros  ihns. inversion ihns.
  - apply basic_eval_unique with
        TC GC G t (v_tree trid) (v_tree trid0) in be1; auto.
    injection be1. intros trids_eq. rewrite trids_eq in H0.
    rewrite H11 in H0. injection H0. intros pids_eq cchils_eq cprods_eq.
    rewrite pids_eq in H12. rewrite H12 in H1.
    injection H1. intros ppids_eq chils_eq prods_eq.
    rewrite prods_eq in H13. rewrite H13 in H2. injection H2.
    intros eqs_eq chs_eq tys_eq tops_eq. rewrite chs_eq in H14.
    rewrite chils_eq in H14. rewrite <- trids_eq in H14.
    rewrite H14 in H3. injection H3. intros trnames_eq.
    rewrite eqs_eq in H15. rewrite trnames_eq in H15.
    rewrite H15 in H4. injection H4. intros es_eq.
    rewrite tops_eq in H19. rewrite tys_eq in H19.
    rewrite chs_eq in H19.
    apply basic_eval_equation_unique with TC GC G' e; auto.
    rewrite <- es_eq. rewrite <- H5. rewrite <- pids_eq.
    rewrite <- chils_eq. rewrite H19. assumption.
  (*true*)
  - reflexivity.
  (*false*)
  - reflexivity.
  (*and*)
  - reflexivity.
  - apply IHbe1_1 in H5. discriminate H5.
  - apply IHbe1_2 in H6. discriminate H6.
  - apply IHbe1 in H4. discriminate H4.
  - reflexivity.
  - reflexivity.
  - apply IHbe1_2 in H6. discriminate H6.
  - reflexivity.
  - reflexivity.
  (*var*)
  - apply lookup_unique with G x; auto.
  (*abs*)
  - reflexivity.
  (*app*)
  - apply IHbe1_1 in H1. inversion H1.
    apply IHbe1_2 in H5. inversion H5.
    apply IHbe1_3. rewrite H10, H8, H9, H12. apply H7.
  (*if-then-else*)
  - apply IHbe1_2. assumption.
  - apply IHbe1_1 in H6. inversion H6.
  - apply IHbe1_1 in H6. inversion H6.
  - apply IHbe1_2. assumption.
  (*return*)
  - apply IHbe1 in H3. rewrite H3. reflexivity.
  (*fail*)
  - reflexivity.
  (*bind*)
  - apply IHbe1_1 in H1. inversion H1.
    apply IHbe1_2 in H5. inversion H5.
    apply IHbe1_3. rewrite H11, H9, H10, H13. apply H7.
  - apply IHbe1_1 in H5. inversion H5.
  - apply IHbe1 in H1. inversion H1.
  - reflexivity.
  (*mzero*)
  - reflexivity.
  (*mplus*)
  - apply IHbe1. assumption.
  - apply IHbe1 in H4. inversion H4.
  - apply IHbe1_1 in H5. inversion H5.
  - apply IHbe1_2. assumption.
  (*let*)
  - apply IHbe1_1 in H7. rewrite <- H7 in H8. apply IHbe1_2; auto.
  (*case*)
  - apply IHbe1 in H5.
    apply basic_eval_cs_unique with TC GC G cs vt; auto.
    rewrite H5. apply H7.
}
{
  intros TC GC G cs vm v1 v2 be1 be2. generalize dependent v2.
  induction be1; intros v2 be2; inversion be2.
  - apply basic_eval_unique with TC GC G t; auto.
  - apply IHbe1; auto.
  - exfalso. apply H. assumption.
  - exfalso. apply H9. assumption.
  - apply basic_eval_unique with TC GC G t; auto.
}
{
  intros TC GC G eq v1 v2 be1. generalize dependent v2.
  induction be1. intros v2 be2. inversion be2.
  apply basic_eval_unique with TC GC G body; auto.
}
Qed.


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

(***
Modulus : 2^480 - 2^240 - 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 15%nat;
    base := 32;
    bitwidth := 32;
    s := 2^480;
    c := [(1, 1); (2^240, 1)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

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

    mul_code := None;

    square_code := None;

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

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


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e369m25_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require FunctionalExtensionality.
Require ProofIrrelevance.
Require Import Program.
Require Import List.
Require Import Equality.
Import EqNotations.
Require Import Arith.
Import ListNotations.
Require Import ZArith.
Require Import Misc.
Require Import JamesTactics.
Require Import Enumerable.
Require Import Monad.
Require Import ListEx.
Require Import EqDec.
Require Import CpdtTactics.
Require Import Graph.
Require Import Category.
Require Import Coq.
Require Import Co.
Require Import Diagram.
Require Import String.
Require Import Ascii.

Set Universe Polymorphism.

Section Parse.

Context `{Category}.

Inductive Direction := north | east | south | west.

Instance enumerableDirection : enumerable Direction :=
  {| enumerate := [west; south; east; north] |}.
Proof.
  intros []; intuition.
Defined.

Instance eqDecDirection : eqDec Direction.
  constructor.
  decide equality.
Defined.

Definition Z_to_nat (z:Z) : option nat :=
  match z with
  | 0%Z => Some 0
  | Z.pos p => Some (Pos.to_nat p)
  | Z.neg _ => None
  end.

Definition imgMap (img:list string) (x:Z*Z) : ascii.
  destruct x as [x y].
  destruct (Z_to_nat x) as [x'|]; [|exact " "%char].
  destruct (Z_to_nat y) as [y'|]; [|exact " "%char].
  refine (let s := nth y' img " "%string in _).
  destruct (get x' s) as [cc|]; [|exact " "%char].
  exact cc.
Defined.

Definition points (w h:nat) (m:(Z*Z)->ascii) : list (Z*Z).
  refine (y <- seq 0 h;; _).
  refine (x <- seq 0 w;; _).
  refine (let x' := Z.of_nat x in let y' := Z.of_nat y in _).
  refine (if m (x',y') =? "o" % char then ret (x',y') else []).
Defined.

Definition directionEdgeChar d :=
  match d with
  | north => "|"
  | east => "-"
  | south => "|"
  | west => "-"
  end % char.

Definition directionEdgeEndChar d :=
  match d with
  | north => "^"
  | east => ">"
  | south => "v"
  | west => "<"
  end % char.

Definition directionMove (d:Direction) (x:Z*Z) : Z*Z.
  destruct x as [x y].
  exact match d with
  | north => (x, Z.pred y)
  | east => (Z.succ x, y)
  | south => (x, Z.succ y)
  | west => (Z.pred x, y)
  end.
Defined.

Definition directionFlip (d:Direction) : Direction :=
  match d with
  | north => south
  | east => west
  | south => north
  | west => east
  end.

Fixpoint traceEdges (fuel:nat) (m:(Z*Z)->ascii) (ps:list (Z*Z)) {struct fuel} : list ((Z*Z)*(Z*Z)).
  refine (s <- ps;; _).
  refine (d <- @enumerate Direction _;; _).
  refine (_ fuel (directionMove d s) d).
  clear d fuel.
  refine (fix rec fuel x d :=
    match fuel with
    | 0 => []
    | S fuel' => _
    end).
  specialize (rec fuel').
  refine (if m x =? "+"%char then _ else _).
  - refine (d' <- @enumerate Direction _;; _).
    refine (if directionFlip d =? d' then [] else _).
    exact (rec (directionMove d' x) d').
  - refine (if m x =? directionEdgeChar d then _ else
            if m x =? directionEdgeEndChar d then _ else []).
    + exact (rec (directionMove d x) d).
    + exact (ret (s,directionMove d x)).
Defined.

Definition parseImage (img:list string) : list (Z*Z) * list ((Z*Z)*(Z*Z)).
  refine (let m := imgMap img in _).
  refine (let h := List.length img in _).
  refine (let w := String.length (nth 0 img " "%string) in _).
  refine (let ps := points w h m in _).
  refine (let es := traceEdges (w*h) m ps in _).
  refine (ps, es).
Defined.

Definition parseDiagramType (img:list string) : Type.
  destruct (parseImage img) as [ps es].
  revert ps.
  refine ((fix rec os (om:(Z*Z) -> option (ListEx.index os)) ps :=
    match ps with
    | [] => _
    | x::ps' => forall o:object, rec (o::os) _ ps'
    end) [] (fun _ => None)); revgoals.
  {
    refine (fun x' => if x =? x' then Some found else (om x') >>= _).
    exact (fun oi => Some (next oi)).
  }
  clear rec ps.
  revert es.
  refine (fix rec es :=
    match es with
    | [] => Diagram
    | (s,d)::es' => (fun T => _) (rec es')
    end).
  destruct (om s) as [si|]; [|exact T].
  destruct (om d) as [di|]; [|exact T].
  refine (forall m : lookup si → lookup di, T).
Defined.

Definition section {A} `{eqDec A} {B:A->A->Type} (l:list {s:A & {d:A & B s d}}) (s d:A) : list (B s d).
  refine (v <- l;; _).
  destruct v as [s' [d' v]].
  refine (match (s, d) =? (s', d') with
  | left e => ret _
  | right _ => []
  end).
  inversion e.
  subst.
  exact v.
Defined.

Definition parseDiagram (img:list string) : parseDiagramType img.
  unfold parseDiagramType.
  destruct (parseImage img) as [ps es].
  match goal with |- _ ?os ?om ?ps => revert ps; generalize om; generalize os end.
  refine (fix rec os om ps {struct ps} :=
    match ps with
    | [] => _
    | x::ps' => _
    end); revgoals. {
    refine (fun o:object => rec _ _ _).
  }
  clear rec ps.
  revert es.
  refine ((fix rec (ms:list {s:ListEx.index os & {d:ListEx.index os & lookup s → lookup d}}) es {struct es} :=
    match es with
    | [] => _
    | (s,d)::es' => _
    end) []); revgoals. {
    destruct (om s) as [si|]; [|exact (rec ms es')].
    destruct (om d) as [di|]; [|exact (rec ms es')].
    refine (fun m => rec ([si & [di & m]]::ms) es').
  }
  clear rec es om.
  refine {|
    Diagram.Vertex := ListEx.index os;
    vertexObject := lookup;
    Arrow s d := ListEx.index (section ms s d);
    arrowMorphism x y := lookup
  |}.
Defined.

End Parse.


(*
Lemma keep_keys_fold : forall soff doff len s d,
  M.Equal (M.fold (fun k e m =>
                     if within_bool soff len k
                     then M.add (k - soff + doff) e m
                     else m) s d)
          (M.fold (fun k => M.add (k - soff + doff))
                  (keep_keys (within_bool soff len) s) d).

Lemma keep_shift_fold : forall soff doff s d,
  P.for_all (fun k _ => soff <=? k) s ->
  M.Equal (M.fold (fun k => M.add (k - soff + doff)) s d)
          (P.update d (shift_keys soff doff s)).
Proof.
  unfold P.update, shift_keys; intros.
  revert H.
  apply P.fold_rec; intros.
    rewrite P.fold_Empty; auto.
      reflexivity.
    rewrite P.fold_Empty; auto.
    apply M.empty_1.

  apply add_equal_iff in H1.
  rewrite <- H1 in H3.
  apply for_all_add_true in H3;
  destruct H3; auto; relational.
  intuition.

  assert (P.transpose_neqkey M.Equal (@M.add Mem.Word8)).
    intros ??????.
    apply add_associative; tauto.

  assert (Proper (eq ==> eq ==> M.Equal ==> M.Equal) (@M.add Mem.Word8)).
    relational.
    rewrite <- H8.
    reflexivity.

  remember (fun _ => M.add _) as f.
  assert (P.transpose_neqkey M.Equal f).
    intros ??????.
    rewrite Heqf.
    apply add_associative; intros.
    apply N.add_cancel_r in H8.
    apply Nsub_eq in H8.
        contradiction.
      a d m i t.
    a d m i t.

  assert (Proper (eq ==> eq ==> M.Equal ==> M.Equal) f).
    relational.
    rewrite <- H10.
    reflexivity.

  pose proof (@fold_Proper Mem.Word8 _ (@M.add Mem.Word8) M.Equal
                           (F.EqualSetoid _) H6 H2).
  pose proof (@fold_Proper Mem.Word8 _ f M.Equal (F.EqualSetoid _) H8 H7).

  rewrite <- H1.
  apply add_equal_iff in H1.

  erewrite P.fold_add; eauto.
  rewrite H5, Heqf.
  erewrite P.fold_add; eauto.
    reflexivity.
  unfold not; intros; destruct H11.
  contradiction H0.
  exists x.
  revert H11.
  apply P.fold_rec_bis; intros; auto.
    rewrite <- H11.
    intuition.
  repeat simplify_maps.
    left; intuition.
    apply N.add_cancel_r in H15.
    apply (proj1 (P.for_all_iff _ _)) with (k1:=k0) (e0:=x) in H3;
    [|exact H11].
    apply Nsub_eq in H15; auto; nomega.
  right; intuition; subst; tauto.
*)

Lemma Map_set_fold_keys_AbsR : forall elt r (m : M.t elt) f,
  (forall x y : M.key, E.eq (f x) (f y) -> E.eq x y)
    -> r [R Map_AbsR eq] m
    -> Map_set (fun p => (f (fst p), snd p)) r
         [R Map_AbsR eq]
         M.fold (fun k : M.key => M.add (f k)) m (M.empty elt).
Proof.
  intros.
  relational; split; intros; split; intros H1.
  - repeat teardown; inv H1.
    apply H0 in H2;
    destruct H2 as [cblk [? ?]]; subst.
    exists cblk; intuition.
    revert H1.
    apply P.fold_rec_bis; auto; intros.
      rewrite <- H1 in H3; intuition.
    repeat simplify_maps.
    right; intuition.
    apply H in H4.
  - reduction.
    revert H1.
    apply P.fold_rec_bis; auto; intros.
    simplify_maps.
    exists (k, x); simpl.
    apply H0 in H1; destruct H1.
    intuition; subst; assumption.
  - revert H1.
    apply P.fold_rec_bis; auto; intros.
    simplify_maps.
    exists cblk; simpl.
    intuition.
    pose proof (Lookup_Map_set (B:=elt) (a:=f k) (b:=cblk)
                               (fun p => (f (fst p), snd p))).
    apply H4.
    exists (k, cblk); simpl.
    apply H0 in H1; destruct H1.
    intuition; subst; assumption.
  - repeat teardown; subst; inv H1.
    apply H0 in H3.
    destruct H3 as [blk [? ?]]; subst.
    revert H1.
    apply P.fold_rec_bis; auto; intros.
      rewrite <- H1 in H3; intuition.
    repeat simplify_maps.
    right; intuition.
Qed.

Lemma overlaps_within : forall addr1 len1 addr2 len2,
  0 < len1 -> overlaps addr1 len1 addr2 len2
                <-> Ifdec addr1 < addr2
                    Then within addr1 len1 addr2
                    Else within addr2 len2 addr1.
Proof. intros; decisions; nomega. Qed.

Corollary not_overlaps_within : forall addr1 len1 addr2 len2,
  0 < len1
    -> ~ overlaps addr1 len1 addr2 len2
         <-> Ifdec addr1 < addr2
             Then ~ within addr1 len1 addr2
             Else ~ within addr2 len2 addr1.
Proof.
  split; intros.
    decisions;
    unfold not; intros;
    apply H0, overlaps_within; trivial;
    decisions; firstorder.
  unfold not; intros;
  apply overlaps_within in H1; trivial;
  decisions; firstorder.
Qed.


Require Import Coq.Logic.ProofIrrelevance.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.find_not_in.
Require Import CertiGraph.graph.path_lemmas.

Module ind.
Section ind.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.

Variable G : PreGraph V E.

Inductive reachable: V -> V -> Prop :=
  | reachable_nil: forall x, vvalid G x -> reachable x x
  | reachable_cons: forall x y z, edge G x y -> reachable y z -> reachable x z.

Lemma reachable_trans1: forall x y z,
  reachable x y -> reachable y z -> reachable x z.
Proof.
  intros.
  induction H.
  + auto.
  + apply reachable_cons with y; auto.
Qed.

End ind.
End ind.

Module ind2.
Section ind2.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Variable G : PreGraph V E.

Inductive reachable: V -> V -> Prop :=
  | reachable_nil: forall x, vvalid G x -> reachable x x
  | reachable_cons: forall x y z, reachable x y -> edge G y z -> reachable x z.

Lemma reachable_trans: forall x y z,
  reachable x y -> reachable y z -> reachable x z.
Proof.
  intros.
  induction H0.
  + auto.
  + apply reachable_cons with y; auto.
Qed.

End ind2.
End ind2.

Section ind_reachable.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context (G : PreGraph V E).

Lemma reachable_ind_reachable: forall x y, reachable G x y <-> ind.reachable G x y.
Proof.
  intros; split; intros.
  + destruct H as [[v p] [[? ?] ?]].
    simpl in H. subst. revert x H1. induction p; intros.
    - destruct H1. simpl in *. apply ind.reachable_nil. auto.
    - pose proof (good_path_tail _ _ _ H1). unfold ptail in H. specialize (IHp _ H).
      rewrite pfoot_cons. apply ind.reachable_cons with (dst G a); auto.
      clear H. destruct H1 as [? _]. apply valid_path_edge with p; auto.
  + induction H.
    - apply reachable_refl; auto.
    - apply edge_reachable with y; auto.
Qed.

Lemma reachable_ind2_reachable: forall x y, reachable G x y <-> ind2.reachable G x y.
Proof.
  intros.
  rewrite reachable_ind_reachable.
  split; intros.
  + induction H.
    - apply ind2.reachable_nil; auto.
    - apply ind2.reachable_trans with y; auto.
      apply ind2.reachable_cons with x; auto.
      apply ind2.reachable_nil.
      destruct H; tauto.
  + induction H.
    - apply ind.reachable_nil; auto.
    - apply ind.reachable_trans1 with y; auto.
      apply ind.reachable_cons with z; auto.
      apply ind.reachable_nil.
      destruct H0; tauto.
Qed.

Lemma reachable_ind_weak: forall x y,
    reachable G x y -> x = y \/ exists z, edge G x z /\ reachable G z y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H.
  induction H.
  + left; auto.
  + destruct_eq_dec x y.
    - subst y.
      apply IHreachable.
    - right.
      exists y. rewrite reachable_ind_reachable in *; auto.
Qed.

Lemma reachable_ind: forall x y,
    reachable G x y -> x = y \/ exists z, edge G x z /\ x <> z /\ reachable G z y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H.
  induction H.
  + left; auto.
  + destruct_eq_dec x y.
    - subst y.
      apply IHreachable.
    - right.
      exists y. rewrite reachable_ind_reachable in *; auto.
Qed.

Lemma reachable_same_or_edge: forall x y, vvalid G x -> reachable G x y <-> x = y \/ exists z, edge G x z /\ x <> z /\ reachable G z y.
Proof.
  intros. split; intros.
  - apply reachable_ind; auto.
  - destruct H0.
    + subst y. apply reachable_refl. auto.
    + destruct H0 as [z [? [? ?]]]. apply edge_reachable with z; auto.
Qed.

Lemma reachable_same_or_edge': forall x y,
    vvalid G x -> reachable G x y <->
                  x = y \/ exists z, edge G x z /\ reachable G z y.
Proof.
  intros. split; intros.
  - apply reachable_ind_weak; auto.
  - destruct H0.
    + subst y. apply reachable_refl. auto.
    + destruct H0 as [z [? ?]]. apply edge_reachable with z; auto.
Qed.

Lemma reachable_ind': forall x S y, vvalid G x -> step_list G x S -> (reachable G x y <-> x = y \/ reachable_through_set G S y).
Proof.
  intros.
  unfold reachable_through_set.
  split; intros.
  + apply reachable_ind in H1.
    destruct H1; [left; auto | right].
    destruct H1 as [z ?]; exists z.
    split; [| tauto].
    rewrite (H0 z).
    destruct H1 as [[? [? ?]] ?].
    auto.
  + destruct H1 as [? | [? [? ?]]].
    - subst; apply reachable_refl; auto.
    - rewrite (H0 x0) in H1.
      apply edge_reachable with x0; auto.
      split; [| split]; auto.
      apply reachable_head_valid in H2; auto.
Qed.

Lemma step_list_step_reachable: forall root s d l, reachable G root s -> reachable G root d -> G |= s ~> d -> step_list G root l -> reachable_through_set G l d.
Proof.
  intros. rewrite (reachable_ind' _ l) in H; auto. 2: apply reachable_head_valid in H0; auto. destruct H.
  + subst s. exists d. split.
    - hnf in H2. rewrite H2. destruct H1 as [? [? ?]]. auto.
    - apply reachable_by_refl; auto. apply reachable_foot_valid in H0. auto.
  + apply reachable_through_set_step with s; auto.
    - apply reachable_foot_valid in H0; auto.
    - destruct H1 as [? [? ?]]; auto.
Qed.

Lemma closed_edge_closed_reachable: forall l,
  (forall x y, In x l -> edge G x y -> In y l) ->
  (forall x y, In x l -> reachable G x y -> In y l).
Proof.
  intros.
  rewrite reachable_ind_reachable in H1.
  induction H1.
  + auto.
  + apply IHreachable.
    apply H with x; auto.
Qed.

Lemma reachable_list_bigraph_in:
  forall {l1 l2 x} l r,
    vvalid G x ->
    reachable_list G l l1 ->
    reachable_list G r l2 ->
    (forall y, step G x y <-> y = l \/ y = r) ->
    forall y, reachable G x y <-> x = y \/ In y l1 \/ In y l2.
Proof.
  intros. specialize (H0 y). specialize (H1 y). split; intro.
  + apply reachable_ind in H3. destruct H3 as [? | [z [[? [? ?]] [? ?]]]]; auto.
    rewrite H2 in *. destruct H5.
    - subst. rewrite <- H0 in H7. auto.
    - subst. rewrite <- H1 in H7. auto.
  + destruct H3 as [? | [? | ?]].
    - subst. apply reachable_by_refl; auto.
    - rewrite H0 in H3. apply edge_reachable_by with l.
      * auto.
      * split; auto. split. apply reachable_head_valid in H3; auto. rewrite H2; auto.
      * apply H3.
    - rewrite H1 in H3. apply edge_reachable_by with r.
      * hnf; auto.
      * split; auto. split. apply reachable_head_valid in H3; auto. rewrite H2; auto.
      * apply H3.
Qed.

Lemma reachable_general_ind: forall (P: V -> Prop),
  (forall x y, edge G x y -> P x -> P y) ->
  forall x y,
  reachable G x y ->
  P x ->
  P y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H0.
  induction H0.
  + auto.
  + firstorder.
Qed.

Lemma reachable_through_general_ind: forall (P: V -> Prop),
  (forall x y, edge G x y -> P x -> P y) ->
  forall S y,
  reachable_through_set G S y ->
  Forall P S ->
  P y.
Proof.
  intros.
  destruct H0 as [x [? ?]].
  rewrite Forall_forall in H1.
  specialize (H1 _ H0).
  eapply reachable_general_ind; eauto.
Qed.

Lemma edge_preserved_rev_foot: forall (P: V -> Prop),
  (forall x y, reachable G x y -> P x -> P y) ->
  forall x y,
  reachable G x y ->
  ~ P y ->
  reachable_by G x (Complement _ P) y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H0.
  induction H0.
  + apply reachable_by_refl; auto.
  + apply edge_reachable_by with y; auto.
    rewrite <- reachable_ind_reachable in H2.
    intro.
    apply (H x z) in H3; [auto |].
    apply edge_reachable with y; auto.
Qed.

Lemma edge_preserved_rev_foot0: forall (P: V -> Prop),
  (forall x y, reachable G x y -> P x -> P y) ->
  forall l y,
  reachable_through_set G l y ->
  ~ P y ->
  reachable_by_through_set G l (Complement _ P) y.
Proof.
  intros.
  destruct H0 as [s [? ?]]; exists s; split; auto.
  apply edge_preserved_rev_foot; auto.
Qed.

End ind_reachable.

Section EQUIV.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.

Lemma edge_equiv_reachable_equiv: forall (g1 g2: PreGraph V E),
  (forall x, vvalid g1 x <-> vvalid g2 x) ->
  (forall x y, edge g1 x y <-> edge g2 x y) -> forall n, Same_set (reachable g1 n) (reachable g2 n).
Proof.
  cut (forall (g1 g2 : PreGraph V E), (forall x, vvalid g1 x <-> vvalid g2 x) -> (forall x y, edge g1 x y <-> edge g2 x y) -> forall n, Included (reachable g1 n) (reachable g2 n)).
  1: intros; split; intros; apply H; [auto | auto | symmetry; auto | symmetry; auto].
  intros; intro; intros.
  unfold Ensembles.In in *.
  rewrite @reachable_ind_reachable in *.
  induction H1.
  + constructor. rewrite H in H1; auto.
  + rewrite H0 in H1.
    apply ind.reachable_cons with y; auto.
Qed.

Lemma si_reachable: forall (g1 g2: PreGraph V E) n,  g1 ~=~ g2 -> Same_set (reachable g1 n) (reachable g2 n).
Proof.
  intros.
  apply edge_equiv_reachable_equiv.
  + destruct H; auto.
  + intros; apply edge_si.
    auto.
Qed.

Lemma si_reachable_direct: forall (g1 g2: PreGraph V E) x y,  g1 ~=~ g2 -> (reachable g1 x y <-> reachable g2 x y).
Proof.
  intros. apply (si_reachable _ _ x) in H. destruct H. split; intros.
  + apply (H y); auto.
  + apply (H0 y); auto.
Qed.

Lemma si_eq_as_set_reachable_through_set: forall (g1 g2: PreGraph V E) S1 S2 n, g1 ~=~ g2 -> eq_as_set S1 S2 -> (reachable_through_set g1 S1 n <-> reachable_through_set g2 S2 n).
Proof.
  cut (forall (g1 g2 : PreGraph V E) S1 S2 (n : V), g1 ~=~ g2 -> eq_as_set S1 S2 ->
         (reachable_through_set g1 S1 n -> reachable_through_set g2 S2 n)).
  1: intros; split; apply H; [| | symmetry | symmetry]; auto.
  intros.
  intros.
  unfold reachable_through_set in *.
  destruct H1 as [s [? ?]].
  exists s; split.
  + pose proof proj1 H0 s.
    auto.
  + destruct (si_reachable g1 g2 s H).
    apply H3; auto.
Qed.

Lemma si_reachable_through_set: forall (g1 g2: PreGraph V E) S n, g1 ~=~ g2 -> (reachable_through_set g1 S n <-> reachable_through_set g2 S n).
Proof.
  intros.
  apply si_eq_as_set_reachable_through_set; auto.
  reflexivity.
Qed.

#[global] Instance reachable_proper: Proper (structurally_identical ==> (@eq V) ==> (@eq V) ==> iff) reachable.
Proof.
  do 3 (hnf; intros); subst.
  apply si_reachable_direct.
  auto.
Defined.

#[global] Instance reachable_proper': Proper (structurally_identical ==> (@eq V) ==> Same_set) reachable.
Proof.
  do 2 (hnf; intros); subst.
  rewrite Same_set_spec in *.
  hnf; intros.
  apply si_reachable_direct.
  auto.
Defined.

#[global] Instance reachable_through_set_proper: Proper (structurally_identical ==> eq_as_set ==> (@eq V) ==> iff) reachable_through_set.
Proof.
  do 3 (hnf; intros); subst.
  apply si_eq_as_set_reachable_through_set; auto.
Defined.

#[global] Instance reachable_through_set_proper': Proper (structurally_identical ==> eq_as_set ==> @Same_set V) reachable_through_set.
Proof.
  do 2 (hnf; intros); subst.
  rewrite Same_set_spec in *.
  hnf; intros.
  apply si_eq_as_set_reachable_through_set; auto.
Defined.

End EQUIV.


Require Import Coq.PArith.BinPos.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.PositiveContext.
Require Import Crypto.Compilers.Z.Named.DeadCodeElimination.
Require Import Crypto.Compilers.Named.DeadCodeEliminationInterp.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Named.Syntax.

Section language.
  Context {interp_base_type : base_type -> Type}
          {interp_op : forall s d, op s d -> interp_flat_type interp_base_type s -> interp_flat_type interp_base_type d}
          {Name : Type}
          {InContext : Context Name (fun _ : base_type => positive)}
          {InContextOk : ContextOk InContext}
          {Name_beq : Name -> Name -> bool}
          {InterpContext : Context Name interp_base_type}
          {InterpContextOk : ContextOk InterpContext}
          (Name_bl : forall n1 n2, Name_beq n1 n2 = true -> n1 = n2)
          (Name_lb : forall n1 n2, n1 = n2 -> Name_beq n1 n2 = true).

  Local Notation EliminateDeadCode := (@EliminateDeadCode Name InContext).
  Local Notation PContext var := (@PositiveContext base_type var base_type_beq internal_base_type_dec_bl).

  Lemma interp_EliminateDeadCode
        t e new_names
        (ctxi_interp : PContext _)
        (ctxr_interp : InterpContext)
        eout v1 v2 x
    : @EliminateDeadCode t e new_names = Some eout
      -> interp (interp_op:=interp_op) (ctx:=ctxr_interp) eout x = Some v1
      -> interp (interp_op:=interp_op) (ctx:=ctxi_interp) e x = Some v2
      -> v1 = v2.
  Proof using InContextOk InterpContextOk Name_bl Name_lb.
    eapply interp_EliminateDeadCode; eauto using internal_base_type_dec_lb.
  Qed.

  Lemma InterpEliminateDeadCode
        t e new_names
        eout
        v1 v2 x
    : @EliminateDeadCode t e new_names = Some eout
      -> Interp (Context:=InterpContext) (interp_op:=interp_op) eout x = Some v1
      -> Interp (Context:=PContext _) (interp_op:=interp_op) e x = Some v2
      -> v1 = v2.
  Proof using InContextOk InterpContextOk Name_bl Name_lb.
    apply interp_EliminateDeadCode.
  Qed.
End language.