From iris Require Import program_logic.weakestpre.
From iris.program_logic Require Import ectx_language ectxi_language.
From st.STLCmuST Require Import lang types typing.
From st.backtranslations.st_sem.correctness.sem_le_st.logrel Require Import lift definition.

Lemma rtc_bind_help n e w u σ σ' u' σ'' :
  nsteps STLCmuST_step n (σ, RunST e) (σ'', of_val u') →
  rtc STLCmuST_step (σ'', RunST (App (of_val w) (of_val u'))) (σ', of_val u) →
  rtc STLCmuST_step (σ, RunST (Bind e (of_val w))) (σ', of_val u).
Proof.
   revert w e u u' σ σ' σ''.
    induction n => w e u u' σ σ' σ'' Hrd1 Hrd2 /=.
  - inversion Hrd1 as [Hs1 Hs2 Hs3 Hs4|]; subst.
    assert (Hkv : to_val (RunST e) = Some u') by
        by rewrite H to_of_val.
    exfalso; by inversion Hkv.
  - inversion Hrd1 as [|Hs1 Hs2 [σ2 e2] Hs4 Hs5 Hs6]; subst; simpl in *.
    inversion Hs5 as [? ? ? Hfl ? Hhd]; subst.
    destruct K as [|[] K] using rev_ind; simpl in *;
      (try rewrite fill_app /= in Hfl); inversion Hfl; subst.
    + inversion Hhd; subst.
      * specialize (IHn _ _ _ _ _ _ _ Hs6 Hrd2).
        apply rtc_l with (y := (σ2, RunST (Bind e' w))); eauto.
        apply head_prim_step.
        econstructor.
        inversion H1 as [K ? ? ?]; subst.
        eapply (@Ectx_step eff_ectx_lang _ _ _ _ _ _ (K ++ [BindECtx _])); eauto;
          by rewrite /= (@fill_app eff_ectxi_lang) /=.
      * inversion Hs6; subst; simpl in *.
        -- eapply rtc_l; simpl; eauto.
           apply head_prim_step.
           econstructor.
           apply head_prim_step.
           econstructor; eauto using to_of_val.
        -- destruct y. erewrite (language.val_stuck) in H1; eauto. inversion H1.
    + rewrite fill_app in Hs6 Hrd2. specialize (IHn _ _ _ _ _ _ _ Hs6 Hrd2).
      apply rtc_l with (y := (σ2, (RunST (Bind (fill K e2') (of_val w))))); auto.
      apply (fill_prim_step [BindLCtx _; RunSTCtx]).
      apply (fill_prim_step K). by apply head_prim_step.
Qed.

Lemma rtc_bind_lemma (σ0 σ1 σ2 σ3 : state) (v f w s r : val) :
  rtc STLCmuST_step (σ0, RunST v) (σ1, of_val w) →
  rtc STLCmuST_step (σ1, ((of_val f) (of_val w))) (σ2, of_val s) →
  rtc STLCmuST_step (σ2, RunST s) (σ3, of_val r) →
  rtc STLCmuST_step (σ0, RunST (Bind v f)) (σ3, of_val r).
Proof.
  intros H0 H1 H2. destruct (rtc_nsteps_1 _ _ H0) as [n H0'].
  apply (rtc_bind_help _ _ _ _ _ _ _ _ H0').
  apply rtc_transitive with (y := (σ2, RunST s)). by apply (fill_STLCmuST_step_rtc [RunSTCtx]).
  auto.
Qed.

From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import invariants gen_heap.
From st.backtranslations.st_sem Require Import ghost heap_emul.base.
From st.STLCmuVS Require Import lang.
From st Require Import resources.

Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

Section valrel_cons_ren.

  Context `{Σ : !gFunctors} `{sem_le_stΣ_inst : !sem_le_stΣ Σ}.

  (* super boring lemma *)
  Lemma valrel_typed_cons_ren γ γ' Δ : ∀ τ v v', valrel_typed ((γ,γ') :: Δ) τ.[ren (+1)] v v' ⊣⊢ valrel_typed Δ τ v v'.
  Proof.
    iLöb as "IHlob".
    iIntros (τ). iInduction τ as [ | | | τ1 τ2 | τ1 τ2 | τ1 τ2 | τb | | τ1 τ2 | τ1 τ2 ] "IH".
    - setoid_rewrite valrel_typed_TUnit_unfold; auto.
    - setoid_rewrite valrel_typed_TBool_unfold; auto.
    - setoid_rewrite valrel_typed_TInt_unfold; auto.
    - setoid_rewrite valrel_typed_TProd_unfold.
      iIntros (v v').
      iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v2 v1' v2') "(eq1 & eq2 & H1 & H2)".
        repeat iExists _. repeat iSplit; auto. by iApply "IH". by iApply "IH1".
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v2 v1' v2') "(eq1 & eq2 & H1 & H2)".
        repeat iExists _. repeat iSplit; auto. by iApply "IH". by iApply "IH1".
    - setoid_rewrite valrel_typed_TSum_unfold.
      iIntros (v v').
      iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v1') "[(eq1 & eq2 & H) | (eq1 & eq2 & H)]".
        * repeat iExists _. iLeft. repeat iSplit; eauto. by iApply "IH".
        * repeat iExists _. iRight. repeat iSplit; eauto. by iApply "IH1".
      + iIntros "Hdes". iDestruct "Hdes" as (v1 v1') "[(eq1 & eq2 & H) | (eq1 & eq2 & H)]".
        * repeat iExists _. iLeft. repeat iSplit; eauto. by iApply "IH".
        * repeat iExists _. iRight. repeat iSplit; eauto. by iApply "IH1".
    - setoid_rewrite valrel_typed_TArrow_unfold.
      iIntros (w w'). iSplit.
      + iIntros "#H". iModIntro. iIntros (v v') "#H1".
        iApply (lift_wand _ (valrel_typed ((γ,γ') :: Δ) τ3.[ren (+1)])). iIntros (x x') "Hxx'". by iApply "IH1".
        iApply "H". by iApply "IH".
      + iIntros "#H". iModIntro. iIntros (v v') "#H1".
        iApply (lift_wand _ (valrel_typed (Δ) τ3)). iIntros (x x') "Hxx'". by iApply "IH1".
        iApply "H". by iApply "IH".
    - setoid_rewrite valrel_typed_TRec_unfold.
      iIntros (v v'). iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (w w') "(eq & eq' & H)".
        iExists w, w'. repeat iSplit; auto. iNext. iApply "IHlob". by asimpl.
      + iIntros "Hdes". iDestruct "Hdes" as (w w') "(eq & eq' & H)".
        iExists w, w'. repeat iSplit; auto. iNext.
        assert (τb.[up (ren (+1))].[TRec τb.[up (ren (+1))]/] =
                τb.[TRec τb/].[ren (+1)]
               ) as eq; first by asimpl. rewrite eq. by iApply "IHlob".
    - setoid_rewrite valrel_typed_TVar_unfold. auto.
    - setoid_rewrite valrel_typed_TSTRef_unfold; auto.
      destruct τ1; auto; destruct (Δ !! X) as [[γ'' γ''']|] eqn:eq; rewrite /= eq; try done.
      iIntros (v v'). iSplit.
      + iIntros "Hdes". iDestruct "Hdes" as (i l) "(-> & -> & Hil & H)". iExists i, l. repeat iSplit; auto.
        iApply (inv_iff with "H"). repeat iModIntro. iSplit.
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
      + iIntros "Hdes". iDestruct "Hdes" as (i l) "(-> & -> & Hil & H)". iExists i, l. repeat iSplit; auto.
        iApply (inv_iff with "H"). repeat iModIntro. iSplit.
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
        * iIntros "Hdes". iDestruct "Hdes" as (w w') "[Hi [Hl Hww']]". iExists w, w'. iFrame "Hi Hl". by iApply "IH1".
    - setoid_rewrite valrel_typed_TST_unfold; auto.
      destruct τ1; auto; destruct (Δ !! X) as [[γ'' γ''']|] eqn:eq; rewrite /= eq; try done.
      iIntros (w w'). iSplit.
      + iIntros "#H". iIntros (ps σ). iModIntro. iIntros "Hσ AuthVals AuthLocs". iSpecialize ("H" $! ps σ with "Hσ AuthVals AuthLocs"). iApply (wp_wand with "H").
        iIntros (v) "Hdes". iDestruct "Hdes" as (w1 w1' ps1 σ1) "(-> & Hσ1 & Hauth1 & Hauth2 & Hstep & H)". iExists w1, w1', ps1, σ1. iFrame. iSplit; auto.
        by iApply "IH1".
      + iIntros "#H". iIntros (ps σ). iModIntro. iIntros "Hσ AuthVals AuthLocs". iSpecialize ("H" $! ps σ with "Hσ AuthVals AuthLocs"). iApply (wp_wand with "H").
        iIntros (v) "Hdes". iDestruct "Hdes" as (w1 w1' ps1 σ1) "(-> & Hσ1 & Hauth1 & Hauth2 & Hstep & H)". iExists w1, w1', ps1, σ1. iFrame. iSplit; auto.
        by iApply "IH1".
  Qed.

End valrel_cons_ren.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple.
Require Import bitsrep bitsops bitsopsprops monad writer reg instr instrsyntax program programassem cursor.
Require Import pecoff cfunc.

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

Open Scope instr_scope.
Open Scope string_scope.

Require Import call.
Example counterDLL :=
  GLOBAL Get as "Get";
  GLOBAL Inc as "Inc";
  GLOBAL Counter;
  SECTION CODE
    Inc:;;  mkbody_toyfun (MOV ECX, Counter;; INC [ECX]);;
    Get:;;  mkbody_toyfun (MOV ECX, Counter;; MOV EAX, [ECX]);
  SECTION DATA
    Counter:;; dd #0.

Compute makeDLL #x"00AC0000" "counter.dll" counterDLL.

(*
Require Import SPred septac spectac spec safe pointsto cursor instr.
Require Import basic basicprog program instrsyntax macros instrrules.
Require Import Setoid RelationClasses Morphisms.

Example counterModuleSpec IAT P Inc Get :=
      (Forall c: DWORD, toyfun Inc (P c ** ECX? ** OSZCP?) (P (c +# 1) ** ECX? ** OSZCP?))
    //\\
      (Forall c: DWORD, toyfun Get (EAX? ** P c ** ECX? ** OSZCP?) (EAX ~= c ** P c ** ECX? ** OSZCP?))
    <@ (IAT :-> (Inc, Get)).

Example counterModuleCode (Inc Get Counter: DWORD) :=
(*  LOCAL Inc; LOCAL Get; LOCAL Counter;*)
    Inc:;;  mkbody_toyfun (MOV ECX, Counter;; INC [ECX]);;
    Get:;;  mkbody_toyfun (MOV ECX, Counter;; MOV EAX, [ECX]).

Example counterModuleData :=
    dd #0.

Example counterModuleIAT Inc Get :=
    dd Inc;; dd Get.

Require Import flags.
Theorem counterModuleCorrect (codeStart codeEnd dataStart:DWORD):
  |-- Forall Inc, Forall Get,
      counterModuleSpec codeStart (fun v => dataStart :-> v) Inc Get <@ (codeStart -- codeEnd :-> counterModuleCode Inc Get dataStart).
Proof.
rewrite /counterModuleSpec.
rewrite /counterModuleCode.
specintros => Inc Get. unfold_program.

specintros => i1 -> -> i2 i3 -> ->.
rewrite !empSPL.
specsplit.
(* Inc *)
specintros => c.
rewrite <- spec_reads_merge.
rewrite <- spec_reads_frame.
  etransitivity; [|apply toyfun_mkbody]. specintro => iret.
  rewrite /flagAny. specintros => O S Z C P. autorewrite with push_at.
  basicapply MOV_RI_rule.
  basicapply INC_M_rule. rewrite addB0.
  rewrite /OSZCP. sbazooka. rewrite addB1 addB0. rewrite /regAny.
  sbazooka.
  rewrite /OSZCP. ssimpl. reflexivity.

(* Get *)
specintros => c.
rewrite spec_reads_swap.
rewrite <- spec_reads_frame.
rewrite <- spec_reads_merge.
rewrite <- spec_reads_swap.
rewrite <- spec_reads_frame.
  etransitivity; [|apply toyfun_mkbody]. specintro => iret.
  rewrite /flagAny. specintros => O S Z C P. autorewrite with push_at.
  basicapply MOV_RI_rule.
  basicapply MOV_RM0_rule. rewrite /regAny. sbazooka.
Qed.

Example useCounterModule IAT : program :=
  MOV EDI, IAT;; call_toyfun [EDI];;
  MOV EDI, IAT;; call_toyfun [EDI];;
  MOV EDI, IAT;; call_toyfun [EDI+4].

Example useCounterModuleCorrect (codeStart codeEnd dataStart Inc Get IAT: DWORD):
  counterModuleSpec codeStart (fun v => dataStart :-> v) Inc Get
  |-- basic (EAX?) (useCounterModule IAT) (EAX ~= #2) @
      (EDI? ** OSZCP? ** retreg?) <@ (IAT :-> (Inc,Get)).
Proof.
  rewrite /useCounterModule. autorewrite with push_at.
  rewrite <- spec_reads_frame.
  eapply basic_seq.
  basicapply MOV_RI_rule.
  rewrite /counterModuleSpec.
  apply landL1.
  - (*apply lforallL with c.*)
    eapply basic_basic_context.
    - have H := toyfun_call. setoid_rewrite spec_at_basic in H. apply H.
    - by apply spec_later_weaken.
    - by ssimpl.
    done.
  apply lforallL with (a +# 2).
  eapply basic_basic_context.
  - have H := toyfun_call. setoid_rewrite spec_at_basic in H. apply H.
  - by apply spec_later_weaken.
  - by ssimpl.
  rewrite -addB_addn. rewrite -[2+2]/4. by ssimpl.
Qed.

Example useCounterSpec IAT :

*)


(** * Push-Button Synthesis of fancy mongomery reduction : Reification Cache *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.derive.Derive.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.FancyMontgomeryReduction.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Local Open Scope Z_scope.

Import Associational Positional.
Import FancyMontgomeryReduction.MontgomeryReduction.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Module Export MontgomeryReduction.
  Derive reified_montred_gen
         SuchThat (is_reification_of reified_montred_gen montred')
         As reified_montred_gen_correct.
  Proof. Time cache_reify (). Time Qed.
  Module Export ReifyHints.
#[global]
    Hint Extern 1 (_ = _) => apply_cached_reification montred' (proj1 reified_montred_gen_correct) : reify_cache_gen.
#[global]
    Hint Immediate (proj2 reified_montred_gen_correct) : wf_gen_cache.
#[global]
    Hint Rewrite (proj1 reified_montred_gen_correct) : interp_gen_cache.
  End ReifyHints.
  Local Opaque reified_montred_gen. (* needed for making [autorewrite] not take a very long time *)
End MontgomeryReduction.


Require Export Relations Wellfounded.
Require Import Sat.
Require Import ZF ZFcoc ZFuniv_real.
Require Import ZFlambda.
Require Import Models SnModels.
Require GenRealSN.
Set Implicit Arguments.

(** Strong normalization proof of the Calculus of Constructions.
    It is based on GenRealSN, so it does support strong eliminations.
    Inhabitation of all types is obtained by adding the empty set in every
    type (cf ZFuniv_real). The product is interpreted by the set of *partial*
    functions.
 *)

Module SN := GenRealSN.MakeModel CC_Real.
Export SN.
Hint Unfold inX.
Existing Instance in_ext.

(** Derived properties *)

Notation daimont := Sat.SatSet.daimon.

Lemma val_ok_cons_default e T i j :
  val_ok e i j ->
  T <> kind ->
  val_ok (T::e) (V.cons empty i) (I.cons daimont j).
intros.
apply vcons_add_var; trivial.
split.
 red; auto.
 apply varSAT.
Qed.

Lemma El_int_prod U V i :
  El (int (Prod U V) i) == cc_prod (El (int U i)) (fun x => El (int V (V.cons x i))).
simpl.
apply El_prod.
do 2 red; intros.
rewrite H0; reflexivity.
Qed.

Lemma El_int_arr U V i :
  El (int (Prod U (lift 1 V)) i) == cc_arr (El (int U i)) (El (int V i)).
rewrite El_int_prod.
apply cc_prod_morph; auto with *.
red; intros.
rewrite int_cons_lift_eq; reflexivity.
Qed.

Lemma Real_int_prod U V i f :
  f ∈ cc_prod (El (int U i)) (fun x => El (int V (V.cons x i))) ->
  eqSAT (Real (int (Prod U V) i) f)
        (piSAT (int U i) (fun x => int V (V.cons x i)) (cc_app f)).
simpl; intros.
apply Real_prod.
 do 2 red; intros.
 rewrite H1; reflexivity.

 change (f ∈ El (int (Prod U V) i)).
 rewrite El_int_prod; trivial.
Qed.

Lemma Real_int_arr U V i f :
  f ∈ cc_arr (El (int U i)) (El (int V i)) ->
  eqSAT (Real (int (Prod U (lift 1 V)) i) f)
        (piSAT (int U i) (fun _ => int V i) (cc_app f)).
intros.
rewrite Real_int_prod.
 apply piSAT_morph; auto with *.
  red; intros.
  apply int_cons_lift_eq.

  red; intros; apply cc_app_morph; auto with *.

 revert H; apply eq_elim; apply cc_prod_ext; auto with *.
 red; intros.
 symmetry; apply El_morph; apply int_cons_lift_eq.
Qed.

Lemma kind_ok_trivial T : kind_ok T.
exists nil.
exists T; simpl; auto with *.
exists empty; auto with *.
Qed.
Hint Resolve kind_ok_trivial.

(** ** Extendability *)
Definition cst (x:set) : term.
(* begin show *)
left; exists (fun _ =>x) (fun _ =>Lambda.K).
(* end show *)
 do 2 red; reflexivity.
 do 2 red; reflexivity.
 red; reflexivity.
 red; reflexivity.
Defined.

Definition mkSET (x:set) := cst (mkTY x (fun _ => snSAT)).

Lemma mkSET_kind e x :
  typ e (mkSET x) kind.
red; intros.
split;[discriminate|].
split; trivial.
apply Lambda.sn_K.
Qed.

Lemma cst_typ e x y :
  in_set x y ->
  typ e (cst x) (mkSET y).
red; intros.
apply in_int_intro; intros; try discriminate.
apply and_split; intros.
 simpl.
 red; rewrite El_def.
 apply union2_intro2; trivial.

 simpl.
 rewrite Real_def.
  apply Lambda.sn_K.

  reflexivity.

  apply union2_intro2; trivial.
Qed.
Lemma cst_eq_typ e x y :
  x == y ->
  eq_typ e (cst x) (cst y).
red; simpl; intros; trivial.
Qed.

Lemma cst_eq_typ_inv x y :
  eq_typ nil (cst x) (cst y) ->
  x == y.
intros.
assert (val_ok nil (V.nil empty) (I.nil Lambda.K)).
 red; intros.
 destruct n; inversion H0.
apply H in H0.
simpl in H0; trivial.
Qed.

Lemma mkSET_eq_typ e x y :
  x == y ->
  eq_typ e (mkSET x) (mkSET y).
red; simpl; intros; trivial.
apply mkTY_ext; auto with *.
Qed.

Lemma mkSET_eq_typ_inv x y :
  eq_typ nil (mkSET x) (mkSET y) ->
  x == y.
intros.
assert (val_ok nil (V.nil empty) (I.nil Lambda.K)).
 red; intros.
 destruct n; inversion H0.
apply H in H0.
simpl in H0.
apply couple_injection in H0; destruct H0; trivial.
Qed.

Definition sub_typ_covariant : forall e U1 U2 V1 V2,
  U1 <> kind ->
  eq_typ e U1 U2 ->
  sub_typ (U1::e) V1 V2 ->
  sub_typ e (Prod U1 V1) (Prod U2 V2).
intros.
apply sub_typ_covariant; trivial.
unfold eqX, inX; intros.
rewrite El_prod in H3; trivial.
apply cc_eta_eq in H3; trivial.
Qed.

(** ** Choice *)
(*Require Import ZFcoc SATtypes.
Module Lc:=Lambda.

Definition Ch (X:term) : term.
(* begin show *)
left;
exists (fun i => mkTY (trunc (El(int X i)))
                      (fun _ => depSAT(fun Y=>forall x,x ∈El(int X i)->
                                 inclSAT(cartSAT(Real (int X i) x)unitSAT) Y)
                                      (fun Y=>Y)))
       (fun j => tm X j).
(* end show *)
do 2 red; intros.
apply mkTY_ext; intros.
 rewrite H; auto with *.

 apply interSAT_morph_subset; simpl; intros; auto with *.
 apply fa_morph; intros z.
 rewrite H; reflexivity.

do 2 red; intros; apply tm_morph; auto with *.

red; intros; apply tm_liftable.
red; intros; apply tm_substitutive.
Defined.

Definition ChI (W:term) : term.
(* begin show *)
left; exists (fun i => empty) (fun j => COUPLE (tm W j) ID).
(* end show *)
do 2 red; intros; reflexivity.

do 2 red; intros.
f_equal; trivial.
apply tm_morph; auto with *.

 (**)
 red; intros.
 unfold COUPLE; simpl.
 rewrite tm_liftable.
 rewrite Lc.permute_lift; reflexivity.
 (**)
 red; intros.
 unfold COUPLE; simpl.
 rewrite tm_substitutive.
 rewrite Lc.commut_lift_subst; reflexivity.
Defined.

Lemma ChI_typ e X W :
  X <> kind ->
  typ e W X ->
  typ e (ChI W) (Ch X).
unfold typ.
intros Xnk tyW; intros.
apply in_int_intro; try discriminate.
apply and_split; simpl; intros.
 red; auto.

 red in H0; rewrite El_def in H0.
 specialize tyW with (1:=H).
 apply in_int_not_kind in tyW; trivial.
 destruct tyW.
 rewrite Real_def; intros; auto.
 2:apply interSAT_morph_subset; simpl; auto with *.
 apply interSAT_intro.
  exists snSAT; intros.
  red; intros; apply snSAT_intro.
  apply sat_sn in H4; trivial.

  intros (Y,?); simpl.
  apply i0 with (int W i); trivial.
  apply cartSAT_intro; trivial.
  apply ID_intro.
Qed.

Definition ChE (X C:term) : term.
  left; exists (fun i => ZFrepl.uchoice (fun x => x ∈ Elt (int X i)))
               (fun j => Lc.App (tm C j) (Lc.Abs (Lc.Abs (Lc.Ref 1)))).
  admit.
  admit.
  admit.
  admit.
Defined.

Lemma ChE_typ e W X :
  X <> kind ->
  typ e W (Ch X) ->
  typ e (ChE X W) X.
unfold typ; intros Xnk tyW i j valok.
specialize tyW with (1:=valok).
apply in_int_not_kind in tyW;[|discriminate].
destruct tyW as (tyW,satW).
red in tyW; simpl in tyW; rewrite El_def in tyW.
simpl in satW; rewrite Real_def in satW; trivial.
apply in_int_intro; trivial; try discriminate.
apply and_split; intros.
 red; simpl.
 apply cc_bot_intro.
 apply ZFrepl.uchoice_def.
 split.
  intros.
  rewrite <- H; trivial.
 split; intros.
  admit.
  admit.

 simpl.
 red in H; simpl in H.
 set (w:=ZFrepl.uchoice (fun x => x ∈ Elt(int X i))) in *.
 clearbody w.
 apply depSAT_elim' in satW.
 red in satW.
 eapply cartSAT_case with (X:=Real(int X i) w) (Y:=unitSAT).
 apply satW; intros.
 intros ? h; apply h.
 reflexivity.

 eexact (fun _ h => h).
 assert (inSAT (tm W j) ; rewrite El_def in H.
split.

(** ** Unique choice *)

Definition Tr (X:term) : term.
(* begin show *)
left;
exists (fun i => mkTY (ZFcoc.trunc (El(int X i)))
                      (fun _ => interSAT(fun Y:{Y|forall x,x ∈El(int X i)->
                                           inclSAT(Real (int X i) x) Y}=>proj1_sig Y)))
       (fun j => tm X j).
(* end show *)
do 2 red; intros.
apply mkTY_ext; intros.
 rewrite H; auto with *.

 apply interSAT_morph_subset; simpl; intros; auto with *.
 apply fa_morph; intros z.
 rewrite H; reflexivity.

do 2 red; intros; apply tm_morph; auto with *.

red; intros; apply tm_liftable.
red; intros; apply tm_substitutive.
Defined.

Definition TrI (W:term) : term.
(* begin show *)
left; exists (fun i => empty) (fun j => tm W j).
(* end show *)
do 2 red; intros; reflexivity.

do 2 red; intros; apply tm_morph; auto with *.

red; intros; apply tm_liftable.
red; intros; apply tm_substitutive.
Defined.

Lemma TrI_typ e X W :
  X <> kind ->
  typ e W X ->
  typ e (TrI W) (Tr X).
unfold typ.
intros Xnk tyW; intros.
apply in_int_intro; try discriminate.
apply and_split; simpl; intros.
 red; auto.

 red in H0; rewrite El_def in H0.
 specialize tyW with (1:=H).
 apply in_int_not_kind in tyW; trivial.
 destruct tyW.
 rewrite Real_def; intros; auto.
  apply interSAT_intro' with (F:=fun X=>X); intros.
   apply sat_sn in H2; trivial.

   apply (H3 (int W i)); trivial.

  apply interSAT_morph_subset; simpl; auto with *.
Qed.

Definition TrE (X P F W:term) : term.
(* begin show *)
  left; exists (fun i => cond_set (int W i ∈ Elt (int (Tr X) i))
                                  (trunc_descr (El(int P i))))
               (fun j => Lambda.App (tm F j) (tm W j)).
(* end show *)
do 2 red; intros; rewrite H; reflexivity.

do 2 red; intros; rewrite H; reflexivity.

red; intros.
do 2 rewrite tm_liftable.
reflexivity.

red; intros.
do 2 rewrite tm_substitutive.
reflexivity.
Defined.

Definition EQ A t1 t2 :=
  Prod (Prod A prop) (Prod (App (Ref 0) (lift 1 t1)) (App (Ref 1) (lift 2 t2))).

Definition IsProp X :=
  Prod X (Prod (lift 1 X) (EQ (lift 2 X) (Ref 1) (Ref 0))).

Lemma TrE_typ e X P Pp F W :
  P <> kind ->
  typ e Pp (IsProp P) ->
  typ e F (Prod X (lift 1 P)) ->
  typ e W (Tr X) ->
  typ e (TrE X P F W) P.
unfold typ; intros Pnk tyPp tyF tyW i j valok.
specialize tyPp with (1:=valok); apply in_int_not_kind in tyPp;[|discriminate].
specialize tyF with (1:=valok); apply in_int_not_kind in tyF;[|discriminate].
specialize tyW with (1:=valok); apply in_int_not_kind in tyW;[|discriminate].
clear valok.
destruct tyPp as (isPp,_).
destruct tyF as (tyF,satF).
destruct tyW as (tyW,satW).
apply in_int_intro; trivial; try discriminate.
split; simpl.
 red.
 rewrite Elt_def.
 red in tyW; simpl in tyW; rewrite El_def in tyW.
 apply cc_bot_ax in tyW; destruct tyW.
  admit.
 rewrite cond_set_ok; trivial.
 apply trunc_ind with (El(int X i)) (fun x => cc_app (int F i) x) (int W i); trivial.
  admit. (*!*)

  red; intros.
  admit.

 rewrite Elt_def.
  red; intros.

*)

(***********************************************************************************************)

(** * Consistency out of the strong normalization model *)

(** Another consistency proof. *)

Theorem consistency : forall M, ~ typ List.nil M (Prod prop (Ref 0)).
red; intros.
apply model_consistency with (FF:=mkTY (singl prf_trm) (fun _ => neuSAT)) in H;
  trivial.
 apply sn_sort_intro.
  reflexivity.

  apply one_in_props.

 intros.
 red in H0; rewrite El_def  in H0.
 rewrite Real_def; auto with *.
Qed.

Print Assumptions consistency.


Require Import Framework FSParameters.
Require Export LoggedDiskLayer ListLayer.
Import ListNotations.

Set Implicit Arguments.

Definition TransactionCacheOperation :=  HorizontalComposition (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length).
Definition TransactionCacheLang := Build_Layer TransactionCacheOperation.

Notation "'|TCCP|' p" := (@lift_L1 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (ListLang (addr * value)) _ p) (at level 59).
Notation "'|TCDP|' p" := (@lift_L2 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (LoggedDiskLang log_length data_length) _ p) (at level 59).
Notation "'|TCCO|' p" := (@lift_L1 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (ListLang (addr * value)) _ (Op (ListOperation (addr * value)) p)) (at level 59).
Notation "'|TCDO|' p" := (@lift_L2 (ListOperation (addr * value)) (LoggedDiskOperation log_length data_length) (LoggedDiskLang log_length data_length) _ (Op (LoggedDiskOperation log_length data_length) p)) (at level 59).


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Coq.Program.Program.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.count.p4ast.

Open Scope func_spec.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Definition am_ge := ltac:(get_am_ge prog).
Definition ge := ltac:(get_ge am_ge prog).

Definition NoAction_fundef : @fundef Info :=
  ltac:(get_fd ["NoAction"] ge).

Definition NoAction_spec : func_spec :=
  WITH,
    PATH []
    MOD None []
    WITH,
      PRE
        (ARG []
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM []
        (EXT []))).

Lemma NoAction_body :
  func_sound ge NoAction_fundef nil NoAction_spec.
Proof.
  start_function.
  step.
  entailer.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* this file contains some cardinal functions, which are message
dependent *)

Require Export reduce.
Require Export DistributedReferenceCounting.machine2.machine.

Section COUNT_MESSAGE.

Definition dec_predicate (m : Message) :=
  match m with
  | dec => true
  | _ => false
  end.

Definition inc_predicate (m : Message) :=
  match m with
  | inc_dec _ => true
  | _ => false
  end.

(* the next one only recognises inc_dec messages related to s0 *)

Variable s0 : Site.

Definition site_inc_predicate (m : Message) :=
  match m with
  | inc_dec s => if eq_site_dec s s0 then true else false
  | _ => false
  end.

Definition copy_predicate (m : Message) :=
  match m with
  | copy => true
  | _ => false
  end.

Definition dec_count (m : Message) :=
  match m with
  | dec => 1%Z
  | _ => 0%Z
  end.

Definition inc_count (m : Message) := 0%Z.

Definition copy_count (m : Message) :=
  match m with
  | copy => 1%Z
  | _ => 0%Z
  end.

Definition cardinal_count :=
  fun_sum Message dec_count (fun_sum Message inc_count copy_count).

Definition cardinal := reduce Message cardinal_count.

Lemma disjoint_cardinal :
 forall q : queue Message,
 cardinal q =
 (reduce Message dec_count q +
  (reduce Message inc_count q + reduce Message copy_count q))%Z.
Proof.
  intro.
  rewrite <- disjoint_reduce.
  rewrite <- disjoint_reduce.
  unfold cardinal in |- *.
  unfold cardinal_count in |- *.
  auto.
Qed.

Lemma cardinal_first_out :
 forall (q : queue Message) (m : Message),
 first Message q = value Message m ->
 cardinal (first_out Message q) = (cardinal q - cardinal_count m)%Z.
Proof.
  intros.
  unfold cardinal in |- *.
  apply reduce_first_out.
  auto.
Qed.

End COUNT_MESSAGE.

Section SIG_WEIGHT.
Let Bag_of_message := Bag_of_Data Message.

Definition sigma_weight (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) (fun s1 s2 : Site => cardinal) bm.

End SIG_WEIGHT.


Require Import Fiat.Common Fiat.Computation.Core Fiat.ADT.Core Coq.Sets.Ensembles.

Section HideADT.

  Context {extSig : ADTSig}.
  (* The extended signature *)

  Context {resMethodIndex : Type}.
  (* The restricted set of method indices *)

  Variable methodMap : resMethodIndex -> MethodIndex extSig.
  (* Map from restricted to extended method indices *)

  Definition resSig :=
    {| MethodIndex := resMethodIndex;
       MethodDomCod idx := MethodDomCod extSig (methodMap idx)
    |}.
  (* The signature of the ADT with restricted constructor and method indices *)

  Definition HideADT (extADT : ADT extSig) : ADT resSig :=
    match extADT with
        {| Rep := rep;
           Methods := extMethods
        |} =>
        Build_ADT resSig rep
                  (fun idx => extMethods (methodMap idx))
    end.

End HideADT.


Require Import Definitions.
Require Import State.
Require Import Step.
Require Import BinNat.
Require Import BinInt.
Require Import String.

Definition initialState := MkState (const None) (const None).

Definition opened_fd (s : state) (fd : Z) : Prop :=
	fds s fd <> None.
Definition opened_file (s : state) (str : string) : Prop :=
	exists (fd : Z), option_map file (fds s fd) = Some str.
Definition opened_file_with_fd (s : state) (f : string) (fd : Z)
	:= forall z, option_map file (fds s z) = Some f <-> fd = z.

Lemma non_opened_fd_1 (s : state) (fd : Z) (file : string)
	: ~ opened_fd s fd -> ~ opened_file_with_fd s file fd.
Proof.
intros H.
unfold opened_file_with_fd.
intro Hf.
apply H.
unfold opened_fd.
intro Hf2.
destruct (fds s fd) eqn:Heq.
+ discriminate Hf2.
+ pose (T := Hf fd).
	replace (fds s fd) with (None (A:=fdState)) in T.
	unfold option_map in T.
	destruct T.
	discriminate (H1 eq_refl).
Qed.

Lemma opened_file_1 (s : state) (fd : Z) (file : string)
	: opened_file_with_fd s file fd -> opened_file s file.
Proof.
edestruct 1.
eexists.
now apply H1.
Qed.

Definition fileContentKnown (f : string) (s : state) : Prop
	:= match (files s f) with
		| Some fs => forall (n : N), content fs n <> Unknownc
		| None => False
		end.

Definition sameFileContent (f : string) (sStart sEnd : state) : Prop
	:= fileContentKnown f sStart
		/\ forall (n : N), option_map (fun x => content x n) (files sStart f) = option_map (fun x => content x n) (files sEnd f).

Definition setFileContent (s : state) (str content : string) : state
	:= let (sfd, sfile) := s in
		 let sfile := setFun sfile
			(Some
				(MkFileState
					(Some (N.of_nat (length content)))
					(addString content 0%N (const Nonec))
				)
			) str in
			MkState sfd sfile.

Lemma fileContentKnownSetFileContent (file content : string) (s : state)
	: fileContentKnown file (setFileContent s file content).
Proof.
unfold fileContentKnown.
unfold setFileContent.
destruct s.
cbn.
rewrite setFunOk.
intros n.
cbn.
assert (forall m, addString content m (const Nonec) n <> Unknownc).
+ induction content.
	- easy.
	- intros m.
		cbn.
		admit.
Admitted.

Lemma setFileContent_fds (s : state) (str content : string) : fds s = fds (setFileContent s str content).
Proof.
now destruct s.
Qed.

Fixpoint setFileContents (s : state) (contents : list (string * string)) : state
	:= match contents with
	   | ((fn, fc)::contents)%list => setFileContents (setFileContent s fn fc) contents
		 | _ => s
		 end.

Lemma setFileContents_fds (s : state) (contents : list (string * string))
	: fds s = fds (setFileContents s contents).
Proof.
generalize s.
induction contents; intros.
+ easy.
+ simpl.
	destruct a.
	rewrite <- IHcontents.
	apply setFileContent_fds.
Qed.

Transparent abs_step.

Section Abs_step_facts.

Variable s : state.

Lemma open_opened_fd (str : string) (fd : Z) (m : FileSystem.mode) (o : FileSystem.options)
	: opened_fd (abs_step (FileSystem.Open m o str) fd s) fd.
Proof.
unfold opened_fd.
destruct s.
cbn.
now rewrite setFunOk.
Qed.

Lemma open_opened_file_with_fd (str : string) (fd : Z) (m : FileSystem.mode) (o : FileSystem.options)
	: ~ opened_file s str (* provable with the precondition *)
		-> opened_file_with_fd (abs_step (FileSystem.Open m o str) fd s) str fd.
Proof.
unfold opened_file_with_fd.
destruct s eqn:Heq.
intros.
constructor;
	intros.
+ cbn in H0.
	case_dec (fd = z).
	- apply H1.
	- rewrite setFunOk2 in H0.
		* absurd (opened_file s str).
			++ now subst.
			++ exists z.
				now subst.
		* easy.
+	subst.
	cbn.
	now rewrite setFunOk.
Qed.

Lemma open_opened_file_with_fd2 (str f : string) (fd1 fd2 : Z) (m : FileSystem.mode) (o : FileSystem.options)
	: opened_file_with_fd s f fd1
		-> str <> f
		-> opened_file_with_fd (abs_step (FileSystem.Open m o str) fd2 s) f fd1.
Proof.
unfold opened_file_with_fd.
intros.
destruct s.
constructor;
	intros.
+ apply H.
	rewrite <- H1.
	cbn.
	case_dec (fd2 = z).
	- subst.
		rewrite setFunOk.
		cbn.
		destruct (fds z);
			cbn.
(*
case_dec (fd2 = fd1).
+ subst.
	intros.
	exfalso.
	eapply non_opened_fd_1 in H0.
	apply H0.
	apply H.
+ intros.
	unfold opened_file_with_fd.
	unfold opened_file_with_fd in H0.
	destruct s eqn:Heq.
	intros.
	constructor;
		intros.
	-	case_dec (fd2 = z).
		* subst.
			cbn in H2.
			rewrite setFunOk in H2.
			cbn in H2.
			cbn in H0.
			inversion H2.
			admit.
		* apply H0.
			cbn in H2.
			now rewrite setFunOk2 in H2.
	- subst.
		cbn.
		rewrite setFunOk2.
		* now apply <- H0.
		* apply H. *)
Admitted.

Lemma open_opened_fd2 (fd r : Z) (str : string) (m : FileSystem.mode) (o : FileSystem.options)
	: opened_fd s fd -> opened_fd (abs_step (FileSystem.Open m o str) r s) fd.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
case_dec (r = fd).
+ subst.
	rewrite setFunOk.
	unfold option_map.
	now destruct (fds fd) eqn:Heq.
+ now rewrite setFunOk2.
Qed.

Lemma open_not_opened_file (r : Z) (str file : string) (m : FileSystem.mode) (o : FileSystem.options)
	: ~ opened_file s file -> file <> str -> ~ opened_file (abs_step (FileSystem.Open m o str) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
clear Hf.
case_dec (r = x).
+ subst.
	rewrite setFunOk in H1.
	cbn in H1.
	inversion H1.
	now subst.
+ rewrite setFunOk2 in H1.
	- apply H.
		now exists x.
	- easy.
Qed.

Lemma getSize_opened_fd (fd1 fd2 : Z) (r : N)
	: opened_fd s fd1 -> opened_fd (abs_step (FileSystem.GetSize fd2) r s) fd1.
Proof.
intros.
now destruct s.
Qed.

Lemma getSize_not_opened_file (file : string) (fd : Z) (r : N)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.GetSize fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
now exists x.
Qed.

Lemma getSize_opened_file_with_fd (file : string) (fd1 fd2 : Z) (r : N)
 : opened_file_with_fd s file fd1 -> opened_file_with_fd (abs_step (FileSystem.GetSize fd2) r s) file fd1.
Proof.
intros.
now destruct s.
Qed.

Lemma read_opened_fd (n : N) (fd1 fd2 : Z) (r : string)
	: opened_fd s fd1 -> opened_fd (abs_step (FileSystem.Read n fd2) r s) fd1.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
case_dec (fd2 = fd1).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	now destruct (fds fd1) eqn:Heq.
+ now rewrite changeFunOk2.
Qed.

Lemma read_not_opened_file (r file : string) (fd : Z) (n : N)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.Read n fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
exists x.
rewrite <- H0.
case_dec (fd = x).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	destruct (fds x).
	- now destruct f.
	- reflexivity.
+ now rewrite changeFunOk2.
Qed.

Lemma read_opened_file_with_fd (file : string) (fd1 fd2 : Z) (n : N) (r : string)
 : opened_file_with_fd s file fd1 -> opened_file_with_fd (abs_step (FileSystem.Read n fd2) r s) file fd1.
Proof.
intros.
destruct s.
unfold opened_file_with_fd.
cbn.
intros z.
case_dec (fd2 = z).
+ subst.
	split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		rewrite <- H0.
		rewrite changeFunOk.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
	- subst.
		rewrite changeFunOk.
		unfold opened_file_with_fd in H.
		pose (Hr := H z).
		destruct Hr.
		rewrite <- H1; try reflexivity.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
+ split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		cbn.
		rewrite <- H1.
		now rewrite changeFunOk2.
	- subst.
		unfold opened_file_with_fd in H.
		rewrite changeFunOk2.
		* now apply <- H.
		* assumption.
Qed.

Lemma write_opened_fd (str : string) (fd1 fd2 : Z) (r : unit)
	: opened_fd s fd1 -> opened_fd (abs_step (FileSystem.Write str fd2) r s) fd1.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
case_dec (fd2 = fd1).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	now destruct (fds fd1) eqn:Heq.
+ now rewrite changeFunOk2.
Qed.

Lemma write_opened_file (str file : string) (fd : Z) (r : unit)
	: opened_file s file -> opened_file (abs_step (FileSystem.Write str fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
inversion H.
exists x.
rewrite <- H0.
case_dec (fd = x).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	cbn.
	destruct (fds x).
	- now destruct f.
	- reflexivity.
+ now rewrite changeFunOk2.
Qed.

Lemma write_not_opened_file (str file : string) (fd : Z) (r : unit)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.Write str fd) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
exists x.
rewrite <- H0.
case_dec (fd = x).
+ subst.
	rewrite changeFunOk.
	unfold option_map.
	destruct (fds x).
	- now destruct f.
	- reflexivity.
+ now rewrite changeFunOk2.
Qed.

Lemma write_opened_file_with_fd (file : string) (fd1 fd2 : Z) (r : unit) (str : string)
 : opened_file_with_fd s file fd1 -> opened_file_with_fd (abs_step (FileSystem.Write str fd2) r s) file fd1.
Proof.
intros.
destruct s.
unfold opened_file_with_fd.
cbn.
intros z.
case_dec (fd2 = z).
+ subst.
	split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		rewrite <- H0.
		rewrite changeFunOk.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
	- subst.
		rewrite changeFunOk.
		unfold opened_file_with_fd in H.
		pose (Hr := H z).
		destruct Hr.
		rewrite <- H1; try reflexivity.
		cbn.
		destruct (fds z).
		* now destruct f.
		* easy.
+ split; intros.
	- unfold opened_file_with_fd in H.
		apply H.
		cbn.
		rewrite <- H1.
		now rewrite changeFunOk2.
	- subst.
		unfold opened_file_with_fd in H.
		rewrite changeFunOk2.
		* now apply <- H.
		* assumption.
Qed.

Lemma close_opened_fd (fd1 fd2 : Z) (r : unit)
	: opened_fd s fd1 -> fd2 <> fd1 -> opened_fd (abs_step (FileSystem.Close fd2) r s) fd1.
Proof.
intros.
unfold opened_fd.
destruct s.
cbn.
now rewrite setFunOk2.
Qed.

Lemma close_not_opened_file (f : string) (fd : Z) (r : unit)
	: ~ opened_file s f -> ~ opened_file (abs_step (FileSystem.Close fd) r s) f.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
case_dec (fd = x).
+ subst.
	now rewrite setFunOk in H0.
+ rewrite setFunOk2 in H0.
	- apply H.
		now exists x.
	- easy.
Qed.

Lemma close_not_opened_file2 (f : string) (fd : Z) (r : unit)
	: opened_file_with_fd s f fd
		-> ~ opened_file (abs_step (FileSystem.Close fd) r s) f.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
unfold opened_file_with_fd in H.
intro Hf.
inversion Hf.
clear Hf.
case_dec (fd = x).
+ subst.
	now rewrite setFunOk in H0.
+ apply H1.
	apply (H x).
	now rewrite setFunOk2 in H0.
Qed.

Lemma close_opened_file_with_fd (f : string) (fd1 fd2 : Z) (r : unit)
	: opened_file_with_fd s f fd1
		-> fd1 <> fd2 (* provable with the postcondition of the corresponding open *)
		-> opened_file_with_fd (abs_step (FileSystem.Close fd2) r s) f fd1.
Proof.
intros.
destruct s.
unfold opened_file_with_fd.
Admitted.

Lemma unlink_not_opened_file (file z : string) (r : unit)
	: ~ opened_file s file -> ~ opened_file (abs_step (FileSystem.Unlink z) r s) file.
Proof.
intros.
destruct s.
unfold opened_file.
cbn.
intro Hf.
inversion Hf.
apply H.
unfold opened_file.
cbn.
now exists x.
Qed.

End Abs_step_facts.


Require Import VST.msl.msl_direct.
Require Import RamifyCoq.msl_ext.abs_addr.

Instance Join_discrete (A : Type): Join A := fun a1 a2 a3 : A => False.

Instance Perm_discrete (A: Type)  : @Perm_alg A (Join_discrete A).
Proof. constructor; intros; inv H. Qed.

Instance psa_discrete (A: Type) :  @Pos_alg A  (Join_discrete A).
Proof. repeat intro. inv H. Qed.

(* Definition var := nat. *)
Definition adr := nat.

Definition world := (fpm adr adr).

Instance Join_world: Join world := Join_fpm (Join_discrete adr).

Instance Perm_world : Perm_alg world. apply Perm_fpm; apply Perm_discrete. Qed.

Instance Sep_world : Sep_alg world. apply Sep_fpm. Qed.

Instance Canc_world : Canc_alg world. apply Canc_fpm; [intuition | repeat intro; inversion H]. Qed.

Instance Disj_world : Disj_alg world. apply Disj_fpm; repeat intro; [apply Perm_discrete | |]; inversion H. Qed.

Instance Cross_world : Cross_alg world. apply Cross_fpm; [apply Perm_discrete | apply psa_discrete | repeat intro; inv H]. Qed.

Instance Trip_world : @Trip_alg world Join_world.
Proof.
  repeat intro.
  destruct ab as [fab Hab]. destruct c as [fc Hc].
  remember (fun x => match (fab x) with
                       | Some v => Some v
                       | None => match (fc x) with
                                   | Some v' => Some v'
                                   | None => None
                                 end
                     end) as fabc.
  assert (finMap fabc). {
    hnf in Hab, Hc. destruct Hab as [lab ?]. destruct Hc as [lc ?].
    exists (lab ++ lc). intro z; intros.
    assert (~ In z lab). intro. apply H2. apply in_or_app. left; auto.
    assert (~ In z lc). intro. apply H2. apply in_or_app. right; auto.
    hnf in *. simpl in *. specialize (e0 z H4). specialize (e z H3).
    rewrite Heqfabc. destruct (fab z) eqn:? . inv e. destruct (fc z) eqn:? . inv e0. auto.
  } exists (exist (finMap (B:=adr)) fabc H2).
  hnf. simpl. intros. rewrite Heqfabc. destruct (fab x) eqn:? .
  + destruct (fc x) eqn:? .
    - destruct a as [fa ?]. destruct b as [fb ?]. hnf in *. simpl in *.
      specialize (H x). rewrite Heqo in *. inversion H.
      * specialize (H0 x). rewrite H6, Heqo0 in *. inversion H0. inversion H9.
      * specialize (H1 x). rewrite H6, Heqo0 in *. inversion H1. inversion H9.
      * inversion H6.
    - constructor.
  + destruct (fc x) eqn:? .
    - constructor.
    - constructor.
Defined.

Definition adr_conflict (a1 a2 : adr) : bool := if (eq_nat_dec a1 a2) then true else false.

Instance AbsAddr_world : AbsAddr adr adr.
  apply (mkAbsAddr adr adr adr_conflict); intros; unfold adr_conflict in *.
  + destruct (eq_nat_dec p1 p2). subst. destruct (eq_nat_dec p2 p2); auto. exfalso; tauto.
    destruct (eq_nat_dec p2 p1). subst. exfalso; tauto. trivial.
  + destruct (eq_nat_dec p1 p1). inversion H. exfalso; tauto.
Defined.

Fixpoint extractSome (f : adr -> option adr) (li : list adr) : list adr :=
  match li with
    | nil => nil
    | x :: lx => match f x with
                   | Some _ => x :: extractSome f lx
                   | None => extractSome f lx
                 end
  end.

Lemma world_finite: forall w: world, exists l: list adr, forall a:adr, In a l <-> lookup_fpm w a <> None.
Proof.
  intro; destruct w as [f [li ?]]; simpl; exists (extractSome f li); split; intros.
  clear e; induction li; simpl in H; auto.
  destruct (f a0) eqn: ?. destruct (in_inv H). subst. rewrite Heqo. intro. inversion H0.
  apply IHli; auto. apply IHli; auto. destruct (in_dec nat_eq_dec a li). clear e.
  induction li; simpl in *; auto. destruct (f a0) eqn : ?. destruct i. subst. apply in_eq.
  apply in_cons. apply IHli; auto. destruct i. subst. exfalso; auto. apply IHli; auto.
  specialize (e a n). exfalso; auto.
Qed.

Lemma lookup_fpm_join_sub: forall (w1 w2 : world) x, join_sub w1 w2 -> lookup_fpm w1 x <> None -> lookup_fpm w2 x <> None.
Proof.
  intros. destruct H as [w3 ?].
  destruct w1 as [f1 [l1 ?]]. destruct w2 as [f2 [l2 ?]]. destruct w3 as [f3 [l3 ?]]. hnf in H; simpl in *.
  specialize (H x). inversion H. exfalso; auto. auto. auto.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition invalidate_page_spec0 (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 _addr =>
      when adt == barrier_spec  adt;
      rely is_int64 _addr;
      when adt == stage2_tlbi_ipa_spec (VZ64 _addr) (VZ64 4096) adt;
      Some adt
     end
    .

End SpecLow.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Platform.Cito.SemanticsFacts4.
  Require Import Platform.Cito.ProgramLogic2.
  Require Import Platform.Cito.Transit.
  Require Import Platform.Cito.Semantics.

  Require Import Platform.Cito.GLabel.
  Require Import Platform.Cito.GLabelMap.
  Import GLabelMap.
  Require Import Platform.Cito.GLabelMapFacts.

  Notation Internal := (@Internal ADTValue).

  Definition strengthen_specs specs_op specs_ax env_ax :=
    forall (lbl : glabel),
      find lbl specs_op = find lbl specs_ax \/
      exists spec_op spec_ax,
        find lbl specs_op = Some (Internal spec_op) /\
        find lbl specs_ax = Some (Foreign spec_ax) /\
        strengthen_op_ax spec_op spec_ax env_ax.

  Require Import Platform.Cito.GeneralTactics Platform.Cito.GeneralTactics2.
  Require Import Platform.Cito.Option.

  Lemma strengthen_specs_strengthen : forall specs_op specs_ax env_op env_ax, strengthen_specs specs_op specs_ax env_ax -> specs_env_agree specs_op env_op -> specs_env_agree specs_ax env_ax -> (forall lbl, fst env_op lbl = fst env_ax lbl) -> strengthen env_op env_ax.
  Proof.
    split; intros.
    eauto.
    destruct (option_dec (fs_op w)).
    destruct s.
    generalize e; intro.
    eapply H0 in e.
    openhyp.
    edestruct (H x0).
    left.
    rewrite e0.
    symmetry.
    eapply H1.
    rewrite H5 in H4; clear H5.
    descend; eauto.
    rewrite <- H2.
    eauto.

    openhyp.
    rewrite H5 in H4; injection H4; intros; subst.
    assert (fs_ax w = Some (Foreign x2)).
    eapply H1.
    descend; eauto.
    rewrite <- H2; eauto.
    right; descend; eauto.

    destruct (option_dec (fs_ax w)).
    destruct s.
    generalize e0; intro.
    eapply H1 in e0.
    openhyp.
    edestruct (H x0).
    assert (fs_op w = Some x).
    eapply H0.
    descend; eauto.
    rewrite H2; eauto.
    rewrite H5.
    eauto.
    rewrite H6 in e; intuition.
    openhyp.
    assert (fs_op w = Some (Internal x1)).
    eapply H0.
    descend; eauto.
    rewrite H2; eauto.
    rewrite H8 in e; intuition.
    left; congruence.
  Qed.

  Notation Foreign := (@Foreign ADTValue).

  Definition apply_specs_diff specs specs_diff := update specs (map Foreign specs_diff).

  Definition strengthen_diff_f specs env_ax k v a :=
    a /\
    (find k specs = Some (Foreign v) \/
     exists op,
       find k specs = Some (Internal op) /\
       strengthen_op_ax op v env_ax).

  Definition strengthen_diff specs specs_diff env_ax :=
    fold (strengthen_diff_f specs env_ax) specs_diff True.

  Lemma strengthen_diff_elim : forall specs_diff env_ax specs, strengthen_diff specs specs_diff env_ax -> forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax.
    do 3 intro.
    eapply fold_rec_bis with (P := fun specs_diff (H : Prop) => H -> forall lbl ax, find lbl specs_diff = Some ax -> find lbl specs = Some (Foreign ax) \/ exists op, find lbl specs = Some (Internal op) /\ strengthen_op_ax op ax env_ax); simpl; intros.
    eapply H0; eauto.
    rewrite H; eauto.
    rewrite empty_o in H0; intuition.
    eapply find_mapsto_iff in H3.
    eapply add_mapsto_iff in H3.
    openhyp.
    subst.
    destruct H2.
    openhyp.
    eauto.
    right; descend; eauto.
    eapply H1.
    destruct H2; eauto.
    eapply find_mapsto_iff; eauto.
  Qed.

  Lemma strengthen_diff_strengthen_specs : forall specs specs_diff env_ax, strengthen_diff specs specs_diff env_ax -> strengthen_specs specs (apply_specs_diff specs specs_diff) env_ax.
    intros.
    unfold strengthen_specs.
    intros.
    destruct (option_dec (find lbl specs_diff)).
    destruct s.
    eapply strengthen_diff_elim in H; eauto.
    openhyp.
    left.
    rewrite H.
    symmetry.
    eapply find_mapsto_iff.
    eapply update_mapsto_iff.
    left.
    eapply find_mapsto_iff.
    rewrite map_o.
    rewrite e.
    eauto.
    right; descend; eauto.
    eapply find_mapsto_iff.
    eapply update_mapsto_iff.
    left.
    eapply find_mapsto_iff.
    rewrite map_o.
    rewrite e.
    eauto.
    left.
    unfold apply_specs_diff.
    rewrite update_o_1; eauto.
    nintro.
    eapply map_4 in H0.
    eapply In_find_not_None in H0.
    erewrite e in H0.
    intuition.
  Qed.

  Lemma strengthen_diff_strenghthen : forall specs specs_diff env_op env_ax, strengthen_diff specs specs_diff env_ax -> specs_env_agree specs env_op -> specs_env_agree (apply_specs_diff specs specs_diff) env_ax -> (forall lbl, fst env_op lbl = fst env_ax lbl) -> strengthen env_op env_ax.
    intros.
    eapply strengthen_specs_strengthen; eauto.
    eapply strengthen_diff_strengthen_specs; eauto.
  Qed.

  Notation Callee := (@Callee ADTValue).

  Definition is_pointer_of_label specs (stn : glabel -> option W) w : option Callee :=
    fold (fun k v res =>
            match res with
              | Some _ => res
              | None =>
                match stn k with
                  | Some w' => if weq w w' then Some v else None
                  | None => None
                end
            end
         ) specs None.

  Notation Env := (@Env ADTValue).

  Definition change_env new_specs (env : Env) : Env :=
    let stn := fst env in
    let fs := snd env in
    (stn,
     fun w =>
       match is_pointer_of_label new_specs stn w with
         | Some new_spec => Some new_spec
         | None => fs w
       end).

  Notation specs_stn_injective := (@specs_stn_injective ADTValue).

  Lemma sub_domain_specs_stn_injective : forall specs1 specs2 stn, specs_stn_injective specs1 stn -> sub_domain specs2 specs1 -> specs_stn_injective specs2 stn.
    unfold ProgramLogic2.specs_stn_injective, sub_domain; intros.
    eapply H; eauto.
  Qed.

  Lemma add_specs_stn_injective : forall specs k v stn, specs_stn_injective (add k v specs) stn -> specs_stn_injective specs stn.
    intros.
    eapply sub_domain_specs_stn_injective; eauto.
    unfold sub_domain; intros.
    eapply add_in_iff; eauto.
  Qed.

  Lemma is_pointer_of_label_intro_elim : forall specs stn w, (forall v, is_pointer_of_label specs stn w = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w) /\ (forall v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> is_pointer_of_label specs stn w = Some v).
    do 3 intro.
    eapply fold_rec_bis with (P := fun specs a => (forall v, a = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w) /\ (forall v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> a = Some v)); simpl; intros.
    unfold ProgramLogic2.specs_stn_injective in *.
    setoid_rewrite H in H0.
    eapply H0; eauto.
    split; intros.
    intuition.
    rewrite empty_o in H0; intuition.
    openhyp.
    split; intros.
    destruct a.
    injection H3; intros; subst.
    edestruct H1; eauto.
    openhyp.
    descend; eauto.
    eapply find_mapsto_iff; eapply add_mapsto_iff.
    right.
    split.
    nintro; subst.
    eapply find_mapsto_iff in H4; eapply MapsTo_In in H4.
    contradiction.
    eapply find_mapsto_iff; eauto.
    destruct (option_dec (stn k)).
    destruct s.
    rewrite e0 in *.
    destruct (weq w x).
    subst.
    injection H3; intros; subst.
    descend; eauto.
    eapply find_mapsto_iff; eapply add_mapsto_iff.
    eauto.
    intuition.
    rewrite e0 in *; intuition.
    destruct a.
    edestruct H1; eauto.
    openhyp.
    eapply find_mapsto_iff in H4; eapply find_mapsto_iff in H6.
    assert (lbl = x).
    eapply H3; eauto.
    eapply MapsTo_In; eauto.
    eapply add_in_iff; right; eapply MapsTo_In; eauto.
    subst.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    eapply MapsTo_In in H6; contradiction.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.

    eapply find_mapsto_iff in H4.
    destruct (option_dec (stn k)).
    destruct s.
    rewrite e0 in *.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    rewrite H5 in e0; injection e0; intros; subst.
    destruct (weq x x); intuition.
    destruct (weq w x).
    subst.
    contradict H4.
    eapply H3; eauto.
    eapply add_in_iff; eauto.
    eapply add_in_iff; right; eapply MapsTo_In; eauto.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.
    rewrite e0 in *.
    eapply add_mapsto_iff in H4; openhyp.
    subst.
    rewrite H5 in e0; intuition.
    eapply H2; eauto.
    eapply add_specs_stn_injective; eauto.
    eapply find_mapsto_iff; eauto.
  Qed.

  Lemma is_pointer_of_label_intro : forall specs stn w v lbl, specs_stn_injective specs stn -> find lbl specs = Some v -> stn lbl = Some w -> is_pointer_of_label specs stn w = Some v.
    eapply is_pointer_of_label_intro_elim; eauto.
  Qed.

  Lemma is_pointer_of_label_elim : forall specs stn w v, is_pointer_of_label specs stn w = Some v -> exists lbl, find lbl specs = Some v /\ stn lbl = Some w.
    eapply is_pointer_of_label_intro_elim; eauto.
  Qed.

  Lemma equal_domain_specs_stn_injective : forall specs1 specs2 stn, equal_domain specs1 specs2 -> (specs_stn_injective specs1 stn <-> specs_stn_injective specs2 stn).
    split; intros.
    eapply sub_domain_specs_stn_injective; eauto; eapply H.
    eapply sub_domain_specs_stn_injective; eauto; eapply H.
  Qed.
  Lemma equal_domain_sym : forall elt1 elt2 (m1 : t elt1) (m2 : t elt2), equal_domain m1 m2 -> equal_domain m2 m1.
    unfold equal_domain; intuition.
  Qed.

  Lemma change_env_agree : forall specs new_specs, equal_domain new_specs specs -> forall env, specs_env_agree specs env -> specs_env_agree new_specs (change_env new_specs env).
  Proof.
    unfold specs_env_agree.
    intros.
    openhyp.
    simpl.
    split.
    unfold labels_in_scope in *.
    intros.
    eapply H0.
    eapply H; eauto.

    split.
    eapply equal_domain_specs_stn_injective; eauto.

    unfold specs_fs_agree in *.
    split; intros.
    simpl in *.
    destruct env in *; simpl in *.
    destruct (option_dec (is_pointer_of_label new_specs o p)).
    destruct s.
    rewrite e in *.
    injection H3; intros; subst.
    eapply is_pointer_of_label_elim in e; openhyp.
    descend; eauto.
    rewrite e in *.
    eapply H2 in H3; openhyp.
    eapply find_mapsto_iff in H4; eapply MapsTo_In in H4.
    eapply H in H4.
    eapply In_MapsTo in H4; openhyp.
    assert (is_pointer_of_label new_specs o p = Some x0).
    eapply is_pointer_of_label_intro; eauto.
    eapply equal_domain_specs_stn_injective; eauto.

    eapply find_mapsto_iff; eauto.
    rewrite e in H5; intuition.
    openhyp.
    simpl in *.
    destruct env; simpl in *.
    assert (is_pointer_of_label new_specs o p = Some spec).
    eapply is_pointer_of_label_intro; eauto.
    eapply equal_domain_specs_stn_injective; eauto.
    rewrite H5; eauto.
  Qed.

  Lemma sub_domain_apply_specs_diff_equal_domain a b : sub_domain b a -> equal_domain (apply_specs_diff a b) a.
  Proof.
    unfold apply_specs_diff.
    unfold equal_domain.
    intros H.
    split.
    {
      eapply sub_domain_update_sub_domain; eauto.
      eapply sub_domain_map_1; eauto.
    }
    {
      eapply sub_domain_update_1.
      eapply sub_domain_refl.
    }
  Qed.

End ADTValue.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Context `{Hcc: CompilerConfiguration}.
Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | _ => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. repeat rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  repeat rewrite Val.add_assoc. decEq; simpl. rewrite Int.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_assoc.
  simpl. rewrite Int.add_assoc; auto.
  rewrite shift_symbol_address. auto.
  rewrite Val.add_assoc. auto.
  rewrite shift_symbol_address. auto.
  rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  eapply eval_static_addressing_correct; eauto.
  unfold eval_static_intoffloat.
  destruct (Float.intoffloat n1) eqn:?; simpl in H0; inv H0.
  simpl; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|] eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite shift_symbol_address; congruence.
  rewrite H. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. repeat rewrite shift_symbol_address. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. rewrite Int.add_permut. repeat rewrite shift_symbol_address.
  rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Int.add_assoc. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Val.add_permut.
  rewrite Int.add_assoc. auto.
  rewrite H0. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  decEq; decEq. apply Val.add_commut.
  rewrite H. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  rewrite (Val.add_permut (rs#r1)). decEq; decEq. apply Val.add_commut.
  rewrite H0. rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. repeat rewrite shift_symbol_address. auto.
  rewrite H0. rewrite shift_symbol_address. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut.
  rewrite H. auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1,
  let (op, args) := make_shlimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  econstructor; split. simpl. eauto. auto.
Qed.

Lemma make_shrimm_correct:
  forall n r1,
  let (op, args) := make_shrimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  econstructor; split; eauto. simpl. auto.
Qed.

Lemma make_shruimm_correct:
  forall n r1,
  let (op, args) := make_shruimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1,
  let (op, args) := make_mulimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  replace v with (Val.shru rs#r1 (Vint i)).
  eapply make_shruimm_correct; eauto.
  eapply Val.divu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_moduimm_correct:
  forall n r1 r2 v,
  Val.modu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_moduimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_moduimm.
  destruct (Int.is_power2 n) eqn:?.
  exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* sub *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
(* mul *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* modu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_moduimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto.
(* or *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto.
(* lea *)
  generalize (addr_strength_reduction_correct addr args0 vl0 H).
  destruct (addr_strength_reduction addr args0 vl0) as [addr' args'].
  intro EQ. exists v; split; auto. simpl. congruence.
(* cond *)
  generalize (cond_strength_reduction_correct c args0 vl0 H).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* default *)
  exists v; auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.


(** * 머리말 *)

(* ################################################################# *)
(** * 환영합니다 *)

(** _소프트웨어 기초_(신뢰성 있는 소프트웨어의 수학적 기초)의 다양한
    면들에 대한 전자책 시리즈의 시작점입니다. 강의 주제로 논리의 기본
    개념, 컴퓨터를 활용한 명제 증명(Computer-assisted theorem
    proving), 콕 증명 보조기 (Coq proof assistant), 함수형 언어
    (functional programming), 실행 과정 기반 의미 구조(operational
    semantics), 호어 논리(Hoare logic), 타입 시스템(static type
    system)을 다룬다. 고학년 학부생부터 박사과정 학생과 연구자들까지
    다양한 독자들을 대상으로 한다. 논리나 프로그래밍 언어에 대한 사전
    지식이 필요하지 않지만 수학을 많이 접했다면 도움이 될 것이다.

    이 강의의 특징은 백 퍼센트 형식화해서 컴퓨터로 검사하도록 구성된
    것이다. 즉, 전체 텍스트가 콕 스크립트다. 콕의 대화식 세션을 따라
    텍스트 내용을 읽도록 구성되어 있다. 텍스트의 모든 상세 내용은
    콕으로 완벽하게 형식화되어 있고, 대부분의 연습문제들을 콕을
    사용하여 풀어보도록 설계되었다.

    강의 파일들은 대략 한 학기 분량의 핵심적인 장들을 나열하도록
    구성되어 있고, 일관성 있고 단일 방향성의 이야기로 구성되어 있다.
    더불어 추가적인 주제들을 다루는 많은 파생된 장들도 있다.  모든
    핵심적인 장들은 고학년 학부생과 대학원생들에게 적합하다.

    이 책, _논리적 기초_,는 다른 책들을 위한 토대이고, 독자들에게
    함수형 프로그래밍, 건설적 논리(constructive logic), 콕 증명
    보조기를 소개한다. *)

(* ################################################################# *)
(** * 개요 *)

(** 신뢰성 있는 소프트웨어를 만드는 것은 어렵다. 현대 시스템들의 크기와
    복잡도, 개발에 참여하는 많은 개발자들, 다양한 시스템 요구사항들로
    인해 100%% 보다 훨씬 낮은 정확성이라도 대략 정확하게 소프트웨어를
    만드는 것조차도 매우 어렵다. 그리고 사회의 다양한 국면과 엮여
    정보를 처리함에 따라 버그와 위험으로 인한 비용이 확대된다.

    컴퓨터과학자들과 소프트웨어 공학자들은 이러한 문제들에 대응하기 위해
    소프트웨어 신뢰성을 높이기 위한 다양한 기법들을
    개발했다. 소프트웨어 프로젝트 팀들을 관리하는 방법(예를 들어
    익스트림 프로그래밍)에서부터 라이브러리(예를 들어 모델 뷰
    컨트롤러, 발행-가입, 등)와 프로그래밍 언어(예를 들어 객체지향
    프로그래밍, 관점 지향 프로그래밍,...) 설계 철학들, 소프트웨어의
    성질들을 기술하고 추론하는 수학적 기법과 이 성질들을 검증하기 위한
    도구들까지 다양하다. 이 강의는 마지막에 언급한 기법들에 초점을
    맞춘다.

    이 책은 세 가지 개념들을 엮어놓았다.

    (1) 프로그램에 대한 명제를 정밀하게 만들고 정당화하는 _논리_의
        기본 도구들

    (2) 논리적 주장을 엄밀하게 만들기 위하여 _증명 보조기_를 사용

    (3) 프로그램들에 대한 추론을 단순화하는 프로그래밍 방법으로
        그리고 프로그래밍과 논리를 연결하는 역할로써 _함수형 프로그래밍_

    [후기] 장에서 추가적으로 읽을만한 문헌을 소개한다.  모든
    참고문헌들에 대한 서지 정보는 [Bib] 파일에 있다.  *)

(* ================================================================= *)
(** ** 논리 *)

(** 논리는 _증명_을 주제로 하는 학문 분야다. 증명이란 특정 명제들이
    참인지 거짓인지에 대한 부정할 수 없는 주장이다. 컴퓨터과학에서
    논리의 중요한 역할에 대해 설명하는 많은 책들이 있다. 마나(Manna)와
    월딩거(Waldinger)는 논리를 "컴퓨터과학의 계산법"이라 불렀고,
    할러펜(Halpern)과 그 동료들의 논문 _컴퓨터과학에서 논리의 유별난
    효과_에서 논리가 어떻게 중요한 도구들과 통찰력들을 제공하는지
    수십 가지 사례들을 나열하였다. 정말로 "사실 논리는 수학에서 보다
    컴퓨터과학에서 훨씬 더 효과적임이 밝혀졌다. 특히 지난 백 년간 논리
    발전의 많은 자극이 수학으로부터 왔기 때문에 이 사실은 상당히
    주목할만하다."라고 보았다.

    특히 _귀납적 증명_이라는 기초적인 도구들은 컴퓨터과학의 모든 영역에
    사용된다. 독자 여러분은 분명히 이전에, 아마도 이산수학이나 알고리즘
    분석에 관한 강의에서 이것들을 보았을 것이다. 하지만 이 강의에서
    훨씬 더 깊이 이것들을 살펴볼 것이다. *)

(* ================================================================= *)
(** ** 증명 보조기 *)

(** 논리와 컴퓨터과학의 아이디어들은 서로 양쪽으로 주고받아왔다. 컴퓨터과학 또한
    논리에 중요한 기여들을 해왔다. 그중 하나는 논리 명제들을 증명하는 것을 도와주는
    소프트웨어 도구들을 개발해온 것이다. 이 도구들은 크게 두 가지로 분류할 수 있다.

       - _자동 정리 증명기_는 버튼만 누르면 제시한 명제가 _참_인지
         _거짓_인지 (또는 _시간이 너무 오래 걸려 모른다_)를
         리턴한다. 비록 특정 영역들에 국한되어 있지만 근래에 이 기술이
         크게 발전해왔고 이제 다양한 상황들에서 사용되고 있다. 이
         도구들의 예를 들면 에스에이티(SAT, boolean SATisfiability)
         도구들, 에스엠티(SMT, satisfiability modulo theores) 도구들,
         모델 검사기들이 있다.

       - _증명 보조기_는 어려운 부분들은 사람의 가이드에 의존하되 다소
         반복적인 부분들을 자동화하여 증명하는 혼합형 도구이다. 널리
         사용 중인 증명 보조기들로 이사벨(Isabelle), 아그다(Agda),
         트웰프(Twelf), 에이씨넬투(ACL2), 피브이에스(PVS), 콕(Coq) 등이
         있다.

    이 강의에서는 콕을 사용한다. 증명 보조기 콕은 1983년에 개발을
    시작했고 최근에 연구와 산업에 종사하는 다양한 커뮤니티에서 사용하고
    있다. 콕은 대화식으로 형식적 추론을 만들고 컴퓨터가 확인하는 방식을
    위한 다양한 기능을 제공하는 환경이다. 콕 시스템의 핵심부는 간단한
    증명 검사기로 구성되어 있는데, 이 검사기를 통해 오직 정확한 추론
    단계들만 수행하도록 보장한다. 콕 환경은 이 핵심부에 증명 개발을
    도와주는 고급 기능들을 제공한다. 방대한 공용 정의들과 보조 정리들
    라이브러리, 복잡한 증명들을 반자동으로 만들 수 있는 강력한
    전술(함수), 특정 상황에 맞추어 증명 자동화 전술을 새롭게 정의할 수
    있는 특별한 목적의 프로그래밍 언어 등이 포함되어 있다.

    콕은 컴퓨터과학과 수학을 넘나드는 거대하고 다양한 분야의 중요한
    성공 요소가 되고 있다.

    - _프로그래밍 언어를 모델링하는 플랫폼_으로써 복잡한 언어 정의들을
      기술하고 추론하는 표준 도구가 되었다. 자바카드(JavaCard) 플랫폼의
      보안성을 검사하는 데 사용되어 보안 분야 인증 표준 CC(Common
      Criteria)의 최고 등급을 받았다.  x86과 LLVM 어셈블리 언어와 C와
      같은 프로그래밍 언어의 형식 명세를 기술하는 데 사용되었다.

    - _형식적으로 검증된 소프트웨어와 하드웨어를 개발하기 위한
      환경_으로써 사용되고 있다. 콤써트(CompCert) 프로젝트에서 C언어
      최적화 컴파일러를 완벽하게 검증하였고, 써티코스(CertiKos)
      프로젝트에서 하이퍼바이저를 완전히 검증하였으며, 부동소수점
      숫자에 관한 알고리즘들의 정확성을 증명했고,
      써티크립트(CertiCrypt) 프로젝트에서 암호 알고리즘들의 보안성을
      추론하는 환경의 기초로 이용하고 있다. 오픈소스 리스크
      파이브(RISC-V) 프로세서의 구현을 검증하는 데에도 사용 중이다.

    - _종속 타입(dependent types)을 제공하는 함수형 프로그래밍을 위한
      제대로 된 환경_으로써 수많은 혁신들에 영향을 끼쳤다. 예를 들어
      와이놋(Ynot) 시스템은 "관계형 호어 추론" (_호어 논리_의 확장으로
      이 강의에서 다룰 것이다) 방법을 콕에 녹여냈다.

    - _고차원 논리(higher-order logic)를 위한 증명 보조기_로써 수학
      분야에서 많은 중요한 결과를 검증하는 데 사용되어 왔다. 증명 안에
      복잡한 계산을 포함하는 기능을 제공함으로써 네 가지 색
      정리(4-color theorem)의 증명을 처음으로 형식적으로
      검증해냈다. 이렇게 검증하기 전에 이 증명은 프로그램을 사용하여
      많은 상황들을 검사하는 부분이 포함되어 있기 때문에 수학자들
      사이에서 증명으로 인정할 지에 관하여 논쟁이 있었다. 콕으로
      형식화하여 프로그램을 실행하여 확인했던 부분의 정확성까지
      포함해서 모든 부분을 검사하였다. 더 최근에는 페이트 톰슨
      정리(Feit-Thompson theorem, 유한단순군의 분류에 관한 주요한
      첫번째 단계)을 콕으로 형식화하는데 더욱 방대한 양의 노력을
      기울이고 있다.

   만일 콕이라는 이름에 대해 궁금하다면 인리아(INRIA, 콕을 개발한
   프랑스 국립 연구소)에 있는 공식 웹 사이트에 언급된 설명을
   보자. "일부 프랑스 컴퓨터과학자들은 그들이 만든 소프트웨어에 동물
   종의 이름을 붙이는 전통을 가지고 있다. 카멜(Caml), 엘란(Elan),
   폭(Foc), 폭스(Phox)는 이런 암묵적인 전통의 예들이다. 프랑스어로
   '콕'은 수탉을 뜻하기도 하고, 콕이 기초로 하는 이론, 구성
   계산법(Calculus of Constructions, CoC)의 머리글자들처럼 발음한다."
   수탉은 프랑스의 국가 상징이기도 하며, 씨-오-큐(C-o-q)는 초기에 콕을
   개발한 사람들 중 티에리 코쿠아(Thierry Coquand)      이름에 포함된 첫
   번째 세 문자들이기도 하다. *)

(* ================================================================= *)
(** ** 함수형 프로그래밍 *)

(** _함수형 프로그래밍_이라는 용어는 거의 모든 프로그래밍 언어에서
    사용할 수 있는 프로그래밍 스타일들을 가리키기도 하고 이 스타일들을
    강조하여 설계된 프로그래밍 언어들을 말하기도
    한다. 하스켈(Haskell), 오캐멀(OCaml), 에스엠엘(Standrad ML),
    에프샵(F##), 스칼라(Scala), 스킴(Scheme), 라킷(Racket),
    리스프(Common Lisp), 클로져(Clojure), 얼랑(Erlang), 콕 등이 함수형
    프로그래밍 언어이다.

    함수형 프로그래밍은 수 십 년간 발전되어 왔다. 그 기원은
    처치(Church)가 1930년대에 발명한 람다 계산법(lambda
    calculus)이다. 이 시기는 초기 컴퓨터들(적어도 초기 전자 컴퓨터들)
    보다 앞선다! 하지만 90년대 초에 이르러서야 비로소 산업계
    엔지니어들과 언어 설계자들이 많은 관심을 보이기 시작했고 제인
    스트리트 캐피털(Jane St. Capital), 마이크로소프트(Microsoft),
    페이스북(Facebook), 에릭슨(Ericsson)과 같은 회사들의 고부가가치
    시스템들에서 중요한 역할을 담당하고 있다.

    함수형 프로그래밍의 가장 기본적인 생각은 가능한 계산은
    _순수(pure)_해야 한다는 것이다.  즉, 실행 결과는 오로지 결과를
    내는 것이라는 것이다. 입출력(I/O), 변수의 값을 할당, 포인터를
    변경하는 것과 같은 _부작용(side effects)_은 없어야 한다는
    생각이다. 예를 들어, _명령 기반(imperative)_ 정렬 함수는 숫자들
    리스트를 받아서 숫자들을 가리키는 포인터들을 배열해서 그 리스트
    안에 순서대로 놓도록 작성한다면, 순수한 정렬 함수는 원래 리스트를
    받아서 그 리스트의 숫자들을 정렬된 순서로 담고 있는 _새로운_
    리스트를 리턴한다.

    이런 스타일로 프로그래밍하면 프로그램을 이해하기 쉽고 추론하기
    쉬운 형태로 작성할 수 있는 혜택이 있다. 자료구조에 대해 연산할 때
    마다 항상 원래 자료구조는 변경하지 않은 채 두고 모두 새로운 자료
    구조를 결과로 낸다면 이 자료구조를 공유하는 방식을 고민할 필요가
    없고, 프로그램의 한 부분을 실행해서 변경이 발생함으로 인해
    프로그램의 다른 부분이 의존하는 불변 성질을 깨뜨리지 않을까 걱정할
    필요도 없다. 이러한 사항들은 동시성을 사용하는 시스템들에서 특히
    중요하다.  동시성 시스템(concurrent systems)에서 변경 가능한
    상태를 여러 스레드들이 공유하는 것은 치명적인 버그들의 잠재적
    원인이다. 산업계에서 최근에 함수형 프로그래밍에 관심을 보인 많은
    부분들이 동시성이 존재하는 상황에서 더 간단하게 동작하도록
    프로그래밍할 수 있기 때문이다.

    최근에 함수형 프로그래밍에 환호하는 또 다른 이유는 첫 번째 이유와
    연관되어 있는데, 보통 함수형 프로그램들은 명령 기반 프로그램들
    보다 병렬화가 훨씬 더 쉽기 때문이다.  만일 프로그램을 실행했을 때
    결과를 내는 것 말고 특별히 다른 효과가 없다면 이 프로그램을
    어디에서 실행하든 상관없다. 비슷한 얘기로, 프로그램을 실행하면서
    자료구조가 내부적으로 결코 변경되지 않는다면 프로세서 코어들 또는
    네트워크를 넘어서 이 자료구조를 자유롭게 복사할 수
    있다. 하둡(Hadoop)과 같은 대용량 분산 질의 처리기들의 핵심이고
    구글(Google)에서 전체 웹을 색인하는 데 사용하는
    "맵-리듀스(Map-Reduce)" 프로그래밍 스타일은 함수형 프로그래밍의
    고전적인 예이다.

    이 강의의 목적을 위하여 함수형 프로그래밍은 앞서 언급한 장점과
    더불어 또 다른 중요한 매력이 있다. 논리와 컴퓨터과학을 연결하는
    다리 역할을 하는 것이다.  정말로 콕은 그 자체로 작지만 매우
    표현력이 높은 함수형 프로그래밍 언어와 논리적 주장들을 서술하고
    증명하는 데 사용할 도구들의 집합을 조합해놓은 것이다.  더욱이 더
    자세히 들여다보면 콕의 논리에 관한 것과 프로그래밍에 관한 것은 콕
    시스템의 동일한 기초 원리(underlying machinery)를 보는 다른
    관점 들일뿐이라는 것을 발견한다. 즉, _증명과 프로그램_. *)

(* ================================================================= *)
(** ** 더 자세한 내용 *)

(** 이 책은 자체로 모든 내용을 담으려 했지만 특정 주제들을 더 깊이 탐구하고자 하는
    독자들은 [후기] 장에서 더 자세한 내용에 대한 제안을 참고할 수 있다.   *)

(* ################################################################# *)
(** * 강의 진행을 위한 참고 *)

(* ================================================================= *)
(** ** 책의 장들 간 의존성 *)

(** 이 책의 모든 장들 간의 의존성을 보여주는 다이어그램과 내용들을 연결하는 경로들을
    [deps.html] 파일에서 확인할 수 있다. *)

(* ================================================================= *)
(** ** 시스템 요구사항 *)

(** 윈도우, 리눅스, 맥 운영체제에서 콕을 실행할 수 있다. 필요한 사항은:

       - 콕 웹 사이트에서 제공하는 콕을 설치. 8.6 버전을 사용하면 된다.

       - 콕을 대화식으로 사용하기 위해 필요한 통합개발환경(IDE). 현재 두 가지 선택이 가능하다.

           - 프룹 제너럴(Proof General)은 이맥스 기반 통합개발환경이다. 이맥스에 익숙한
             사용자가 선호하는 선택이다. 콕과 별도의 설치가 필요하다 (구글링 "Proof General").

             이맥스를 사용하는 콕 사용자들 중 대범한 사용자라면 확장
             기능들 [company-coq]과 [control-lock]을 내려받아 사용할
             수도 있다.

           - CoqIDE는 간단한 독립적인 통합개발환경이다. 콕과 함께 배포되기 때문에 콕을 설치하면
             바로 사용 가능하다. 처음부터 컴파일해서 사용할 수도 있는데 어떤 환경에서는
             그래픽 사용자 인터페이스 라이브러리 등 추가 패키지들을 설치해야 컴파일 가능하다. *)

(* ================================================================= *)
(** ** 연습문제 *)

(** 각 장은 많은 연습문제들을 포함하고 있다. 각 연습문제에 별 등급을 매겨 놓았다.

       - 별 하나: 쉬운 연습문제로 등급을 표시해두었다. 대부분의 독자들은 1,2분 내에
         풀 수 있을 것이다. 이 별 등급의 연습문제들을 만날 때마다 풀어보는 습관을 갖기 바란다.

       - 별 두 개: 간단한 연습문제들 (5~10분).

       - 별 세 개: 다소 생각을 요구하는 연습문제들 (10분에서 30분).

       - 별 네 개와 다섯 개: 더 어려운 연습문제들 (30분 이상).

    어떤 연습문제들에는 "고급(Advanced)"을 붙여 놓았고 다른
    연습문제들은 "선택(optional)"을 붙여 놓았다. 선택 사항이 아니고
    고급 연습문제들이 아닌 연습문제들만 푸는 것만으로도 핵심적인
    내용을 잘 커버할 것이다. 선택적 연습문제들은 핵심 개념들과 함께
    다소 추가적인 연습을 제공하고 일부 독자들에게 흥미를 줄 수 있은
    부차적인 주제들을 소개한다. 고급 연습문제들은 도전적이고 깊은
    내용을 원하는 독자들을 위한 것이다.

    _이 연습문제들에 대한 풀이들을 공공장소에 공개하지 않을 것을
    부탁한다._ 소프트웨어 기초는 스스로 학습과 대학 강의에 널리
    사용되고 있다. 해답이 쉽게 노출된다면 과제물을 가지고 성적을 주는
    일반 강의에 훨씬 덜 도움이 될 것이다. 특히 독자들에게 검색
    엔진으로 찾을 수 있는 어떠한 장소에도 연습문제들의 해답을 올리지
    않도록 요청한다.   *)

(* ================================================================= *)
(** ** 콕 파일들을 내려받기 *)

(** 이 책의 배포판에 대한 전체 소스를 포함하는 묶음(tar) 파일에 콕
    스크립트와 에이치티엠엘(HTML) 파일들이 있는데 아래 주소에서
    제공한다.

        http://www.cis.upenn.edu/~bcpierce/sf

    (만일 이 책을 강의의 일부로 사용한다면 그 강의를 담당하는 교수가
     이 파일들을 직접 수정한 버전을 제공할 수도 있다. 배포판 대신
     수정판을 사용하세요) *)

(* ================================================================= *)
(** ** 강의 비디오 *)

(** _논리적 기초_에 관한 집중 여름 강좌들_(2017년 딥스펙 여름 학교의 일부)을
    아래 주소에서 볼 수 있다. 처음 강의 동영상의 화질이 좋지 않지만 나중에는
    점점 나아질 것이다. *)

    - https://deepspec.org/event/dsss17/coq_intensive.html

(* ################################################################# *)
(** * 강사를 위한 메모  *)

(** 강사 본인의 강의에 이 책을 사용한다면, 내용 중에 변경하고,
    개선하고, 추가하고 싶은 것이 반드시 있을 것이다. 당신이 기여하는 것을 환영합니다!

    만일 라이센스 문구, 서브라이센스 등을 조정해야하는 상황이 발생하는
    경우 합법성 문제를 단순하게 유지하고 책임을 단일화하기 위해서 이
    책에 기여하는 모든 사람들(개발자 저장소를 접근하는 모든
    사람들)에게 각자의 기여한 바에 대한 저작권을 다음과 같이 적절한
    "기록의 저자(Author of Record)"에 부여할 것을 요청한다.

      - 나는 나의 과거와 미래에 기여했던 바에 대한 저작권을 소프트웨어
        기초 프로젝트에 각 권 또는 요소의 "기록의 저자"에 부여하고,
        소프트웨어 기초의 나머지와 동일한 조항하에 라이센스를
        부여한다. 현재 시점에 "기록의 저자"는 다음과 같음을 이해하고
        있다. 2016년까지 "소프트웨어 기초"로, 2016년부터 각각 "논리적
        기초"와 "프로그래밍 기초"로 알려진 1권과 2권에 대해 "기록의
        저자"는 벤자민 피어스이다. 3권 "함수형 알고리즘 검증"에 대해
        "기록의 저자"는 안드류 더블류 아펠이다. 이 범위 밖에 있는
        요소(예를 들어 타입 세팅, 채점 도구, 다른 기반 소프트웨어)들에
        대해 "Author of Record"는 벤자민 피어스이다.

    시작하려면 벤자민 피어스에게 본인 소개와 이 책을 사용할 계획을 서술한 이메일을 보내주세요. 그리고
    아래 내용도 함께 보내주세요.
       (1) 위의 저작권 위임 텍스트와
       (2) 명령어 "htpasswd -s -n NAME"를 실행한 결과
    원하는 사용자 이름을 정해서 NAME을 바꾸면 됩니다.

    서브버전 저장소와 개발자 메일 리스트에 접근할 수 있도록 설정할 것입니다. 이 저장소의
    [INSTRUCTORS] 파일에서 추가 지시 사항들을 확인할 수 있습니다. *)

(* ################################################################# *)
(** * 번역 *)

(** 번역을 자원해서 진행하는 팀의 노력 덕분에
    [http://proofcafe.org/sf]에서 일본어로 _소프트웨어 기초_를 읽을 수 있습니다.
    중국어 번역은 진행 중입니다. *)

(* ################################################################# *)
(** * 감사 *)

(** _소프트웨어 기초_ 시리즈를 개발하는 것을 국립과학재단 엔에스에프
    익스페디션 그란트 1521523, _딥 스펙에 관한 과학_으로부터 일부
    지원을 받았습니다.

(** $Date: 2017-08-24 17:13:02 -0400 (Thu, 24 Aug 2017) $ *)


(*! Language | Combinational primitives available in all Kôika programs !*)
Require Export Koika.Common Koika.Environments Koika.IndexUtils Koika.Types Koika.ErrorReporting.

Inductive bits_comparison :=
  cLt | cGt | cLe | cGe.

Inductive bits_display_style :=
  dBin | dDec | dHex | dFull.

Record display_options :=
  { display_strings : bool;
    display_newline : bool;
    display_style : bits_display_style }.

Module PrimUntyped.
  Inductive udisplay :=
  | UDisplayUtf8
  | UDisplayValue (opts: display_options).

  Inductive uconv :=
  | UPack
  | UUnpack (tau: type)
  | UIgnore.

  Inductive ubits1 :=
  | UNot
  | USExt (width: nat)
  | UZExtL (width: nat)
  | UZExtR (width: nat)
  | URepeat (times: nat)
  | USlice (offset: nat) (width: nat).

  Inductive ubits2 :=
  | UAnd
  | UOr
  | UXor
  | ULsl
  | ULsr
  | UAsr
  | UConcat
  | USel
  | USliceSubst (offset: nat) (width: nat)
  | UIndexedSlice (width: nat)
  | UPlus
  | UMinus
  | UMul
  | UCompare (signed: bool) (c: bits_comparison).

  Inductive ustruct1 :=
  | UGetField (f: string)
  | UGetFieldBits (sig: struct_sig) (f: string).

  Inductive ustruct2 :=
  | USubstField (f: string)
  | USubstFieldBits (sig: struct_sig) (f: string).

  Inductive uarray1 :=
  | UGetElement (pos: nat)
  | UGetElementBits (sig: array_sig) (pos: nat).

  Inductive uarray2 :=
  | USubstElement (pos: nat)
  | USubstElementBits (sig: array_sig) (pos: nat).

  Inductive ufn1 :=
  | UDisplay (fn: udisplay)
  | UConv (fn: uconv)
  | UBits1 (fn: ubits1)
  | UStruct1 (fn: ustruct1)
  | UArray1 (fn: uarray1).

  Inductive ufn2 :=
  | UEq (negate: bool)
  | UBits2 (fn: ubits2)
  | UStruct2 (fn: ustruct2)
  | UArray2 (fn: uarray2).
End PrimUntyped.

Module PrimTyped.
  Inductive fdisplay :=
  | DisplayUtf8 (len: nat)
  | DisplayValue (tau: type) (opts: display_options).

  Inductive fconv :=
    Pack | Unpack | Ignore.

  Inductive lowered1 :=
  | IgnoreBits (sz: nat)
  | DisplayBits (fn: fdisplay).

  Inductive fbits1 :=
  | Not (sz: nat)
  | SExt (sz: nat) (width: nat)
  | ZExtL (sz: nat) (width: nat)
  | ZExtR (sz: nat) (width: nat)
  | Repeat (sz: nat) (times: nat)
  | Slice (sz: nat) (offset: nat) (width: nat)
  | Lowered (fn: lowered1).

  Inductive fbits2 :=
  | And (sz: nat)
  | Or (sz: nat)
  | Xor (sz: nat)
  | Lsl (bits_sz: nat) (shift_sz: nat)
  | Lsr (bits_sz: nat) (shift_sz: nat)
  | Asr (bits_sz: nat) (shift_sz: nat)
  | Concat (sz1 sz2 : nat)
  | Sel (sz: nat)
  | SliceSubst (sz: nat) (offset: nat) (width: nat)
  | IndexedSlice (sz: nat) (width: nat)
  | Plus (sz : nat)
  | Minus (sz : nat)
  | Mul (sz1 sz2: nat)
  | EqBits (sz: nat) (negate: bool)
  | Compare (signed: bool) (c: bits_comparison) (sz: nat).

  Inductive fstruct1 :=
  | GetField.

  Inductive fstruct2 :=
  | SubstField.

  Inductive farray1 :=
  | GetElement.

  Inductive farray2 :=
  | SubstElement.

  Inductive fn1 :=
  | Display (fn: fdisplay)
  | Conv (tau: type) (fn: fconv)
  | Bits1 (fn: fbits1)
  | Struct1 (fn: fstruct1) (sig: struct_sig) (f: struct_index sig)
  | Array1 (fn: farray1) (sig: array_sig) (idx: array_index sig).

  Inductive fn2 :=
  | Eq (tau: type) (negate: bool)
  | Bits2 (fn: fbits2)
  | Struct2 (fn: fstruct2) (sig: struct_sig) (f: struct_index sig)
  | Array2 (fn: farray2) (sig: array_sig) (idx: array_index sig).

  Definition GetElementBits (sig: array_sig) (idx: array_index sig) : fbits1 :=
    Slice (array_sz sig) (element_offset_right sig idx) (element_sz sig).

  Definition SubstElementBits (sig: array_sig) (idx: array_index sig) : fbits2 :=
    SliceSubst (array_sz sig) (element_offset_right sig idx) (element_sz sig).

  Definition GetFieldBits (sig: struct_sig) (idx: struct_index sig) : fbits1 :=
    Slice (struct_sz sig) (field_offset_right sig idx) (field_sz sig idx).

  Definition SubstFieldBits (sig: struct_sig) (idx: struct_index sig) : fbits2 :=
    SliceSubst (struct_sz sig) (field_offset_right sig idx) (field_sz sig idx).
End PrimTyped.

Module PrimTypeInference.
  Import PrimUntyped PrimTyped.

  Definition find_field sig f : result _ fn_tc_error :=
    opt_result (List_assoc f sig.(struct_fields)) (Arg1, UnboundField f sig).

  Definition check_index sig pos : result (array_index sig) fn_tc_error :=
    opt_result (Vect.index_of_nat sig.(array_len) pos) (Arg1, OutOfBounds pos sig).

  Definition tc1 (fn: ufn1) (tau1: type): result fn1 fn_tc_error :=
    match fn with
    | UDisplay fn =>
      match fn with
      | UDisplayUtf8 =>
        let/res sig := assert_kind (kind_array None) Arg1 tau1 in
        Success (Display (DisplayUtf8 sig.(array_len)))
      | UDisplayValue opts =>
        Success (Display (DisplayValue tau1 opts))
      end
    | UConv fn =>
      Success (match fn with
               | UPack => Conv tau1 Pack
               | UUnpack tau => Conv tau Unpack
               | UIgnore => Conv tau1 Ignore
               end)
    | UBits1 fn =>
      let/res sz1 := assert_kind kind_bits Arg1 tau1 in
      Success (Bits1 match fn with
                     | UNot => Not sz1
                     | USExt width => SExt sz1 width
                     | UZExtL width => ZExtL sz1 width
                     | UZExtR width => ZExtR sz1 width
                     | URepeat times => Repeat sz1 times
                     | USlice offset width => Slice sz1 offset width
                     end)
    | UStruct1 fn =>
      match fn with
      | UGetField f =>
        let/res sig := assert_kind (kind_struct None) Arg1 tau1 in
        let/res idx := find_field sig f in
        Success (Struct1 GetField sig idx)
      | UGetFieldBits sig f =>
        let/res idx := find_field sig f in
        Success (Bits1 (GetFieldBits sig idx))
      end
    | UArray1 fn =>
      match fn with
      | UGetElement pos =>
        let/res sig := assert_kind (kind_array None) Arg1 tau1 in
        let/res idx := check_index sig pos in
        Success (Array1 GetElement sig idx)
      | UGetElementBits sig pos =>
        let/res idx := check_index sig pos in
        Success (Bits1 (GetElementBits sig idx))
      end
    end.

  Definition tc2 (fn: ufn2) (tau1: type) (tau2: type): result fn2 fn_tc_error :=
    match fn with
    | UEq negate => Success (Eq tau1 negate)
    | UBits2 fn =>
      let/res sz1 := assert_kind kind_bits Arg1 tau1 in
      let/res sz2 := assert_kind kind_bits Arg2 tau2 in
      Success (Bits2 match fn with
                     | USel => Sel sz1
                     | USliceSubst offset width => SliceSubst sz1 offset width
                     | UIndexedSlice width => IndexedSlice sz1 width
                     | UAnd => And sz1
                     | UOr => Or sz1
                     | UXor => Xor sz1
                     | ULsl => Lsl sz1 sz2
                     | ULsr => Lsr sz1 sz2
                     | UAsr => Asr sz1 sz2
                     | UConcat => Concat sz1 sz2
                     | UPlus => Plus sz1
                     | UMinus => Minus sz1
                     | UMul => Mul sz1 sz2
                     | UCompare signed c => Compare signed c sz1
                     end)
    | UStruct2 fn =>
      match fn with
      | USubstField f =>
        let/res sig := assert_kind (kind_struct None) Arg1 tau1 in
        let/res idx := find_field sig f in
        Success (Struct2 SubstField sig idx)
      | USubstFieldBits sig f =>
        let/res idx := find_field sig f in
        Success (Bits2 (SubstFieldBits sig idx))
      end
    | UArray2 fn =>
      match fn with
      | USubstElement pos =>
        let/res sig := assert_kind (kind_array None) Arg1 tau1 in
        let/res idx := check_index sig pos in
        Success (Array2 SubstElement sig idx)
      | USubstElementBits sig pos =>
        let/res idx := check_index sig pos in
        Success (Bits2 (SubstElementBits sig idx))
      end
    end.
End PrimTypeInference.

Module CircuitSignatures.
  Import PrimTyped.
  Import SigNotations.

  Definition DisplaySigma (fn: fdisplay) : Sig 1 :=
    {$ match fn with
       | DisplayUtf8 len => array_t {| array_len := len; array_type := bits_t 8 |}
       | DisplayValue tau _ => tau
       end ~> unit_t $}.

  Definition CSigma1 (fn: fbits1) : CSig 1 :=
    match fn with
    | Not sz => {$ sz ~> sz $}
    | SExt sz width => {$ sz ~> (Nat.max sz width) $}
    | ZExtL sz width => {$ sz ~> (Nat.max sz width) $}
    | ZExtR sz width => {$ sz ~> (Nat.max sz width) $}
    | Repeat sz times => {$ sz ~> times * sz $}
    | Slice sz offset width => {$ sz ~> width $}
    | Lowered fn =>
      match fn with
      | DisplayBits fn => CSig_of_Sig (DisplaySigma fn)
      | IgnoreBits sz => {$ sz ~> 0 $}
      end
    end.

  Definition CSigma2 (fn: PrimTyped.fbits2) : CSig 2 :=
    match fn with
    | Sel sz => {$ sz ~> (log2 sz) ~> 1 $}
    | SliceSubst sz offset width => {$ sz ~> width ~> sz $}
    | IndexedSlice sz width => {$ sz ~> (log2 sz) ~> width $}
    | And sz => {$ sz ~> sz ~> sz $}
    | Or sz => {$ sz ~> sz ~> sz $}
    | Xor sz => {$ sz ~> sz ~> sz $}
    | Lsl bits_sz shift_sz => {$ bits_sz ~> shift_sz ~> bits_sz $}
    | Lsr bits_sz shift_sz => {$ bits_sz ~> shift_sz ~> bits_sz $}
    | Asr bits_sz shift_sz => {$ bits_sz ~> shift_sz ~> bits_sz $}
    | Concat sz1 sz2 => {$ sz1 ~> sz2 ~> (sz2 + sz1) $}
    | EqBits sz _ => {$ sz ~> sz ~> 1 $}
    | Plus sz => {$ sz ~> sz ~> sz $}
    | Minus sz => {$ sz ~> sz ~> sz $}
    | Mul sz1 sz2 => {$ sz1 ~> sz2 ~> sz1 + sz2 $}
    | Compare _ _ sz => {$ sz ~> sz ~> 1 $}
    end.
End CircuitSignatures.

Module PrimSignatures.
  Import PrimUntyped PrimTyped CircuitSignatures.
  Import SigNotations.

  Definition Sigma1 (fn: fn1) : Sig 1 :=
    match fn with
    | Conv tau fn =>
      match fn with
      | Pack => {$ tau ~> bits_t (type_sz tau) $}
      | Unpack => {$ bits_t (type_sz tau) ~> tau $}
      | Ignore => {$ tau ~> unit_t $}
      end
    | Display fn => DisplaySigma fn
    | Bits1 fn => Sig_of_CSig (CSigma1 fn)
    | Struct1 GetField sig idx => {$ struct_t sig ~> field_type sig idx $}
    | Array1 GetElement sig idx => {$ array_t sig ~> sig.(array_type) $}
    end.

  Definition Sigma2 (fn: fn2) : Sig 2 :=
    match fn with
    | Eq tau _ => {$ tau ~> tau ~> bits_t 1 $}
    | Bits2 fn => Sig_of_CSig (CSigma2 fn)
    | Struct2 SubstField sig idx => {$ struct_t sig ~> field_type sig idx ~> struct_t sig $}
    | Array2 SubstElement sig idx => {$ array_t sig ~> sig.(array_type) ~> array_t sig $}
    end.
End PrimSignatures.

Module BitFuns.
  Definition bitfun_of_predicate {sz} (p: bits sz -> bits sz -> bool) (bs1 bs2: bits sz) :=
    Ob~(p bs1 bs2).

  Definition sel {sz} (bs: bits sz) (idx: bits (log2 sz)) :=
    Ob~match Bits.to_index sz idx with
       | Some idx => Bits.nth bs idx
       | _ => false (* TODO: x *)
       end.

  Definition lsl {bits_sz shift_sz} (bs: bits bits_sz) (places: bits shift_sz) :=
    Bits.lsl (Bits.to_nat places) bs.

  Definition lsr {bits_sz shift_sz} (bs: bits bits_sz) (places: bits shift_sz) :=
    Bits.lsr (Bits.to_nat places) bs.

  Definition asr {bits_sz shift_sz} (bs: bits bits_sz) (places: bits shift_sz) :=
    Bits.asr (Bits.to_nat places) bs.

  Definition _eq {tau} {EQ: EqDec tau} (v1 v2: tau) :=
    Ob~(beq_dec v1 v2).

  Definition _neq {tau} {EQ: EqDec tau} (v1 v2: tau) :=
    Ob~(negb (beq_dec v1 v2)).

  Fixpoint get_field fields
           (v: struct_denote fields)
           (idx: index (List.length fields))
           {struct fields}
    : type_denote (snd (List_nth fields idx)).
    destruct fields, idx, p; cbn.
    - apply (fst v).
    - apply (get_field fields (snd v) a).
  Defined.

  Fixpoint subst_field fields
           (v: struct_denote fields)
           (idx: index (List.length fields))
           (v': type_denote (snd (List_nth fields idx)))
           {struct fields}
    : (struct_denote fields).
    destruct fields, idx, p; cbn.
    - apply (v', snd v).
    - apply (fst v, subst_field fields (snd v) a v').
  Defined.
End BitFuns.

Module CircuitPrimSpecs.
  Import PrimTyped BitFuns.

  Definition sigma1 (fn: PrimTyped.fbits1) : CSig_denote (CircuitSignatures.CSigma1 fn) :=
    match fn with
    | Not _ => fun bs => Bits.neg bs
    | SExt sz width => fun bs => Bits.extend_end bs width (Bits.msb bs)
    | ZExtL sz width => fun bs => Bits.extend_end bs width false
    | ZExtR sz width => fun bs => Bits.extend_beginning bs width false
    | Repeat sz times => fun bs => Bits.repeat times bs
    | Slice _ offset width => Bits.slice offset width
    | Lowered (DisplayBits _) => fun bs => Ob
    | Lowered (IgnoreBits _) => fun bs => Ob
    end.

  Definition sigma2 (fn: PrimTyped.fbits2) : CSig_denote (CircuitSignatures.CSigma2 fn) :=
    match fn with
    | Sel _ => sel
    | SliceSubst _ offset width => Bits.slice_subst offset width
    | IndexedSlice _ width => fun bs offset => Bits.slice (Bits.to_nat offset) width bs
    | And _ => Bits.and
    | Or _ => Bits.or
    | Xor _ => Bits.xor
    | Lsl _ _ => lsl
    | Lsr _ _ => lsr
    | Asr _ _ => asr
    | Concat _ _ => Bits.app
    | Plus _ => Bits.plus
    | Minus _ => Bits.minus
    | Mul _ _ => Bits.mul
    | EqBits _ false => _eq
    | EqBits _ true => _neq
    | Compare true cLt _ => bitfun_of_predicate Bits.signed_lt
    | Compare true cGt _ => bitfun_of_predicate Bits.signed_gt
    | Compare true cLe _ => bitfun_of_predicate Bits.signed_le
    | Compare true cGe _ => bitfun_of_predicate Bits.signed_ge
    | Compare false cLt _ => bitfun_of_predicate Bits.unsigned_lt
    | Compare false cGt _ => bitfun_of_predicate Bits.unsigned_gt
    | Compare false cLe _ => bitfun_of_predicate Bits.unsigned_le
    | Compare false cGe _ => bitfun_of_predicate Bits.unsigned_ge
    end.
End CircuitPrimSpecs.

Module PrimSpecs.
  Import PrimTyped BitFuns.

  Definition sigma1 (fn: fn1) : Sig_denote (PrimSignatures.Sigma1 fn) :=
    match fn with
    | Display fn =>
      match fn with
      | DisplayUtf8 _ => fun _ => Ob
      | DisplayValue tau _ => fun _ => Ob
      end
    | Conv tau fn =>
      match fn with
      | Pack => fun v => bits_of_value v
      | Unpack => fun bs => value_of_bits bs
      | Ignore => fun _ => Ob
      end
    | Bits1 fn => CircuitPrimSpecs.sigma1 fn
    | Struct1 GetField sig idx => fun s => get_field sig.(struct_fields) s idx
    | Array1 GetElement sig idx => fun a => vect_nth a idx
    end.

  Definition sigma2 (fn: fn2) : Sig_denote (PrimSignatures.Sigma2 fn) :=
    match fn with
    | Eq tau false  => _eq
    | Eq tau true  => _neq
    | Bits2 fn => CircuitPrimSpecs.sigma2 fn
    | Struct2 SubstField sig idx => fun s v => subst_field sig.(struct_fields) s idx v
    | Array2 SubstElement sig idx => fun a e => vect_replace a idx e
    end.
End PrimSpecs.