Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Require Import rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_nom_sel_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_upp x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1' T2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_sel_low_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_low x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (orb (subtype T1' T2)
                                                           (subtype T1 T2')).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_sel_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_equ x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (orb (subtype T1' T2)
                                                           (subtype T1 T2')).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_sel_nom_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_nom x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1' T2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_nom_low_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_low L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_nom_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_equ L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_nom_nom_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 L2 t T2', T2 = (t_nom L2 t T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_nom_rfn_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 Ts, T2 = (t_rfn_top Ts) ->
                           subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_rfn_sel_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall x2 L2 T2 Ts T', T2 = (t_rfn_sel x2 L2 Ts T') ->
                                    subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_sha_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 x2 L2 ss2, T2 = (t_sha_top x2 L2 ss2) ->
                                  subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_sha_sel_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 x2 L2 ss2 T', T2 = (t_sha_sel x2 L2 ss2 T') ->
                                     subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_all_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 T T', T2 = (t_all T T') ->
                             subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_nom_bot_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  subtype T1 t_bot = subtype T1' t_bot.
Proof.
  intros.

  remember (subtype T1 t_bot) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
  Qed.

Lemma subtype_sel_nom_nil_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  subtype T1 t_nil = false.
Proof.
  intros; subst.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.

Qed.

Lemma subtype_sel_nom_con_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 T2' Ts, T2 = (t_con T2' Ts) ->
                               subtype T1 T2 = false.
Proof.
  intros; subst.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.

Qed.

Lemma subtype_sel_nom_reduce :
  forall T1 x1 L1 T1',
    T1 = (t_sel_nom x1 L1 T1') ->
    forall T2, subtype T1 T2 = match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_upp x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_nom x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_upp L2 T2' => false
                          | t_low L2 T2' => false
                          | t_equ L2 T2' => false
                          | t_nom L2 _ T2' => false

                          | t_nil => false
                          | t_con _ _ => false

                          | _ => subtype T1' T2
                          end.
Proof.
  intros.

  destruct T2.

  apply subtype_top;
    subst;
    intros;
    intro Hcontra;
    inversion Hcontra.

  subst;
    apply subtype_sel_nom_bot_reduce
      with (x1:=x1)(L1:=L1);
    auto.

  subst;
    apply subtype_sel_nom_sel_upp_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_low_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_equ_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_nom_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_rfn_top_reduce
      with (x1:=x1)(L1:=L1)(Ts:=T2);
    auto.

  subst;
    apply subtype_sel_nom_rfn_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(Ts:=T2_1)(T':=T2_2);
    auto.

  subst;
    apply subtype_sel_nom_sha_top_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(ss2:=d);
    auto.

  subst;
    apply subtype_sel_nom_sha_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T':=T2)(ss2:=d);
    auto.

  subst;
    apply subtype_sel_nom_all_reduce
      with (x1:=x1)(L1:=L1)(T:=T2_1)(T':=T2_2);
    auto.

  subst;
    apply subtype_sel_nom_upp_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_low_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_equ_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    eapply subtype_sel_nom_nom_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    eauto.

  subst; eapply subtype_sel_nom_nil_reduce; eauto.

  subst; eapply subtype_sel_nom_con_reduce; eauto.

Qed.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import Domains.basics.
Require Import Domains.preord.
Require Import Domains.categories.
Require Import Domains.sets.
Require Import Domains.finsets.
Require Import Domains.esets.
Require Import Domains.effective.
Require Import Domains.directed.
Require Import Domains.plotkin.
Require Import Domains.joinable.
Require Import Domains.approx_rels.
Require Import Domains.cpo.

Delimit Scope plt_scope with plt.
Open Scope plt_scope.

(**  * Categories of profinite domains, expressed as Plotkin orders

     Here we define both the category PLT of effective Plotkin orders,
     and the category ∂PLT of partial Plotkin orders.  PLT is
     is equivalant to the category of profinite domains via
     ideal completion, and ∂PLT is equivalant to the category of
     pointed profinite domains with strict continuous functions.

     The objects of PLT are the effective Plotkin orders, and the
     arrows are approximable relations.  The objects and characteristic
     operations are provided for the unit, empty, product, sum and
     function space.

     PLT is DCPO-enriched, which means that each homset is equipped
     with a DCPO.  In addition the composition operation is
     continuous in both arguments.
  *)

Module PLT.
Section PLT.
  Variable hf:bool.

  Record class_of (A:Type) :=
    Class
    { cls_preord : Preord.mixin_of A
    ; cls_ord := Preord.Pack A cls_preord
    ; cls_effective : effective_order cls_ord
    ; cls_plotkin : plotkin_order hf cls_ord
    }.

  Record ob := Ob { carrier :> Type; class : class_of carrier }.

  Definition effective (X:ob) := cls_effective _ (class X).
  Definition plotkin (X:ob)   := cls_plotkin _ (class X).
  Definition ord (X:ob)       := cls_ord _ (class X).

  Canonical Structure ord.
  Canonical Structure dec (X:ob) := eff_to_ord_dec (ord X) (effective X).

  Record hom (A B:ob) :=
    Hom
    { hom_rel :> erel (ord A) (ord B)
    ; hom_order : forall x x' y y', x ≤ x' -> y' ≤ y ->
         (x,y) ∈ hom_rel -> (x',y') ∈ hom_rel
    ; hom_directed : directed_rel hf (ord A) (ord B) (effective A) hom_rel
    }.
  Arguments hom_rel [A] [B] h n.

  Program Definition hom_ord_mixin (A B:ob) : Preord.mixin_of (hom A B) :=
    Preord.Mixin (hom A B) (fun f g => hom_rel f ≤ hom_rel g) _ _.
  Solve Obligations of hom_ord_mixin with (intros; eauto).
  Solve Obligations of hom_ord_mixin with (simpl; auto).
  Next Obligation.
    simpl. intros. etransitivity; eauto.
  Qed.

  Canonical Structure hom_ord (A B:ob) := Preord.Pack (hom A B) (hom_ord_mixin A B).

  Definition hom_eq_mixin (A B:ob) := Preord.ord_eq (hom_ord A B).
  Canonical Structure hom_eq (A B:ob) := Eq.Pack (hom A B) (hom_eq_mixin A B).

  Definition ident (A:ob) : hom A A :=
    Hom A A
       (ident_rel (effective A))
       (ident_ordering (ord A) (effective A))
       (ident_image_dir hf (ord A) (effective A)).

  Program Definition compose (A B C:ob) (g:hom B C) (f:hom A B) : hom A C :=
    Hom A C (compose_rel (effective B) g f) _ _.
  Next Obligation.
    intros A B C g f.
    apply compose_ordering. apply hom_order. apply hom_order.
  Qed.
  Next Obligation.
    intros A B C g f. apply compose_directed.
    apply hom_order. apply hom_order.
    apply hom_directed. apply hom_directed.
  Qed.

  Definition comp_mixin : Comp.mixin_of ob hom
    := Comp.Mixin ob hom ident compose.
  Canonical Structure comp : Comp.type := Comp.Pack ob hom comp_mixin.

  Lemma compose_mono (X Y Z:ob) (f f':hom X Y) (g g':hom Y Z) :
    f ≤ f' -> g ≤ g' -> g ∘ f ≤ g' ∘ f'.
  Proof.
    repeat intro; simpl in *.
    destruct a as [x z].
    apply compose_elem in H1.
    apply compose_elem.
    apply hom_order.
    destruct H1 as [y [??]].
    exists y. split.
    apply H; auto.
    apply H0; auto.
    apply hom_order.
  Qed.

  Lemma cat_axioms : Category.axioms ob hom hom_eq_mixin comp_mixin.
  Proof.
    constructor.

    intros. apply compose_ident_rel2. apply hom_order.
    intros. apply compose_ident_rel1. apply hom_order.
    intros. apply compose_assoc.
    intros. split; apply compose_mono; auto.
  Qed.

  Canonical Structure PLT : category :=
    Category ob hom hom_eq_mixin comp_mixin cat_axioms.

  Program Definition empty : ob :=
    Ob False
      (Class _
        (Preord.mixin emptypo)
        effective_empty
        (empty_plotkin hf)).

  Program Definition unit : ob :=
    Ob unit
      (Class _
        (Preord.mixin unitpo)
        effective_unit
        (unit_plotkin hf)).

  Definition prod (A B:ob) : ob :=
    Ob (carrier A * carrier B)
       (Class _
         (Preord.mixin (ord A × ord B))
         (effective_prod (effective A) (effective B))
         (plotkin_prod hf (ord A) (ord B) (effective A) (effective B) (plotkin A) (plotkin B))).
  Canonical Structure prod.

  Definition sum (A B:ob) : ob :=
    Ob (sum_preord (ord A) (ord B))
       (Class _
         (Preord.mixin (sum_preord (ord A) (ord B)))
         (effective_sum (effective A) (effective B))
         (plotkin_sum hf (ord A) (ord B) (effective A) (effective B)
             (plotkin A) (plotkin B))
         ).
  Canonical Structure sum.

  Definition exp (A B:ob) : ob :=
    Ob (joinable_relation hf (ord A) (ord B))
       (Class _
         (joinable_rel_ord_mixin hf (ord A) (ord B))
         (joinable_rel_effective hf (ord A) (ord B) (effective A) (effective B) (plotkin A))
         (joinable_rel_plt hf (ord A) (ord B) (effective A) (plotkin A) (effective B) (plotkin B))).
  Canonical Structure exp.

  Program Definition initiate A : empty → A :=
    Hom empty A (esets.empty (prod_preord (ord empty) (ord A))) _ _.
  Next Obligation.
    intros. apply empty_elem in H1. elim H1.
  Qed.
  Next Obligation.
    intros A x. elim x.
  Qed.

  Program Definition terminate A : A → unit :=
    Hom A unit (eprod (eff_enum _ (effective A)) (eff_enum _ (effective unit))) _ _.
  Next Obligation.
    intros.
    apply eprod_elem. split; apply eff_complete.
  Qed.
  Next Obligation.
    intros A x. repeat intro.
    exists tt. split.
    hnf; simpl; intros. hnf; auto.
    apply erel_image_elem.
    apply eprod_elem; split; apply eff_complete.
  Qed.

  Definition iota1 A B : A → (sum A B) :=
    Hom A (sum A B)
      (iota1_rel (ord A) (ord B) (effective A))
      (iota1_ordering (ord A) (ord B) (effective A))
      (iota1_dir (ord A) (ord B) (effective A) hf).

  Definition iota2 A B : B → (sum A B) :=
    Hom B (sum A B)
      (iota2_rel (ord A) (ord B) (effective B))
      (iota2_ordering (ord A) (ord B) (effective B))
      (iota2_dir (ord A) (ord B) (effective B) hf).

  Definition sum_cases {C A B} (f:A → C) (g:B → C) : (sum A B) → C :=
    Hom (sum A B) C
      (sum_cases (ord C) (ord A) (ord B) f g)
      (sum_cases_ordering (ord C) (ord A) (ord B) f g
           (hom_order _ _ f) (hom_order _ _ g))
      (sum_cases_dir (ord C) (ord A) (ord B)
          (effective A) (effective B) hf f g
          (hom_directed _ _ f) (hom_directed _ _ g)).

  Definition app {A B} : (prod (exp A B) A) → B :=
    Hom (prod (exp A B) A) B
      (apply_rel hf (ord A) (ord B) (effective A) (effective B) (plotkin A))
      (apply_rel_ordering hf (ord A) (ord B) (effective A) (effective B) (plotkin A))
      (apply_rel_dir hf (ord A) (ord B) (effective A) (effective B) (plotkin A)).

  Definition curry {C A B} (f:(prod C A) → B) : C → (exp A B) :=
    Hom C (exp A B)
      (curry_rel hf (ord A) (ord B) (ord C)
        (effective A) (effective B) (effective C) (plotkin A) f)
      (curry_rel_ordering hf (ord A) (ord B) (ord C)
        (effective A) (effective B) (effective C) (plotkin A)
        f (hom_order _ _ f))
      (curry_rel_dir hf (ord A) (ord B) (ord C)
        (effective A) (effective B) (effective C) (plotkin A)
        f (hom_order _ _ f) (hom_directed _ _ f)
        (plotkin B)).

  Definition pair {C A B} (f:C → A) (g:C → B) : C → (prod A B) :=
    Hom C (prod A B)
      (pair_rel (effective C) f g)
      (pair_rel_ordering _ _ _ (effective C) f g (hom_order _ _ f) (hom_order _ _ g))
      (pair_rel_dir _ _ _ _ (effective C) f g
        (hom_order _ _ f) (hom_order _ _ g)
        (hom_directed _ _ f) (hom_directed _ _ g)).

  Definition pi1 {A B} : (prod A B) → A :=
    Hom (prod A B) A
      (pi1_rel (effective A) (effective B))
      (pi1_rel_ordering _ _ (effective A) (effective B))
      (pi1_rel_dir _ _ _ (effective A) (effective B)).

  Definition pi2 {A B} : (prod A B) → B :=
    Hom (prod A B) B
      (pi2_rel (effective A) (effective B))
      (pi2_rel_ordering _ _ (effective A) (effective B))
      (pi2_rel_dir _ _ _ (effective A) (effective B)).

  Definition pair_map {A B C D} (f:A → C) (g:B → D) : (prod A B) → (prod C D) :=
    pair (f ∘ pi1) (g ∘ pi2).

  Program Definition pair_map' {A B C D} (f:A → C) (g:B → D) : (prod A B) → (prod C D) :=
    Hom (prod A B) (prod C D) (pair_rel' f g) _ _.
  Next Obligation.
    intros A B C D f g.
    apply pair_rel_order'; auto.
    apply hom_order.
    apply hom_order.
  Qed.
  Next Obligation.
(* FIXME, move this proof into approx_rels.v *)

    repeat intro.
    destruct (hom_directed _ _ f (fst x) (image π₁ M)).
    apply inh_image; auto.
    red; intros. apply image_axiom2 in H0. destruct H0 as [y[??]].
    apply erel_image_elem.
    apply H in H0.
    apply erel_image_elem in H0.
    destruct x; destruct y.
    apply (pair_rel_elem' _ _ _ _ f g) in H0.
    simpl. destruct H0.
    apply member_eq with (c,c1); auto.
    simpl in H1.
    destruct H1; split; split; auto.
    apply hom_order.
    apply hom_order.
    destruct (hom_directed _ _ g (snd x) (image π₂ M)).
    apply inh_image; auto.
    red; intros. apply image_axiom2 in H1. destruct H1 as [y[??]].
    apply erel_image_elem.
    apply H in H1.
    apply erel_image_elem in H1.
    destruct x; destruct y.
    apply (pair_rel_elem' _ _ _ _ f g) in H1.
    simpl. destruct H1.
    apply member_eq with (c0,c2); auto.
    simpl in H2.
    destruct H2; split; split; auto.
    apply hom_order.
    apply hom_order.
    exists (x0,x1).
    destruct H0. destruct H1.
    split.
    red; intros.
    split.
    apply H0. apply image_axiom1'.
    exists x2. split; auto.
    apply H1. apply image_axiom1'.
    exists x2. split; auto.
    apply erel_image_elem.
    apply erel_image_elem in H2.
    apply erel_image_elem in H3.
    destruct x.
    apply (pair_rel_elem' _ _ _ _ f g).
    apply hom_order. apply hom_order.
    split; auto.
  Qed.

  Lemma pair_map_eq {A B C D} (f:A → C) (g:B → D) :
    pair_map f g ≈ pair_map' f g.
  Proof.
    red. simpl. symmetry.
    apply pair_rel_eq.
    apply hom_order.
    apply hom_order.
  Qed.

  Theorem initiate_univ A (f:empty → A) :
    f ≈ initiate A.
  Proof.
    split; hnf; intros.
    destruct a. elim c.
    destruct a. elim c.
  Qed.

  Theorem terminate_le_univ A (f:A → unit) :
    f ≤ terminate A.
  Proof.
    hnf; intros.
    red. simpl.
    destruct a.
    apply eprod_elem. split. apply eff_complete.
    apply single_axiom. destruct c0. auto.
  Qed.

  Theorem iota1_cases_commute C A B (f:A → C) (g:B → C) :
    sum_cases f g ∘ iota1 A B ≈ f.
  Proof.
    apply iota1_cases_commute.
    apply (hom_order _ _ f).
  Qed.

  Theorem iota2_cases_commute C A B (f:A → C) (g:B → C) :
    sum_cases f g ∘ iota2 A B ≈ g.
  Proof.
    apply iota2_cases_commute.
    apply (hom_order _ _ g).
  Qed.

  Theorem sum_cases_universal C A B (f:A → C) (g:B → C) (CASES:(sum A B) → C) :
    CASES ∘ iota1 A B ≈ f -> CASES ∘ iota2 A B ≈ g -> CASES ≈ sum_cases f g.
  Proof.
    intros. symmetry.
    apply (sum_cases_univ _ _ _ (effective A) (effective B) f g); auto.
    apply (hom_order _ _ CASES).
  Qed.

  Theorem pair_universal_le C A B (f:C → A) (g:C → B) (PAIR:C → (prod A B)) :
    pi1 ∘ PAIR ≤ f -> pi2 ∘ PAIR ≤ g -> PAIR ≤ pair f g.
  Proof.
    apply pair_rel_universal_le.
    apply hom_order.
    apply hom_order.
    apply hom_order.
  Qed.

  Theorem pair_universal C A B (f:C → A) (g:C → B) (PAIR:C → (prod A B)) :
    pi1 ∘ PAIR ≈ f -> pi2 ∘ PAIR ≈ g -> PAIR ≈ pair f g.
  Proof.
    apply (pair_rel_universal hf).
    apply hom_order.
    apply hom_order.
    apply hom_order.
    apply hom_directed.
  Qed.

  Theorem pair_le_commute1 C A B (f:C → A) (g:C → B) :
    pi1 ∘ pair f g ≤ f.
  Proof.
    apply pair_proj_commute1_le.
    apply PLT.hom_order.
    apply PLT.hom_order.
  Qed.

  Theorem pair_le_commute2 C A B (f:C → A) (g:C → B) :
    pi2 ∘ pair f g ≤ g.
  Proof.
    apply pair_proj_commute2_le.
    apply PLT.hom_order.
    apply PLT.hom_order.
  Qed.

  Theorem pair_compose_commute A B C D
    (f:C → A) (g:C → B) (h:D → C) :
    PLT.pair f g ∘ h ≈ PLT.pair (f ∘ h) (g ∘ h).
  Proof.
    split.
    apply pair_universal_le.
    rewrite (cat_assoc _ _ _ _ _ pi1).
    apply compose_mono; auto.
    apply pair_le_commute1.
    rewrite (cat_assoc _ _ _ _ _ pi2).
    apply compose_mono; auto.
     apply pair_le_commute2.
    hnf; simpl; intros.
    destruct a as  [d [a b]].
    rewrite (pair_rel_elem _ _ _ (effective D) (compose_rel (effective C) f h) (compose_rel (effective C) g h) d a b) in H.
    destruct H.
    apply compose_elem.
    apply hom_order.
    apply compose_elem in H.
    2: apply hom_order.
    apply compose_elem in H0.
    2: apply hom_order.
    destruct H as [q1 [??]].
    destruct H0 as [q2 [??]].
    destruct (hom_directed _ _ h d (q1::q2::nil)%list).
    apply elem_inh with q1. apply cons_elem; auto.
    red; simpl; intros. apply erel_image_elem.
    apply cons_elem in H3. destruct H3.
    revert H. apply member_eq.
    split; split; auto.
    apply cons_elem in H3. destruct H3.
    revert H0. apply member_eq.
    split; split; auto.
    apply nil_elem in H3. elim H3.
    destruct H3.
    apply erel_image_elem in H4.
    exists x. split; auto.
    apply pair_rel_elem.
    split.
    revert H1. apply hom_order; auto.
    apply H3. apply cons_elem; auto.
    revert H2. apply hom_order; auto.
    apply H3.
    apply cons_elem; right.
    apply cons_elem; auto.
  Qed.

  Theorem curry_apply A B C (f:(prod C A) → B) :
    app ∘ pair_map (curry f) id ≈ f.
  Proof.
    rewrite pair_map_eq.
    apply curry_apply.
    apply PLT.hom_order.
    apply hom_directed.
    apply plotkin.
  Qed.

  Theorem pair_mono (C A B:ob) (f f':C → A) (g g':C → B) :
    f ≤ f' -> g ≤ g' -> pair f g ≤ pair f' g'.
  Proof.
    repeat intro.
    destruct a as [c [a b]]. simpl in *.
    apply (pair_rel_elem _ _ _ _ f g) in H1.
    apply pair_rel_elem.
    destruct H1; split; auto.
  Qed.

  Theorem pair_eq (C A B:ob) (f f':C → A) (g g':C → B) :
    f ≈ f' -> g ≈ g' -> pair f g ≈ pair f' g'.
  Proof.
    intros. split; apply pair_mono; auto.
  Qed.

  Theorem sum_cases_mono (C A B:ob) (f f':A → C) (g g':B → C) :
    f ≤ f' -> g ≤ g' -> sum_cases f g ≤ sum_cases f' g'.
  Proof.
    repeat intro.
    destruct a as [z c]. simpl in *.
    apply (sum_cases_elem (ord C) (ord A) (ord B) (hom_rel f) (hom_rel g)) in H1.
    apply (sum_cases_elem (ord C) (ord A) (ord B) (hom_rel f') (hom_rel g')).
    destruct z; auto.
  Qed.

  Theorem sum_cases_eq (C A B:ob) (f f':A → C) (g g':B → C) :
    f ≈ f' -> g ≈ g' -> sum_cases f g ≈ sum_cases f' g'.
  Proof.
    intros. split; apply sum_cases_mono; auto.
  Qed.

  Theorem curry_mono (C A B:ob) (f f':prod C A → B) :
    f ≤ f' -> curry f ≤ curry f'.
  Proof.
    repeat intro. destruct a as [c R].
    simpl in H0.
    simpl. apply curry_rel_elem.
    apply PLT.hom_order.
    intros. apply H.
    revert H0 a b H1.
    apply curry_rel_elem.
    apply PLT.hom_order.
  Qed.

  Theorem curry_eq (C A B:ob) (f f':prod C A → B) :
    f ≈ f' -> curry f ≈ curry f'.
  Proof.
    intros; split; apply curry_mono; auto.
  Qed.

  Theorem pair_map_pair C X Y Z W (f1:C → X) (f2:X → Y) (g1:C → Z) (g2:Z → W) :
    pair (f2 ∘ f1) (g2 ∘ g1) ≈ pair_map f2 g2 ∘ pair f1 g1.
  Proof.
    split; hnf; simpl; intros.
    destruct a as [c [y w]].
    apply (pair_rel_elem (ord Y) (ord W) (ord C) (effective C)
         (compose_rel (effective X) f2 f1)
         (compose_rel (effective Z) g2 g1)) in H.
    destruct H.
    apply compose_elem.
    apply pair_rel_ordering; apply hom_order.
    simpl.
    apply compose_elem in H. 2: apply hom_order.
    apply compose_elem in H0. 2: apply hom_order.
    destruct H as [x [??]].
    destruct H0 as [z [??]].
    exists (x,z). split; auto.
    apply pair_rel_elem; split; auto.
    apply pair_rel_elem. split; auto.
    apply compose_elem. apply pi1_rel_ordering.
    exists x; split; auto.
    apply pi1_rel_elem. auto.
    apply compose_elem. apply pi2_rel_ordering.
    exists z. split; auto.
    apply pi2_rel_elem. auto.

    destruct a as [c [y w]].
    apply compose_elem in H; simpl in *.
    2: apply pair_rel_ordering; apply hom_order.
    destruct H as [[x z] [??]].
    apply pair_rel_elem in H.
    apply (pair_rel_elem _ _ _ _
           (compose_rel (effective X) f2
              (pi1_rel (effective X) (effective Z)))
           (compose_rel (effective Z) g2
              (pi2_rel (effective X) (effective Z)))) in H0.
    destruct H0.
    apply compose_elem in H0. 2: apply pi1_rel_ordering.
    apply compose_elem in H1. 2: apply pi2_rel_ordering.
    destruct H0 as [x' [??]].
    destruct H1 as [y' [??]].
    apply pair_rel_elem.
    split.
    apply compose_elem. apply hom_order.
    destruct H.
    exists x. split; auto.
    apply (hom_order _ _ f2) with x' y; auto.
    apply pi1_rel_elem in H0. auto.
    apply compose_elem. apply hom_order.
    destruct H.
    exists z. split; auto.
    apply (hom_order _ _ g2) with y' w; auto.
    apply pi2_rel_elem in H1. auto.
  Qed.

  Theorem curry_apply2 A B C (f:(prod C A) → B) (g:C → A) :
    app ∘ pair (curry f) g ≈ f ∘ pair id g.
  Proof.
    cut (pair (curry f) g ≈ pair_map (curry f) id ∘ pair id g).
    intros. rewrite H.
    rewrite (@cat_assoc PLT).
    rewrite curry_apply. auto.
    rewrite <- pair_map_pair.
    apply pair_eq.
    symmetry. apply cat_ident1.
    symmetry. apply cat_ident2.
  Qed.

  Theorem curry_apply3 A B C D (f:(prod D A) → B) (h:C → D) (g:C → A) :
    app ∘ pair (curry f ∘ h) g ≈ f ∘ pair h g.
  Proof.
    cut (pair (curry f ∘ h) g ≈ pair_map (curry f) id ∘ pair h g).
    intros. rewrite H.
    rewrite (@cat_assoc PLT).
    rewrite curry_apply. auto.
    rewrite <- pair_map_pair.
    apply pair_eq. auto.
    symmetry. apply cat_ident2.
  Qed.

  Theorem curry_universal A B C (f:(prod C A) → B) (CURRY:C → (exp A B)) :
    app ∘ pair_map CURRY id ≈ f -> CURRY ≈ curry f.
  Proof.
    intro. apply (curry_universal hf); auto.
    apply PLT.hom_order.
    apply (hom_directed _ _ f).
    apply plotkin.
    apply (hom_order _ _ CURRY).
    apply (hom_directed _ _ CURRY).
    rewrite pair_map_eq in H. apply H.
  Qed.

  Theorem curry_compose_commute A B C D (f:(prod C A) → B) (h:D → C) :
    curry f ∘ h ≈ curry (f ∘ pair_map h id).
  Proof.
    apply curry_universal.
    unfold pair_map.
    symmetry.
    rewrite <- (curry_apply3).
    apply cat_respects. auto.
    apply pair_eq; auto.
    apply cat_assoc.
  Qed.

  Definition initialized_mixin :=
    Initialized.Mixin ob hom hom_eq_mixin empty initiate initiate_univ.

  Program Definition cocartesian_mixin :=
    Cocartesian.Mixin ob hom hom_eq_mixin comp_mixin sum iota1 iota2 (@sum_cases) _.
  Next Obligation.
    constructor.
    apply iota1_cases_commute.
    apply iota2_cases_commute.
    apply sum_cases_universal.
  Qed.

  Definition cocartesian :=
    Cocartesian ob hom hom_eq_mixin comp_mixin cat_axioms initialized_mixin cocartesian_mixin.

  Lemma compose_hom_rel : forall (A B C:PLT) (f:A → B) (g:B → C) x z,
    (x,z) ∈ PLT.hom_rel (g ∘ f) <->
    exists y, (x,y) ∈ PLT.hom_rel f /\ (y,z) ∈ PLT.hom_rel g.
  Proof.
    simpl; intros.
    split; intros.
    apply compose_elem in H. auto.
    apply PLT.hom_order.
    apply compose_elem. apply PLT.hom_order.
    auto.
  Qed.

  Lemma pair_hom_rel : forall (A B C:PLT) (f:C → A) (g:C → B) c a b ,
    (c,(a,b)) ∈ hom_rel (pair f g) <-> (c,a) ∈ hom_rel f /\ (c,b) ∈ hom_rel g.
  Proof.
    simpl; intros.
    rewrite pair_rel_elem. intuition.
  Qed.

  Lemma sum_cases_hom_rel : forall (A B C:PLT) (f:A → C) (g:B → C) c z,
    (z,c) ∈ hom_rel (sum_cases f g) <->
        match z with
        | inl a => (a,c) ∈ hom_rel f
        | inr b => (b,c) ∈ hom_rel g
        end.
  Proof.
    simpl; intros.
    rewrite (sum_cases_elem _ _ _ (hom_rel f) (hom_rel g) z c). intuition.
  Qed.

  Lemma curry_hom_rel : forall (A B C:PLT) (f:prod C A → B) c R,
    (c,R) ∈ hom_rel (curry f) <->
    (forall a b, (a,b) ∈ proj1_sig R -> ((c,a),b) ∈ hom_rel f).
  Proof.
    intros. simpl.
    rewrite (curry_rel_elem _ _ _ _ _ _ _ _ f (hom_order _ _ f) c R).
    split; auto.
  Qed.

  Lemma app_hom_rel : forall (A B:PLT) R x y,
    ((R,x),y) ∈ hom_rel (@app A B) <->
    exists x' y', (x',y') ∈ proj1_sig R /\ x' ≤ x /\ y ≤ y'.
  Proof.
    intros. simpl.
    rewrite (apply_rel_elem _ _ _ _ _ _ x y R). split; auto.
  Qed.

  Global Opaque compose.
  Global Opaque pair.
  Global Opaque sum_cases.
  Global Opaque curry.
  Global Opaque app.

  Section homset_cpo.
    Variables A B:ob.

    Program Definition hom_rel' : hom_ord A B → erel (ord A) (ord B) :=
      Preord.Hom (hom_ord A B) (erel (ord A) (ord B)) (@hom_rel A B) _.
    Next Obligation. simpl. auto. Qed.

    Program Definition homset_sup (M:cl_eset (directed_hf_cl hf) (hom_ord A B))
      : hom A B := Hom A B (∪(image hom_rel' _)) _ _.
    Next Obligation.
      intros. apply M.
    Defined.
    Next Obligation.
      intros. apply union_axiom in H1. apply union_axiom.
      destruct H1 as [X [??]].
      exists X. split; auto.
      apply image_axiom2 in H1.
      destruct H1 as [Y [??]].
      rewrite H3. simpl.
      apply hom_order with x y; auto.
      rewrite H3 in H2. auto.
    Qed.
    Next Obligation.
      intros. red. intro x.
      apply prove_directed.
      generalize (refl_equal hf).
      pattern hf at 2. case hf; intros.
      pattern hf at 1. rewrite H; auto.
      pattern hf at 1. rewrite H; auto.
      destruct M as [M HM]; simpl in *.
      destruct (HM nil) as [q [??]].
      rewrite H. hnf; auto.
      hnf; intros. apply nil_elem in H0. elim H0.
      destruct (hom_directed A B q x nil) as [z [??]].
      rewrite H. hnf. auto.
      hnf; intros. apply nil_elem in H2. elim H2.
      apply erel_image_elem in H3.
      exists z. apply erel_image_elem.
      apply union_axiom.
      exists (hom_rel q). split; auto.
      apply image_axiom1'; eauto.
      exists q. split; auto.

      intros y1 y2. intros.
      apply erel_image_elem in H.
      apply erel_image_elem in H0.
      apply union_axiom in H.
      apply union_axiom in H0.
      destruct H as [X1 [??]].
      destruct H0 as [X2 [??]].
      apply image_axiom2 in H.
      destruct H as [Y1 [??]].
      apply image_axiom2 in H0.
      destruct H0 as [Y2 [??]].
      destruct M as [M HM]; simpl in *.
      destruct (HM (Y1::Y2::nil)%list) as [Y [??]].
      apply elem_inh with Y1. apply cons_elem; auto.
      hnf; intros.
      apply cons_elem in H5.
      destruct H5. rewrite H5; auto.
      apply cons_elem in H5.
      destruct H5. rewrite H5; auto.
      apply nil_elem in H5. elim H5.
      destruct (hom_directed A B Y x (y1::y2::nil)%list) as [z [??]].
      apply elem_inh with y1; auto. apply cons_elem; auto.
      hnf; intros.
      apply cons_elem in H7. destruct H7.
      rewrite H7. apply erel_image_elem.
      assert (Y1 ≤ Y). apply H5. apply cons_elem. auto.
      apply H8. rewrite <- H3. auto.
      assert (Y2 ≤ Y). apply H5. apply cons_elem. right.
      apply cons_elem. auto.
      apply cons_elem in H7. destruct H7.
      rewrite H7. apply erel_image_elem.
      apply H8. rewrite <- H4. auto.
      apply nil_elem in H7. elim H7.
      apply erel_image_elem in H8.
      exists z.
      split.
      apply H7. apply cons_elem; auto.
      split.
      apply H7. apply cons_elem; right. apply cons_elem; auto.
      apply erel_image_elem.
      apply union_axiom.
      exists (hom_rel Y). split; auto.
      apply image_axiom1'. exists Y; split; auto.
    Qed.

    Program Definition homset_cpo_mixin :
      CPO.mixin_of (directed_hf_cl hf) (hom_ord A B)
      := CPO.Mixin _ _ homset_sup _ _.
    Next Obligation.
      repeat intro; simpl.
      apply union_axiom.
      exists (hom_rel x). split; auto.
      apply image_axiom1'. exists x. split; auto.
    Qed.
    Next Obligation.
      repeat intro.
      simpl in H0.
      apply union_axiom in H0.
      destruct H0 as [Q [??]].
      apply image_axiom2 in H0.
      destruct H0 as [y [??]].
      generalize (H y H0); intros.
      apply H3.
      rewrite H2 in H1. auto.
    Qed.

    Definition homset_cpo : CPO.type (directed_hf_cl hf) :=
      CPO.Pack _ (hom A B) (hom_ord_mixin A B) homset_cpo_mixin.
  End homset_cpo.
End PLT.

Theorem pair_commute1 (C A B:PLT false) (f:C → A) (g:C → B) :
  pi1 false ∘ pair false f g ≈ f.
Proof.
  apply pair_proj_commute1.
  apply PLT.hom_order.
  apply PLT.hom_order.
  apply PLT.hom_directed.
Qed.

Theorem pair_commute2 (C A B:PLT false) (f:C → A) (g:C → B) :
  pi2 false ∘ pair false f g ≈ g.
Proof.
  apply pair_proj_commute2.
  apply PLT.hom_order.
  apply PLT.hom_order.
  apply PLT.hom_directed.
Qed.

Lemma terminate_univ : forall (A:PLT false) (f:A → unit false),
  f ≈ PLT.terminate false A.
Proof.
  intros. split.
  apply PLT.terminate_le_univ.
  hnf; simpl; intros.
  destruct a.
  destruct u.
  destruct (PLT.hom_directed false _ _ f c nil); auto.
  hnf; auto. hnf; intros. apply nil_elem in H0. elim H0.
  destruct H0. apply erel_image_elem in H1. destruct x. auto.
Qed.

Definition terminated_mixin
  := Terminated.Mixin (ob false) (hom false)
       (hom_eq_mixin false)
       (unit false) (terminate false) terminate_univ.

Program Definition cartesian_mixin
  := Cartesian.Mixin (ob false) (hom false)
       (hom_eq_mixin false) (comp_mixin false)
       (prod false) (@pi1 false) (@pi2 false)
       (@pair false) _.
Next Obligation.
  constructor.
  apply pair_commute1.
  apply pair_commute2.
  apply pair_universal.
Qed.

Program Definition cartesian_closed_mixin
  := CartesianClosed.Mixin (ob false) (hom false)
       (hom_eq_mixin false) (comp_mixin false)
       (cat_axioms false)
       terminated_mixin
       cartesian_mixin
       (exp false) (@curry false) (@app false)
       _.
Next Obligation.
  constructor.
  intros.
  generalize (curry_apply false A B C f).
  intros.
  etransitivity. 2: apply H.
  apply cat_respects; auto.
  unfold pair_map.
  apply pair_eq; auto.
  symmetry. apply cat_ident2.
  intros.
  apply curry_universal.
  etransitivity. 2: apply H.
  apply cat_respects; auto.
  unfold pair_map.
  apply pair_eq; auto.
  apply cat_ident2.
Qed.

Definition terminated :=
  Terminated (ob false) (hom false)
       (hom_eq_mixin false) (comp_mixin false)
       (cat_axioms false)
       terminated_mixin.
Definition cartesian :=
  Cartesian (ob false) (hom false)
       (hom_eq_mixin false) (comp_mixin false)
       (cat_axioms false)
       terminated_mixin
       cartesian_mixin.
Definition cartesian_closed :=
  CartesianClosed (ob false) (hom false)
       (hom_eq_mixin false) (comp_mixin false)
       (cat_axioms false)
       cartesian_mixin
       terminated_mixin
       cartesian_closed_mixin.

End PLT.

Canonical Structure PLT.PLT.
Canonical Structure PLT.ord.
Canonical Structure PLT.dec.
Canonical Structure PLT.hom_ord.
Canonical Structure PLT.hom_eq.
Canonical Structure PLT.comp.
Canonical Structure PLT.homset_cpo.
Canonical Structure PLT.cocartesian.
Canonical Structure PLT.terminated.
Canonical Structure PLT.cartesian.
Canonical Structure PLT.cartesian_closed.

Arguments PLT.hom [hf] A B.
Arguments PLT.hom_rel [hf] [A] [B] h n.
Arguments PLT.effective [hf] X.
Arguments PLT.plotkin [hf] X.
Arguments PLT.ord [hf] X.
Arguments PLT.dec [hf] X.
Arguments PLT.pi1 [hf] [A] [B].
Arguments PLT.pi2 [hf] [A] [B].
Arguments PLT.pair [hf] [C] [A] [B] f g.
Arguments PLT.iota1 [hf] [A] [B].
Arguments PLT.iota2 [hf] [A] [B].
Arguments PLT.sum_cases [hf] [C] [A] [B] f g.
Arguments PLT.prod [hf] A B.
Arguments PLT.sum [hf] A B.
Arguments PLT.exp [hf] A B.
Arguments PLT.app [hf A B].
Arguments PLT.curry [hf C A B] f.
Arguments PLT.pair_map [hf] [A B C D] f g.

Coercion PLT.ord : PLT.ob >-> preord.
Coercion PLT.carrier : PLT.ob >-> Sortclass.

Global Close Scope category_ops_scope.

Notation PLT := (PLT.PLT false).
Notation "'∂PLT'" := (PLT.PLT true).

Notation "0" := (PLT.empty _) : plt_scope.
Notation "1" := (PLT.unit _) : plt_scope.
Notation "'Λ' f" := (PLT.curry f) : plt_scope.
Notation apply := (@PLT.app _ _ _).

Notation "〈 f , g 〉" := (@PLT.pair false _ _ _ (f)%plt (g)%plt) : plt_scope.
Notation "A × B" := (@PLT.prod false (A)%plt (B)%plt) : plt_scope.
Notation "A ⇒ B" := (@PLT.exp false (A)%plt (B)%plt) : plt_scope.
Notation "A + B" := (@PLT.sum false (A)%plt (B)%plt) : plt_scope.

Notation "《 f , g 》" := (@PLT.pair true _ _ _ (f)%plt (g)%plt) : plt_scope.
Notation "A ⊗ B" := (@PLT.prod true (A)%plt (B)%plt) : plt_scope.
Notation "A ⊸ B" := (@PLT.exp true (A)%plt (B)%plt) : plt_scope.
Notation "A ⊕ B" := (@PLT.sum true (A)%plt (B)%plt) : plt_scope.

Notation "'π₁'"  := (@PLT.pi1 _ _ _) : plt_scope.
Notation "'π₂'"  := (@PLT.pi2 _ _ _) : plt_scope.
Notation "'ι₁'"  := (@PLT.iota1 _ _ _) : plt_scope.
Notation "'ι₂'"  := (@PLT.iota2 _ _ _) : plt_scope.

Add Parametric Morphism (hf:bool) (C A B:PLT.ob hf) :
    (@PLT.pair hf C A B)
    with signature (Preord.ord_op (PLT.hom_ord hf C A)) ==>
                   (Preord.ord_op (PLT.hom_ord hf C B)) ==>
                   (Preord.ord_op (PLT.hom_ord hf C (PLT.prod A B)))
     as plt_le_pair_morphism.
Proof.
  intros. apply PLT.pair_mono; auto.
Qed.

Add Parametric Morphism (hf:bool) (C A B:PLT.ob hf) :
    (@PLT.sum_cases hf C A B)
    with signature (Preord.ord_op (PLT.hom_ord hf A C)) ==>
                   (Preord.ord_op (PLT.hom_ord hf B C)) ==>
                   (Preord.ord_op (PLT.hom_ord hf (PLT.sum A B) C))
     as plt_le_cases_morphism.
Proof.
  repeat intro.
  destruct a as [z c].
  simpl in *.
  apply (sum_cases_elem C A B (PLT.hom_rel x) (PLT.hom_rel x0)) in H1.
  apply (sum_cases_elem C A B (PLT.hom_rel y) (PLT.hom_rel y0)).
  destruct z; auto.
Qed.

Add Parametric Morphism (hf:bool) (C A B:PLT.ob hf) :
    (@PLT.pair hf C A B)
    with signature (eq_op (PLT.hom_eq hf C A)) ==>
                   (eq_op (PLT.hom_eq hf C B)) ==>
                   (eq_op (PLT.hom_eq hf C (PLT.prod A B)))
     as plt_pair_morphism.
Proof.
  intros. apply PLT.pair_eq; auto.
Qed.

Add Parametric Morphism (hf:bool) (C A B:PLT.ob hf) :
    (@PLT.sum_cases hf C A B)
    with signature (eq_op (PLT.hom_eq hf A C)) ==>
                   (eq_op (PLT.hom_eq hf B C)) ==>
                   (eq_op (PLT.hom_eq hf (PLT.sum A B) C))
     as plt_cases_morphism.
Proof.
  intros. split; apply plt_le_cases_morphism; auto.
Qed.

Add Parametric Morphism (hf:bool) (C A B:PLT.ob hf) :
    (@PLT.curry hf C A B)
    with signature (Preord.ord_op (PLT.hom_ord hf (PLT.prod C A) B)) ==>
                   (Preord.ord_op (PLT.hom_ord hf C (PLT.exp A B)))
     as plt_le_curry_morphism.
Proof.
  intros. apply PLT.curry_mono; auto.
Qed.

Add Parametric Morphism (hf:bool) (C A B:PLT.ob hf) :
    (@PLT.curry hf C A B)
    with signature (eq_op (PLT.hom_eq hf (PLT.prod C A) B)) ==>
                   (eq_op (PLT.hom_eq hf C (PLT.exp A B)))
     as plt_curry_morphism.
Proof.
  intros. apply PLT.curry_eq; auto.
Qed.

Lemma plt_hom_directed2 hf (A B:PLT.PLT hf) (f:A → B) a x y :
  (a,x) ∈ PLT.hom_rel f ->
  (a,y) ∈ PLT.hom_rel f ->
  exists z, (a,z) ∈ PLT.hom_rel f /\ x ≤ z /\ y ≤ z.
Proof.
  intros.
  destruct (PLT.hom_directed hf A B f a (x::y::nil)%list) as [z [??]].
  destruct hf; simpl; auto.
  exists x. apply cons_elem; auto.
  red; intros.
  apply erel_image_elem.
  apply cons_elem in H1. destruct H1.
  apply PLT.hom_order with a x; auto.
  apply cons_elem in H1. destruct H1.
  apply PLT.hom_order with a y; auto.
  apply nil_elem in H1. elim H1.
  apply erel_image_elem in H2.
  exists z. split; auto.
  split.
  apply H1. apply cons_elem; auto.
  apply H1. apply cons_elem. right. apply cons_elem; auto.
Qed.

Lemma hom_rel_pair_map hf (A B C D:PLT.PLT hf) (f:A → C) (g:B → D) x y x' y' :
  (x,y,(x',y')) ∈ PLT.hom_rel (PLT.pair_map f g) <->
  ((x,x') ∈ PLT.hom_rel f /\ (y,y') ∈ PLT.hom_rel g).
Proof.
  unfold PLT.pair_map.
  split; intros.
  rewrite (PLT.pair_hom_rel _ _ _ _ (f∘π₁) (g∘π₂) (x,y) x' y') in H.
  destruct H.
  apply PLT.compose_hom_rel in H.
  destruct H as [?[??]].
  apply PLT.compose_hom_rel in H0.
  destruct H0 as [?[??]].
  simpl in H.
  rewrite (pi1_rel_elem _ _ _ _ x y x0)  in H.
  simpl in H0.
  rewrite (pi2_rel_elem _ _ _ _ x y x1) in H0.
  split.
  revert H1. apply PLT.hom_order; auto.
  revert H2. apply PLT.hom_order; auto.
  rewrite (PLT.pair_hom_rel _ _ _ _ (f∘π₁) (g∘π₂)).
  destruct H.
  split.
  apply PLT.compose_hom_rel.
  exists x. split; auto. simpl. apply pi1_rel_elem; auto.
  apply PLT.compose_hom_rel.
  exists y. split; auto. simpl. apply pi2_rel_elem; auto.
Qed.

Lemma terminate_le_cancel (hf:bool) (A B:PLT.PLT hf) (f g:1 → B) (a:A) :
  f ∘ PLT.terminate hf A ≤ g ∘ PLT.terminate hf A ->
  f ≤ g.
Proof.
  repeat intro.
  destruct a0. destruct c.
  assert ((a,c0) ∈ PLT.hom_rel (f ∘ PLT.terminate hf A)).
  apply PLT.compose_hom_rel. exists tt. split; auto.
  apply eprod_elem. split; apply eff_complete.
  apply H in H1.
  apply PLT.compose_hom_rel in H1.
  destruct H1 as [[] [??]]. auto.
Qed.

Lemma terminate_cancel (hf:bool) (A B:PLT.PLT hf) (f g:1 → B) (a:A) :
  f ∘ PLT.terminate hf A ≈ g ∘ PLT.terminate hf A ->
  f ≈ g.
Proof.
  intros. destruct H; split; eapply terminate_le_cancel; eauto.
Qed.

Section plt_const.
  Variable hf:bool.
  Variables A B:PLT.PLT hf.
  Variable b:B.

  Definition plt_const_rel :=
    eprod (eff_enum A (PLT.effective A))
                       (esubset_dec B (fun x => x ≤ b)
                          (fun x => eff_ord_dec B (PLT.effective B) x b)
                          (eff_enum B (PLT.effective B))).

  Lemma plt_const_rel_elem : forall a b',
    (a,b') ∈ plt_const_rel <-> b' ≤ b.
  Proof.
    repeat intro. unfold plt_const_rel. split; intro.
    apply eprod_elem in H. destruct H.
    apply esubset_dec_elem in H0. destruct H0; auto.
    intros. rewrite <- H2; auto.
    apply eprod_elem. split.
    apply eff_complete.
    apply esubset_dec_elem.
    intros. rewrite <- H0. auto.
    split; auto.
    apply eff_complete.
  Qed.

  Program Definition plt_const :=
    PLT.Hom hf A B plt_const_rel _ _.
  Next Obligation.
    intros.
    apply plt_const_rel_elem in H1.
    apply plt_const_rel_elem.
    eauto.
  Qed.
  Next Obligation.
    repeat intro.
    exists b; split; repeat intro.
    apply H in H0.
    apply erel_image_elem in H0.
    apply plt_const_rel_elem in H0. auto.
    apply erel_image_elem.
    apply plt_const_rel_elem. auto.
  Qed.
End plt_const.

Theorem pair_bottom1 (C A B:ob ∂PLT) (f:C → A) :
  《 f, ⊥ : C → B 》 ≈ ⊥.
Proof.
  split. hnf; simpl; intros.
  destruct a as [c [a b]].
  apply (PLT.pair_hom_rel _ A B C) in H.
  destruct H.
  simpl in H0.
  apply union_axiom in H0.
  destruct H0 as [q [??]].
  apply image_axiom2 in H0.
  destruct H0 as [?[??]].
  apply empty_elem in H0. elim H0.
  apply bottom_least.
Qed.

Theorem pair_bottom2 (C A B:ob ∂PLT) (g:C → B) :
  《 ⊥ : C → A,  g 》 ≈ ⊥.
Proof.
  split. hnf; simpl; intros.
  destruct a as [c [a b]].
  apply (PLT.pair_hom_rel _ A B C) in H.
  destruct H. simpl in H.
  apply union_axiom in H.
  destruct H as [q [??]].
  apply image_axiom2 in H.
  destruct H as [?[??]].
  apply empty_elem in H. elim H.
  apply bottom_least.
Qed.

Theorem pi1_greatest (A B:ob ∂PLT) (proj:A⊗B → A) :
  (forall C (f:C → A) (g:C → B), proj ∘ 《f, g》 ≤ f) ->
  proj ≤ π₁.
Proof.
  repeat intro.
  destruct a as [[a b] a']. simpl in *.
  apply pi1_rel_elem.
  apply (plt_const_rel_elem true B A a b a').
  apply (H B (plt_const _ _ _ a) (id) (b,a')).
  apply PLT.compose_hom_rel.
  exists (a,b).
  split; auto.
  simpl.
  apply PLT.pair_hom_rel.
  split; auto.
  apply plt_const_rel_elem. auto.
  apply ident_elem. auto.
Qed.

Theorem pi2_greatest (A B:ob ∂PLT) (proj:A⊗B → B) :
  (forall C (f:C → A) (g:C → B), proj ∘ 《f, g》 ≤ g) ->
  proj ≤ π₂.
Proof.
  repeat intro.
  destruct a as [[a b] b']. simpl in *.
  apply pi2_rel_elem.
  apply (plt_const_rel_elem true A B b a b').
  apply (H A (id) (plt_const _ _ _ b) (a,b')).
  apply PLT.compose_hom_rel.
  exists (a,b).
  split; auto.
  simpl.
  apply PLT.pair_hom_rel.
  split; auto.
  apply ident_elem. auto.
  apply plt_const_rel_elem. auto.
Qed.

Definition antistrict (A B:∂PLT) (f:A → B) :=
  forall a, exists b, (a,b) ∈ PLT.hom_rel f.
Arguments antistrict [A B] f.

Definition nonbottom (A B:∂PLT) (f:A → B) :=
  exists x, x ∈ PLT.hom_rel f.
Arguments nonbottom [A B] f.

Lemma antistrict_nonbottom (A B:∂PLT) (f:A → B) :
  antistrict f <-> (forall C (g:C → A), nonbottom g -> nonbottom (f ∘ g)).
Proof.
  split; intros.
  destruct H0 as [[??] ?].
  destruct (H c0) as [q ?].
  exists (c,q). apply PLT.compose_hom_rel. eauto.
  red; intros.
  destruct (H (PLT.unit true) (plt_const true _ _ a)).
  exists (tt,a). simpl. apply plt_const_rel_elem. auto.
  destruct x as [??].
  apply PLT.compose_hom_rel in H0.
  destruct H0 as [q [??]].
  simpl in *. apply plt_const_rel_elem in H0.
  exists c0. eapply PLT.hom_order; eauto.
Qed.

Theorem antistrict_pair_commute1 (C B:∂PLT) (g:C → B) :
  antistrict g <-> forall A (f:C → A), π₁ ∘ 《f,g》 ≈ f.
Proof.
  intros.
  split; repeat intro.
  split. apply PLT.pair_le_commute1.
  hnf; intros.
  apply PLT.compose_hom_rel. simpl.
  destruct a as [c a].
  destruct (H c) as [b ?].
  exists (a,b).
  split.
  apply PLT.pair_hom_rel. split; auto.
  apply pi1_rel_elem. auto.

  rename a into c.
  destruct (H C id).
  assert ((c,c) ∈ PLT.hom_rel (PLT.pi1 ∘ PLT.pair id g)).
  apply H1. simpl. apply ident_elem. auto.
  apply PLT.compose_hom_rel in H2.
  destruct H2 as [q [??]].
  destruct q.
  simpl in H2.
  rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c c0 c1) in H2. destruct H2.
  simpl in H2.
  apply ident_elem in H2.
  exists c1; auto.
Qed.

Theorem antistrict_pair_commute2 (C A:∂PLT) (f:C → A) :
  antistrict f <-> forall B (g:C → B), π₂ ∘ 《f, g》 ≈ g.
Proof.
  split; intros.
  split. apply PLT.pair_le_commute2.
  hnf; intros.
  apply PLT.compose_hom_rel. simpl.
  destruct a as [c b].
  destruct (H c) as [a ?].
  exists (a,b).
  split.
  apply pair_rel_elem. split; auto.
  apply pi2_rel_elem. auto.

  intro c. destruct (H C id).
  assert ((c,c) ∈ PLT.hom_rel (π₂ ∘ PLT.pair f id)).
  apply H1. simpl. apply ident_elem. auto.
  apply PLT.compose_hom_rel in H2.
  destruct H2 as [q [??]].
  destruct q.
  simpl in H2.
  rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c c0 c1) in H2. destruct H2.
  simpl in H4. apply ident_elem in H4.
  exists c0; auto.
Qed.


Require Import Coqlib.
Require Import MachineInt.
Require Import Repeat.

Require Import AbstractRegister.
Require Import AbstractMemory.
Require Import MemoryR.
Require Import Instructions.

(**
- C	....	Retenue (Carry) ) posé si le complément à deux du résultat après une instruction ADC ou SBC est inférieur à -128 ou supérieur à 127
- Z	....	Zero
- I	....	Interruptions non autorisées si le drapeau est posé
- D	....	Mode décimal codé binaire
- B	....	Break
- V	....	Débordement (Overflow)
- N	....	Nombre négatif (Signe)
*)

Inductive Flag : Set :=
  | C : Flag
  | Zero : Flag
  | I : Flag
  | D : Flag
  | B : Flag
  | V : Flag
  | Si : Flag.

Record Status : Set :=
  mkState {
  CF : bool;
  ZF : bool;
  InF : bool;
  DF : bool;
  BF : bool;
  VF : bool;
  SF : bool
}.

Definition setFlag (S: Status) (f: Flag): Status :=
  match f with
  | Si => mkState S.(CF) S.(ZF) S.(InF) S.(DF) S.(BF) S.(VF) true
  | V => mkState S.(CF) S.(ZF) S.(InF) S.(DF) S.(BF) true S.(SF)
  | B => mkState S.(CF) S.(ZF) S.(InF) S.(DF) true S.(VF) S.(SF)
  | D => mkState S.(CF) S.(ZF) S.(InF) true S.(BF) S.(VF) S.(SF)
  | I => mkState S.(CF) S.(ZF) true S.(DF) S.(BF) S.(VF) S.(SF)
  | Zero => mkState S.(CF) true S.(InF) S.(DF) S.(BF) S.(VF) S.(SF)
  | C => mkState true S.(ZF) S.(InF) S.(DF) S.(BF) S.(VF) S.(SF)
  end.

Definition clearFlag (S: Status) (f: Flag): Status :=
  match f with
  | Si => mkState S.(CF) S.(ZF) S.(InF) S.(DF) S.(BF) S.(VF) false
  | V => mkState S.(CF) S.(ZF) S.(InF) S.(DF) S.(BF) false S.(SF)
  | B => mkState S.(CF) S.(ZF) S.(InF) S.(DF) false S.(VF) S.(SF)
  | D => mkState S.(CF) S.(ZF) S.(InF) false S.(BF) S.(VF) S.(SF)
  | I => mkState S.(CF) S.(ZF) false S.(DF) S.(BF) S.(VF) S.(SF)
  | Zero => mkState S.(CF) false S.(InF) S.(DF) S.(BF) S.(VF) S.(SF)
  | C => mkState false S.(ZF) S.(InF) S.(DF) S.(BF) S.(VF) S.(SF)
  end.

(**
L'état d'une machine se compose :
- des registres de calcul A (accumulateur), X et Y sur 8 bits,
- d'une mémoire avec un bus d'adresse sur 16 bits,
- d'un compteur ordinal sur 16 bits,
- et d'un registre de status contenant les différents drapeaux.
*)

Definition State := (AbstractRegister.RegF * AbstractMemory.Mem * word * Status)%type.

Definition R (S : State) :=
  match S with
    | (r, _, _, _) => r
  end.

Definition M (S : State) :=
  match S with
    | (_, m, _, _) => m
  end.

Definition PC (S : State) :=
  match S with
    | (_, _, pc, _) => pc
  end.

Definition ST (S : State) :=
  match S with
    | (_, _, _, st) => st
  end.

Definition nextinstr (S: State) : State :=
(R S, M S, (Word.repr (Word.intval (PC S) + 1)), ST S).

(**
Si l'instruction a été exécutée correctement, le constructeur Next contient
le nouvel état de la machine.
Sinon, la machine se trouve bloquée.
*)

Inductive outcome: Type :=
  | Next: State -> outcome
  | Stuck: outcome.

(** On définit ici les fonctions implémentant le comportement des instructions.
*)

Definition exec_jmp_abs (S: State) (w: word) :=
Next (R S, M S, w, ST S).

Definition exec_jmp_indirect (S: State) (a:nat) :=
  match MemoryR.Load.load8 (M S) (a+1) with
  | MemoryR.Safe v1 =>   match MemoryR.Load.load8 (M S) (a+2) with
                        | MemoryR.Safe v2 => Next (R S, M S, (Word.repr (Byte.intval (Byte.or v1 v2))), ST S)
                        | _ => Stuck
                        end
  | _ => Stuck
  end.

Definition exec_load (a: nat) (dest: AbstractRegister.Reg8) (S: State) :=
  match MemoryR.Load.load8 (M S) a with
  | MemoryR.Safe v => Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) dest v, M S, PC S, ST S))
  | _ => Stuck
  end.

Definition exec_store (a: nat) (S: State) (source: AbstractRegister.Reg8) :=
  match MemoryR.Store.store8 (M S) a (AbstractRegister.GetRegisterValue.getReg8 (R S) source) with
  | Some m' => Next (nextinstr (R S, m', PC S, ST S))
  | None => Stuck
  end.

Definition exec_load_imm (b: byte) (S : State) (r : AbstractRegister.Reg8) :=
 Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) r b, M S, PC S, ST S)).

Definition exec_adc_mr (a: nat) (S : State) :=
  match MemoryR.Load.load8 (M S) a with
  | MemoryR.Safe v => let res := Byte.add (v) (AbstractRegister.GetRegisterValue.getReg8 (R S) A) in
                      Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) A res, M S, PC S, ST S))
  | _ => Stuck
  end.

Definition exec_adc_imm (b: byte) (S : State) :=
    let res := Byte.add (b) (AbstractRegister.GetRegisterValue.getReg8 (R S) A) in match (ST S).(CF) with
    | true => Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) A (Byte.add res Byte.one), M S, PC S, ST S))
    | false => Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) A res, M S, PC S, ST S))
    end.

Definition exec_sbc_mr (a: nat) (S : State) :=
  match MemoryR.Load.load8 (M S) a with
  | MemoryR.Safe v => let res := Byte.sub (AbstractRegister.GetRegisterValue.getReg8 (R S) A) (v) in
                      Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) A res, M S, PC S, ST S))
  | _ => Stuck
  end.

Definition exec_sbc_imm (b: byte) (S : State) :=
    let res := Byte.sub (AbstractRegister.GetRegisterValue.getReg8 (R S) A) (b) in match (ST S).(CF) with
    | true => Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) A (Byte.sub res Byte.one), M S, PC S, ST S))
    | false => Next (nextinstr (AbstractRegister.SetRegister.setReg8 (R S) A res, M S, PC S, ST S))
    end.

Definition exec_instr (i: Instr) (S: State) :=
  match i with
    LDA_ir b => exec_load_imm b S A
  | LDX_ir b => exec_load_imm b S X
  | LDY_ir b => exec_load_imm b S Y
  | LDA_mr l => exec_load l A S
  | LDX_mr l => exec_load l X S
  | LDY_mr l => exec_load l Y S
  | STA_rm l => exec_store l S A
  | STX_rm l => exec_store l S X
  | STY_rm l => exec_store l S Y
  | ADC_ir b => exec_adc_imm b S
  | SBC_ir b => exec_sbc_imm b S
  | ADC_mr l => exec_adc_mr l S
  | SBC_mr l => exec_sbc_mr l S
  | JMP_abs w => exec_jmp_abs S w
  | JMP_ind w => exec_jmp_indirect S w
  | _ => Next (S)
end.

(** Fonctions d'exécution des programmes. *)

Fixpoint find_instr (pos: Z) (code: list Instr) : option Instr :=
  match code with
  | nil => None
  | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il
  end.

Fixpoint step (S1 : State) (p: list Instr) : option State :=
      match find_instr (Word.intval (PC S1)) p with
        Some i => match exec_instr i S1 with
                    Next S2 => Some S2
                    |Stuck => None
                    end
        | None => None
        end.

Fixpoint run (S1 : State) (p: list Instr) (n : nat) : option State :=
  match n with
  | 0%nat => Some S1
  | S n' => match step S1 p with
              | Some S2 => run S2 p n'
              | None => None
              end
  end.

(** Les états initiaux des différents éléments de la machine.
Bien sur, dans une machine réelle, ces états sont indéterminés et peuvent contenir
n'importe quoi.
*)

Definition StartR := AbstractRegister.mkState (Byte.repr 0) (Byte.repr 0) (Byte.repr 0).

Definition StartM := repeat (Byte.repr 0) 4096.

Definition StartPC := Word.repr 0.

Definition StartST := mkState false false false false false false false.

Definition StartP := (StartR, StartM, StartPC, StartST).


(**********************************************************************)
(* 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                        L-Calculus                                  *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        L_Combinators.v                             *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.

(* combinators to represent lambda-calculus with tuples *)

Inductive operator : Set :=
Un | Pr | Zero | Next | Pred | Plus | Discriminate | Var | Rase | Lam.

Inductive combinator:  Set :=
| Op : operator -> combinator
| Ap : combinator -> combinator -> combinator .

Lemma decidable_combinator_equality : forall (M N: combinator), M = N \/ M<> N.
Proof.
  induction M; induction N; intros; try (left; congruence); try(right; congruence).
  (* 2 *)
  assert(o = o0 \/ o <> o0).  case o; case o0; try (right; discriminate); try (left;auto).
  inversion H. subst; left; auto. right; intro; invsub.
  (* 1 *)
   elim(IHM1 N1); elim(IHM2 N2); auto; (right; congruence; fail) || left; congruence.
Qed.


(*
  Reduction from:
    Krivine machine halting for closed terms (KrivineMclosed_HALT)
  to:
    Halting problem for a fixed, universal, single-tape, binary Turing machine (HaltUTM)
*)

From Undecidability Require Import TM.UTM TM.TM LambdaCalculus.Krivine MinskyMachines.MMA
  Shared.Libs.PSL.FiniteTypes.FinTypesDef.

From Undecidability Require
  MinskyMachines.Reductions.KrivineMclosed_HALT_to_MMA_HALTING
  TM.Reductions.MMA_HALTING_n_to_HaltTM_n
  TM.Reductions.mTM_to_TM
  TM.Reductions.Arbitrary_to_Binary
  Shared.Libs.DLW.Vec.vec
  LambdaCalculus.Util.Krivine_facts.

Module KM_MMA := KrivineMclosed_HALT_to_MMA_HALTING.Argument.
Module MMA_TM := MMA_HALTING_n_to_HaltTM_n.Argument.
Module MTM_TM := mTM_to_TM.
Module TM_BTM := Arbitrary_to_Binary.

From Coq Require Import Vector ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Lemma TM_BTM_iff {sig} {M : TM sig 1} {ts : Vector.t (tape sig) 1} :
  HaltsTM M ts <->
  HaltsTM (TM_BTM.M' M) (cons _ (hd (TM_BTM.ts' ts)) 0 (nil _)).
Proof.
  have -> (A) (v : Vector.t A 1) : cons _ (hd v) 0 (nil _) = v
    by rewrite (vec.vec_head_tail v) (vec.vec_0_nil (vec.vec_tail v)).
  by apply: TM_BTM.HaltTM_Σ_to_HaltTM_bool_correct.
Qed.

Lemma MTM_TM_iff {sig n} {M : TM sig n} {ts : Vector.t (tape sig) n} :
  HaltsTM M ts <->
  HaltsTM (MTM_TM.M' M) (MTM_TM.ts' ts).
Proof. by apply: MTM_TM.MTM_to_stM_correct. Qed.

Lemma MMA_TM_iff {n MM} {cs : Vector.t nat n}  :
  @MMA_HALTING n (MM, cs) <->
  HaltsTM (MMA_TM.P MM) (MMA_TM.encode_counters cs).
Proof.
  split.
  - by apply: MMA_TM.simulation.
  - by move=> [p'] [ts] /MMA_TM.inverse_simulation.
Qed.

Lemma KM_MMA_iff {tm} : (forall sigma, wCBN.subst sigma tm = tm) ->
  KrivineM_HALT tm <->
  @MMA_HALTING 5 (KM_MMA.PROG 1, KM_MMA.input tm).
Proof.
  move=> /Krivine_facts.eclosed_closed ?. split.
  - by apply: KM_MMA.simulation.
  - by apply: (KM_MMA.inverse_simulation List.nil List.nil).
Qed.

#[local] Opaque TM_BTM.ts' MMA_TM.encode_counters.

Require Import Undecidability.Synthetic.Definitions.

Lemma reduction : KrivineMclosed_HALT ⪯ HaltUTM.
Proof.
  unshelve eexists.
  { intros [tm _].
    assert (cs := KM_MMA.input tm).
    assert (ts := MMA_TM.encode_counters cs).
    assert (t := MTM_TM.ts' ts).
    assert (t' := TM_BTM.ts' t).
    exact (Vector.hd t'). }
  move=> [tm Htm].
  apply: (iff_trans (KM_MMA_iff Htm)).
  apply: (iff_trans MMA_TM_iff).
  apply: (iff_trans MTM_TM_iff).
  by apply: TM_BTM_iff.
Qed.


From Perennial.goose_lang Require Import notation typing.
From Perennial.goose_lang.lib Require Import map.impl.

Reserved Notation "![ t ] e"
         (at level 9, right associativity, format "![ t ]  e").
Reserved Notation "e1 <-[ t ] e2"
         (at level 80, format "e1  <-[ t ]  e2").

Section goose_lang.
  Context {ext} {ext_ty: ext_types ext}.

  (** allocation with a type annotation *)
  Definition ref_to (t:ty): val := λ: "v", ref (Var "v").
  Definition ref_zero (t:ty): val := λ: <>, ref (zero_val t).

  Fixpoint load_ty t: val :=
    match t with
    | prodT t1 t2 => λ: "l", (load_ty t1 (Var "l"), load_ty t2 (Var "l" +ₗ[t1] #1))
    | baseT unitBT => λ: <>, #()
    | _ => λ: "l", !(Var "l")
    end.

  Fixpoint store_ty t: val :=
    match t with
    | prodT t1 t2 => λ: "pv",
                    let: "p" := Fst (Var "pv") in
                    let: "v" := Snd (Var "pv") in
                    store_ty t1 (Var "p", Fst (Var "v"));;
                    store_ty t2 (Var "p" +ₗ[t1] #1, Snd (Var "v"))
    | baseT unitBT => λ: <>, #()
    | _ => λ: "pv", Fst (Var "pv") <- Snd (Var "pv")
    end.

  Fixpoint store_ty' t: val :=
    match t with
    | prodT t1 t2 => λ: "p" "v",
                    store_ty' t1 (Var "p") (Fst (Var "v"));;
                    store_ty' t2 (Var "p" +ₗ[t1] #1) (Snd (Var "v"))
    | baseT unitBT => λ: <> <>, #()
    | _ => λ: "p" "v", Var "p" <- Var "v"
    end.

  (* approximate types for closed values, as obligatons for using load_ty and
  store_ty *)

  Inductive lit_ty : base_lit -> ty -> Prop :=
  | int_ty x : lit_ty (LitInt x) uint64T
  | int32_ty x : lit_ty (LitInt32 x) uint32T
  | int8_ty x : lit_ty (LitByte x) byteT
  | bool_ty x : lit_ty (LitBool x) boolT
  | string_ty x : lit_ty (LitString x) stringT
  | unit_ty : lit_ty LitUnit unitT
  | loc_array_ty x t : lit_ty (LitLoc x) (arrayT t)
  | loc_struct_ty x ts : lit_ty (LitLoc x) (structRefT ts)
  | loc_ptr_ty x : lit_ty (LitLoc x) ptrT
  | proph_ty p : lit_ty (LitProphecy p) prophT
  .

  Inductive val_ty : val -> ty -> Prop :=
  | base_ty l t : lit_ty l t -> val_ty (LitV l) t
  | val_ty_pair v1 t1 v2 t2 : val_ty v1 t1 ->
                              val_ty v2 t2 ->
                              val_ty (PairV v1 v2) (prodT t1 t2)
  | nil_ty t : val_ty (InjLV (LitV LitUnit)) (listT t)
  | sum_ty_l v1 t1 t2 : val_ty v1 t1 ->
                        val_ty (InjLV v1) (sumT t1 t2)
  | sum_ty_r v2 t1 t2 : val_ty v2 t2 ->
                        val_ty (InjRV v2) (sumT t1 t2)
  | map_def_ty v t : val_ty v t ->
                     val_ty (MapNilV v) (mapValT t)
  | map_cons_ty k v mv' t : val_ty mv' (mapValT t) ->
                            val_ty k uint64T ->
                            val_ty v t ->
                            val_ty (InjRV (k, v, mv')%V) (mapValT t)
  | rec_ty f x e t1 t2 : val_ty (RecV f x e) (arrowT t1 t2)
  | ext_val_ty x T : val_ty (ExtV x) (extT T)
  .

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

  (* Prove that this is a sensible definition *)

  Theorem zero_val_ty' t : has_zero t -> val_ty (zero_val t) t.
  Proof.
    induction t; simpl; intros; intuition eauto using val_ty, lit_ty.
    destruct t; eauto using val_ty, lit_ty.
  Qed.

  Theorem val_ty_len {v t} :
    val_ty v t ->
    length (flatten_struct v) = Z.to_nat (ty_size t).
  Proof.
    induction 1; simpl; rewrite -> ?app_length in *; auto.
    - invc H; eauto.
    - pose proof (ty_size_ge_0 t1).
      pose proof (ty_size_ge_0 t2).
      lia.
  Qed.

  Theorem val_ty_flatten_length v t :
    val_ty v t ->
    length (flatten_struct v) = length (flatten_ty t).
  Proof.
    induction 1; simpl; auto.
    - invc H; eauto.
    - rewrite ?app_length.
      lia.
  Qed.

  Ltac inv_lit_ty :=
    try match goal with
        | [ H: lit_ty _ _ |- _ ] => solve [ inversion H ]
        end.

  Theorem flatten_struct_inj v1 v2 t :
    val_ty v1 t ->
    val_ty v2 t ->
    flatten_struct v1 = flatten_struct v2 ->
    v1 = v2.
  Proof.
    intros H.
    revert v2.
    induction H; simpl; intros.
    - inversion H0; subst; simpl in H1;
        try solve [ inversion H ];
        try (destruct l, l0; inversion H1; subst);
        auto.
    - invc H1; simpl in *; inv_lit_ty.
      pose proof (val_ty_len H6).
      pose proof (val_ty_len H).
      unshelve epose proof (app_inj_1 _ _ _ _ _ H2); first by congruence.
      intuition eauto.
      eapply IHval_ty1 in H5; eauto; subst.
      eapply IHval_ty2 in H8; eauto; subst.
      congruence.
    - invc H; simpl in *; inv_lit_ty; try congruence.
    - invc H0; simpl in *; inv_lit_ty; try congruence.
    - invc H0; simpl in *; inv_lit_ty; try congruence.
    - invc H0; simpl in *; inv_lit_ty; try congruence.
    - invc H0; simpl in *; inv_lit_ty; try congruence.
      invc H4.
      invc H2; simpl in *; inv_lit_ty; try congruence.
    - invc H; simpl in *; inv_lit_ty; try congruence.
    - invc H; simpl in *; inv_lit_ty; try congruence.
  Qed.

End goose_lang.

#[global]
Hint Resolve zero_val_ty' : core.
(* give has_zero a chance to simplify, then eauto can keep going *)
#[global]
Hint Extern 50 (has_zero _) => progress simpl : core.
(* Only use constructors as fallback *)
#[global]
Hint Extern 10 (val_ty _ _) => constructor : core.
#[global]
Hint Extern 10 (lit_ty _ _) => constructor : core.
(* Just a compat alias *)
Ltac val_ty :=
  lazymatch goal with
  | |- val_ty _ _ => by eauto 20
  | |- lit_ty _ _ => by eauto
  | _ => fail "not a val_ty goal"
  end.

Notation "![ t ] e" := (load_ty t e%E) : expr_scope.
(* NOTE: in code we want to supply arbitrary expressions, so we have the usual
   notation, but the specs should be in terms of value pairs, so we have a
   similar notation in the value-scope (even though this is an expression and
   not a value)

   See the HeapLang documentation in Iris for par, which has a similar
   trick. *)
Notation "e1 <-[ t ] e2" := (store_ty t (Pair e1%E e2%E)) : expr_scope.
Notation "v1 <-[ t ] v2" := (store_ty t (PairV v1%V v2%V)) : val_scope.


Require Import SquiggleEq.list.
Require Import SquiggleEq.UsefulTypes.
Require Import common.
Require Import SquiggleEq.tactics.

Arguments memberb {_} {_} x l.

Set Implicit Arguments.

(* transparent lemma for computations. Move to SquiggleEq *)
Lemma subsetb_memberb {T:Type} {dt :Deq T} (l1 l2 : list T):
  (subsetb _ l1 l2 = true)
  -> forall t, (memberb t l1) = true -> (memberb t l2) = true.
Proof using.
  intros  Hs ? Hm.
  remember (memberb t l2) as m2. symmetry in Heqm2.
  destruct m2;[reflexivity|].
  apply False_rect.
  setoid_rewrite assert_subsetb in Hs.
  setoid_rewrite assert_memberb in Hm.
  apply Bool.not_true_iff_false in Heqm2.
  setoid_rewrite assert_memberb in Heqm2.
  eauto.
Defined.

(*Prop is also considered a type here.*)
Inductive Props : Set := Total | OneToOne (*| Irrel *).
Definition allProps : list Props := [Total; OneToOne (*; Irrel *) ].

Global Instance deq : Deq Props.
Proof using.
  apply @deqAsSumbool.
  unfold DeqSumbool. intros. unfold DecidableSumbool.
  repeat decide equality.
Defined.

Notation univ := (Set) (only parsing).

Definition IndicesInvUniv := Type.

(* use IndUnivs here? *)
(*Polymorphic *) Record GoodRel (select: list Props)
 (T₁ T₂: univ)  : IndicesInvUniv (* nececcarily bigger than Set if univ, because of R*) :=
{
  R : T₁ -> T₂ -> Prop (* Type ? *);
  Rtot : if (memberb Total select) then TotalHeteroRel R else True;
  Rone : if (memberb OneToOne select) then oneToOne R else True;

  (* Proof irrelevance is not needed anymore, after changing Type to Prop in R.
  This item is always deselected. Can be removed once we totatlly commit to Prop
  and decide that assuming Proof irrelevance is acceptable.
  About the latter, UIP was badly needed for the oneToOne of indexed inductives.
  If UIP <-> Proof Irrelevance, then we will be forced to have Proof irrelevance
  be acceptable
  Rirrel : if (memberb Irrel select) then relIrrUptoEq R else True;
   *)
}.

Check (GoodRel allProps (True:Prop) (True:Prop)):Type.

Fail Check (GoodRel allProps (nat:Set) (nat:Set)):Set (* because of R, this has to be atleast 1 bigger than Set*).

Definition eraseRP  (sb ss: list Props)
  (sub: subsetb _ ss sb=true) (T₁ T₂:univ) (gb: GoodRel sb T₁ T₂ ) :
    (GoodRel ss T₁ T₂ ).
Proof.
  (* projecting a goodrel should compute to a goodRel. So no matching before
    returning a goodRel *)
  apply Build_GoodRel with (R:= @R sb _ _ gb);
     destruct gb; simpl in *;
  apply' subsetb_memberb sub.
- specialize (sub Total).
  destruct (memberb _ ss);[| exact I].
  specialize (sub eq_refl). rewrite sub in Rtot0.
  assumption.
- specialize (sub OneToOne).
  destruct (memberb _ ss);[| exact I].
  specialize (sub eq_refl). rewrite sub in Rone0.
  assumption.
Defined.

Definition onlyTotal : list Props := [Total].

Definition cast_Good_onlyTotal  (T₁ T₂:univ)  (gb: GoodRel allProps T₁ T₂ ) :
  (GoodRel onlyTotal T₁ T₂ ).
  apply eraseRP with (sb:=allProps);[reflexivity| assumption].
Defined.

Definition BestRel  : Set -> Set -> Type := GoodRel allProps (* [Total; OneToOne] *).
Definition BestR : forall T₁ T₂ : Set, GoodRel allProps T₁ T₂ -> T₁ -> T₂ -> Prop
  := @R allProps.

Lemma IsoRel_implies_iff (A B:Prop) (pb : BestRel A B) : A <-> B.
Proof using.
  specialize (@Rtot allProps _ _ pb). simpl.
  intros Ht.
  apply Prop_RSpec in Ht.
  apply fst in Ht.
  unfold IffRel in Ht.
  apply tiffIff in Ht.
  apply Ht.
Qed.

Definition mkBestRel (A1 A2:Set) (AR : A1 -> A2 -> Prop)
           (tot12 : TotalHeteroRelHalf AR)
           (tot21 : TotalHeteroRelHalf (rInvSP AR))
           (one12: oneToOneHalf AR)
           (one21: oneToOneHalf (rInvSP AR))
  : BestRel A1 A2.
Proof.
  exists AR; simpl.
  - split.
    + exact tot12.
    + exact tot21.
  - split.
    + exact one12.
    + exact one21.
Defined.

Definition mkBestRelPropOld (A1 A2:Prop) (AR : A1 -> A2 -> Prop)
           (tot12 : TotalHeteroRelHalf AR)
           (tot21 : TotalHeteroRelHalf (rInvSP AR))
  : BestRel A1 A2.
Proof.
  exists AR; simpl.
  - split.
    + exact tot12.
    + exact tot21.
  - apply propeOneToOne.
Defined.

(* TODO: remove new *)
Definition mkBestRelProp (A1 A2:Prop) (AR : A1 -> A2 -> Prop)
           (tot12 : iffCompleteHalf AR)
           (tot21 : iffCompleteHalf (rInvSP AR))
  : BestRel A1 A2.
Proof.
  exists AR; simpl.
  - apply iffHalfTotal; assumption.
  - apply propeOneToOne.
Defined.

Definition BestTot12 (T₁ T₂ : Set) (T_R: GoodRel allProps T₁ T₂) (t1:T₁) : T₂
  := projT1 ((fst (Rtot T_R)) t1).

Definition BestTot12R (T₁ T₂ : Set) (T_R: GoodRel allProps T₁ T₂) (t1:T₁)
  := projT2 ((fst (Rtot T_R)) t1).

Definition BestTot21 (T₁ T₂ : Set) (T_R: GoodRel allProps T₁ T₂) (t2:T₂) : T₁
  := projT1 ((snd (Rtot T_R)) t2).

Definition BestTot21R (T₁ T₂ : Set) (T_R: GoodRel allProps T₁ T₂) (t2:T₂)
  := projT2 ((snd (Rtot T_R)) t2).

Definition BestOne12 (A B : Set) (T_R: GoodRel allProps A B) (a :A) (b1 b2 :B)
  (r1 : R T_R a b1) (r2 : R T_R a b2) : b2=b1
  := eq_sym ((proj1 (Rone T_R)) a b1 b2 r1 r2).

Definition BestOne21 (A B : Set) (T_R: GoodRel allProps A B) (a1 :A) (b :B) (a2:A)
  (r1 : R T_R a1 b) (r2 : R T_R a2 b) : a2 = a1
  := eq_sym ((proj2 (Rone T_R)) b a1 a2 r1 r2).

Definition BestOneijjo (A B : Set) (T_R: GoodRel allProps A B) (a :A) (b1 b2 :B)
  (r1 : R T_R a b1) (r2 : R T_R a b2) : b1=b2
  :=  ((proj1 (Rone T_R)) a b1 b2 r1 r2).

Definition BestOneijjo21 (A B : Set) (T_R: GoodRel allProps A B) (b :B) (a1 a2:A)
  (r1 : R T_R a1 b) (r2 : R T_R a2 b) : a1 = a2
  :=  ((proj2 (Rone T_R)) b a1 a2 r1 r2).

Definition BestRelP : Prop -> Prop -> Prop := iff.
Definition BestRP (T₁ T₂ : Prop) (t₁ : T₁) (t₂ : T₂) : Prop := True.

Require Import ProofIrrelevance.

(*
The relation for Prop cannot be  (fun _ _ => True) as it breaks many things:
see the erasure section of onenote
https://onedrive.live.com/edit.aspx/Documents/Postdoc?cid=946e75b47b19a3b5&id=documents&wd=target%28parametricity%2Fpapers%2Flogic%2Ferasure.one%7CE3B57163-01F2-A447-8AD2-A7AA172DB692%2F%29
onenote:https://d.docs.live.net/946e75b47b19a3b5/Documents/Postdoc/parametricity/papers/logic/erasure.one#section-id={E3B57163-01F2-A447-8AD2-A7AA172DB692}&end
 *)

Definition GoodPropAsSet {A1 A2:Prop} (bp: BestRelP A1 A2) : BestRel A1 A2.
unfold BestRelP in bp.
exists (fun _ _ => True); simpl.
- apply Prop_RSpec. unfold Prop_R,IffRel,CompleteRel.
  apply tiffIff in bp.
  split; [assumption|]. intros ? ?. exact I.
- split; intros ? ?  ? ? ?; apply proof_irrelevance.
Defined.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2004                                *)
(*                              LaBRI                                   *)
(************************************************************************)
Add LoadPath "..".
Set Implicit Arguments.
Require Export crossDep.

(* analysis of crossed-dependencies in Dutch: this phenomenon can't be anlysed by a CFG !*)
(* examples taken from 'Labelled Deduction in the composition of Form and Meaning: M.Moortgat 1999*)

Require Export notations.

Inductive I:Set:= |i0|i1.

Definition eqDecI: eqdec I.
 unfold eqdec; decide equality.
Defined.

Inductive W:Set:=
Peter|Mary|wil|plagen|slapen.

(* here the translation of the above words:
  wil --> wants
  plagen-->tease
  slapen-->sleep
  *)

Definition eqDecW:eqdec W.
unfold eqdec; decide equality.
Defined.

Inductive atoms:Set:= np |s|inf.

Definition eqDecA:eqdec atoms.
unfold eqdec; decide equality.
Defined.

Open Scope lamb_scope.
Definition mapping(ato: atoms):semType:=
match ato with
|np =>e
|s=>t
|inf=> e-->t (* a revoir je suis pas du tout sure!*)
end.

Open Scope mmg_scope.
Notation "'!' F":=(At F)(at level 40):mmg_scope.
Notation "A '/o' B"
 := (Slash i0 A B) (at level 41,  right associativity) : mmg_scope.

Notation " A '\o' B"
 := (Backslash i0 A B) (at level 41,  right associativity) : mmg_scope.

Notation " A 'Oo B"
 := (Dot i0 A B) (at level 38, left associativity) : mmg_scope.

Notation "'[]o' A" :=(Box i0 A) (at level 30):mmg_scope.
Notation "'<>o' A":=(Diamond i0 A)(at level 30):mmg_scope.

Notation "A '/1' B"
 := (Slash i1 A B) (at level 41,  right associativity) : mmg_scope.

Notation " A '\1' B"
 := (Backslash i1 A B) (at level 41,  right associativity) : mmg_scope.

Notation " A 'O1 B"
 := (Dot i1 A B) (at level 38, left associativity) : mmg_scope.

Notation "'[]1' A" :=(Box i1 A) (at level 30):mmg_scope.
Notation "'<>1' A":=(Diamond i1 A)(at level 30):mmg_scope.

(* set of semantic constants*)
Inductive consSem:Set:=
|mary|peter|wi|plag|slap.

Notation "'$' n" :=(num (semRess I I atoms W) n) (at level 40):mmg_scope.
Notation "% n" :=(num consSem n)(at level 40):mmg_scope.
Notation "'#' w":= (oneW I I  w)(at level 40):mmg_scope .
Notation " T1 ';1' T2 ":=(comW i1 T1 T2)(at level 41,right associativity):mmg_scope.
Notation " T1 ';o' T2 ":=(comW i0 T1 T2)(at level 41,right associativity):mmg_scope.

Definition setType(cs:consSem):semType:=
match cs with
| peter => e
| mary => e
|wi =>(e-->t)-->e-->t
|plag=>(intention (e-->e-->t))
|slap=>(intention (e-->t))
end.

Definition lexic(w:W):list (prod (Form I I atoms) (lambdaC consSem)):=
match w with
|Peter => (! np , @peter)::nil
|Mary =>(! np, @mary)::nil
|wil=>([]o ((! np \1 !s)/o !inf) ,@wi)::nil
|plagen=>([]o (!np \1 !inf) ,@plag)::nil
|slapen=>([]o (!inf) ,@slap)::nil
end.

Definition lexic1:lexicon.
econstructor.
eexact eqDecI.
eexact eqDecI.
eexact eqDecA.
eexact eqDecW.
eexact mapping.
eexact setType.
eexact lexic.
Defined.

Definition ext:=add_rule (K2Diam i1 i1) (add_rule (incDiam I i1 i0)
         (add_rule (KDiam i0 i0) (add_rule (MPDiam i1 i0 i0) NL))).
Definition gram:Grammar.
eapply mk_gram with (lexic:=lexic1).
simpl.
exact ext.
Defined.

Definition frag:= Mary::wil::slapen::nil.

Definition my_contextW:= #Mary ;1 #wil ;o #slapen.

Definition treeDeriv:[gram] frag>>[]1 (!s).
unfold deriveTo.
setCont0 my_contextW.
simpl.
boxI.
unfold ext.
eapply cross_depend.
repeat econstructor. (* faire une tactique !*)
repeat econstructor.
repeat econstructor.
simpl.
ebackE.
axiom.
eslashE.
boxE.
axiom.
boxE.
axiom.
Defined.

Definition frag2:=Peter::Mary::wil::plagen::nil.
Definition cw:= #Peter ;1 #Mary ;1 #wil ;o #plagen.
Definition tree2: [gram] frag2>> []1 (!s).
unfold deriveTo.
setCont0 cw.
simpl.
boxI.
eapply cross_depend;unfold ext.
repeat constructor.
repeat constructor.
repeat constructor.
simpl.
eapply StructRule.
constructor 2.
constructor 2.
constructor 2.
constructor 1.
constructor 3.
constructor.
apply MPDiam_rw.
ebackE.
axiom.
eslashE.
boxE.
axiom.
ebackE.
axiom.
boxE;axiom.
Defined.


From isla Require Import opsem.

Definition a742c : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 16%N)) Mk_annot :t:
  Smt (DeclareConst 92%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R6" [] (RegVal_Base (Val_Symbolic 92%Z)) Mk_annot :t:
  Smt (DefineConst 95%Z (Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Symbolic 92%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xffffffff0000ffff%Z)) Mk_annot] Mk_annot; Binop ((Bvarith Bvshl)) (Unop (ZeroExtend 48%N) (Val (Val_Symbolic 0%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 64%N 0x10%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R6" [] (RegVal_Base (Val_Symbolic 95%Z)) Mk_annot :t:
  Smt (DeclareConst 96%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 96%Z)) Mk_annot :t:
  Smt (DefineConst 97%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 96%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 97%Z)) Mk_annot :t:
  tnil
.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D U Xu Du Bprime Dprime Dprimeprime : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ O Xu /\ (wd_ Dprimeprime O /\ (wd_ D Du /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime O /\ (col_ O E Xu /\ (col_ O A Eprime /\ (col_ Xu A Eprime /\ (col_ O Eprime Du /\ (col_ O Eprime Bprime /\ (col_ O Eprime Dprime /\ col_ O Eprime Dprimeprime))))))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*============================================================================================
 The Ethereum Runtime Environment (ERE) for the virtual machine EVM.

 ============================================================================================*)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype finfun tuple zmodp.

Require Import common_definitions exceptions bitsrep bitsops cursor pmap reader writer mem stack instr program.

(*=Log topic *)
Definition LOGTopic := seq EVMWORD.

Notation "'nilLOGTopic'" := nil.
(*=End *)

(*=Log entry *)
Record LOGEntry :=
  mkLOGEntry {
      a : ADDRESS;
      t : LOGTopic;
      logm : seq BYTE
    }.
(*=End *)

(*-------------------------------------------------------------------------------------------
 Initialize.
 -------------------------------------------------------------------------------------------*)
Definition initialLOGEntry : LOGEntry :=
  mkLOGEntry (#0 : ADDRESS) nilLOGTopic nil.

(*=ERE *)
Record EREnvironment :=
  mkEREnvironment {
      (* address of the contract or contract-to-be that owns the running code *)
      Ia : ADDRESS;
      (* the sender address that sends the message - either equal to origin or a constract *)
      Io : ADDRESS;
      (* Original transactor *)
      Is : ADDRESS;
      (* the price of gas in the transaction *)
      Ip : EVMWORD;
      (* the input data *)
      Id : seq BYTE;
      (* the value *)
      Iv : EVMWORD;
      (* the bytecode *)
      Ib : Program;
      (* the hash of executing code *)
      Ih : EVMWORD;

      (* sub-state *)
      As : seq ADDRESS;
      Al : seq LOGEntry;
      Ar : EVMWORD;

      (* the call depth *)
      Ie : EVMWORD
    }.

(*=End *)

(*---------------------------------------------------------------------------------------------
 Initialization.
 ---------------------------------------------------------------------------------------------*)
Definition initialERE : EREnvironment :=
  mkEREnvironment (#0 : ADDRESS)
                  (#0 : ADDRESS)
                  (#0 : ADDRESS)
                  (#0 : EVMWORD)
                  nil
                  (#0 : EVMWORD)
                  initialProgram
                  (#0 : EVMWORD)
                  nil
                  nil
                  (#0 : EVMWORD)
                  (#0 : EVMWORD).

(*---------------------------------------------------------------------------------------------
 Update Ia.
 ---------------------------------------------------------------------------------------------*)
Definition updateIa (newIa : ADDRESS) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment newIa
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Io.
 ---------------------------------------------------------------------------------------------*)
Definition updateIo (newIo : ADDRESS) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  newIo
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Is.
 ---------------------------------------------------------------------------------------------*)
Definition updateIs (newIs : ADDRESS) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  newIs
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Ip.
 ---------------------------------------------------------------------------------------------*)
Definition updateIp (newIp : EVMWORD) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  newIp
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Id.
 Notice that it updates the whole sequence of BYTE in Id.
 ---------------------------------------------------------------------------------------------*)
Definition updateId (newId : seq BYTE) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  newId
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Iv.
 ---------------------------------------------------------------------------------------------*)
Definition updateIv (newIv : EVMWORD) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  newIv
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Ib.
 Notice that it replaces the whole sequence of BYTE in Ib.
 ---------------------------------------------------------------------------------------------*)
Definition updateIb (newIb : Program) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  newIb
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Ih.
 ---------------------------------------------------------------------------------------------*)
Definition updateIh (newIh : EVMWORD) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  newIh
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update As.
 ---------------------------------------------------------------------------------------------*)
Definition updateAs (newAs : seq ADDRESS) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  newAs
                  e.(Al)
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Al.
 ---------------------------------------------------------------------------------------------*)
Definition updateAl (newAl : seq LOGEntry) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  newAl
                  e.(Ar)
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Ar.
 ---------------------------------------------------------------------------------------------*)
Definition updateAr (newAr : EVMWORD) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  newAr
                  e.(Ie).

(*---------------------------------------------------------------------------------------------
 Update Ie.
 ---------------------------------------------------------------------------------------------*)
Definition updateIe (newIe : EVMWORD) (e : EREnvironment) : EREnvironment :=
  mkEREnvironment e.(Ia)
                  e.(Io)
                  e.(Is)
                  e.(Ip)
                  e.(Id)
                  e.(Iv)
                  e.(Ib)
                  e.(Ih)
                  e.(As)
                  e.(Al)
                  e.(Ar)
                  newIe.

(*--------------------------------------------------------------------------------------------
 ERE to string.
 --------------------------------------------------------------------------------------------*)
Require Import Coq.Strings.String.
Import Ascii.

(* LOGEntry to string *)
Definition logentrytoString (loge : LOGEntry) :=
  (
    "(" ++ (toHex loge.(a)) ++ "," ++ (evmwordsToHex loge.(t)) ++ "," ++ (bytesToHex loge.(logm)) ++ ")"
  )%string.

(* sequence of LOGEntry (Al) to string *)
Fixpoint altoString (al : seq LOGEntry) :=
  (
    if al is a::al then
      logentrytoString a ++ "; " ++ altoString al
    else
      ""
  )%string.

Definition eretoString (eres : EREnvironment) :=
  (
    "(Ia: " ++ (toHex eres.(Ia)) ++
            ",Io: " ++ (toHex eres.(Io)) ++
            ",Is: " ++ (toHex eres.(Is)) ++
            ",Ip: " ++ (toHex eres.(Ip)) ++
            ",Id: " ++ (bytesToHex eres.(Id)) ++
            ",Iv: " ++ (toHex eres.(Iv)) ++
            ",Ib: " ++ (programToString eres.(Ib)) ++
            ",Ih: " ++ (toHex eres.(Ih)) ++
            ",As: " ++ (addressesToHex eres.(As)) ++
            ",Al: " ++ (altoString eres.(Al)) ++
            ",Ar: " ++ (toHex eres.(Ar)) ++
            ",Ie: " ++ (toHex eres.(Ie)) ++ ")"
  )%string.


Require Import
        Fiat.Common.BoundedLookup.
Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Coq.Vectors.Vector
        Bedrock.Word.

Section Enum.
  Context {len : nat}.
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Context {sz : nat}.
  Context {ta : t A (S len)}.
  Variable (tb : t (word sz) (S len)).

  Inductive NoDupVector {A}
    : forall {n}, Vector.t A n -> Prop :=
    NoDupVector_nil : NoDupVector (Vector.nil _)
  | NoDupVector_cons : forall (x : A) {n} (l : Vector.t A n),
      ~ Vector.In x l -> NoDupVector l -> NoDupVector (Vector.cons _ x _ l).

  Lemma NoDupVector_invert {A'}
    : forall n (l : Vector.t A' n),
      NoDupVector l
      -> match l with
         | Vector.nil => True
         | Vector.cons a _ l' =>
           ~ Vector.In a l' /\ NoDupVector l'
         end.
  Proof.
    clear; induction 1; eauto.
  Qed.

  Definition format_enum (idx : Fin.t _) :
    CacheFormat -> Comp (B * CacheFormat) :=
    format_word (nth tb idx).

  Definition encode_enum (idx : Fin.t _) :
    CacheFormat -> B * CacheFormat :=
    encode_word (nth tb idx).

  Lemma refine_format_enum :
    forall idx ce,
      refine (format_enum idx ce)
             (ret (encode_enum idx ce)).
  Proof.
    intros; reflexivity.
  Qed.

  Fixpoint word_indexed {n : nat}
           (w : word sz)
           (t : t (word sz) n) : option (Fin.t n)
    := match t in Vector.t _ n return option (Fin.t n) with
       | nil => None
       | cons w' _ t' =>
         if (weqb w w') then Some (Fin.F1) else
           match word_indexed w t' with
           | Some f => Some (Fin.FS f)
           | None => None
           end
       end.

  Definition decode_enum (b : B)
             (cd : CacheDecode)
    : option (Fin.t _ * B * CacheDecode) :=
    `(w, b', cd') <- decode_word (sz:=sz) b cd;
      Ifopt word_indexed w tb as idx Then
      Some (idx, b', cd')
      Else None.

  Lemma word_indexed_correct :
    forall n (i : Fin.t n) (t : t (word sz) n),
      NoDupVector t
      -> match word_indexed (nth t i) t with
      | Some w' => i = w'
      | None => False
      end.
  Proof.
    clear.
    induction i.
    - intro; pattern n, t; apply Vector.caseS; simpl; intros.
      rewrite (proj2 (weqb_true_iff h h)); eauto.
    - intro; generalize i (IHi (Vector.tl t)); clear.
      pattern n, t; apply Vector.caseS; simpl.
      intros h n0 t0 i; case_eq (word_indexed (nth t0 i) t0); intros;
        apply NoDupVector_invert in H1; intuition subst.
      case_eq (weqb (nth t0 t1) h); intros; eauto.
      apply weqb_true_iff in H0; subst.
      destruct H2; generalize t0 H; clear; induction t1.
      + intro; pattern n, t0; apply Vector.caseS; simpl; intros; econstructor.
      + intro; revert t1 IHt1; pattern n, t0; apply Vector.caseS;
          simpl; intros.
        case_eq (weqb (nth t t1) h); intros; eauto.
        * apply weqb_true_iff in H0; subst; econstructor.
        * rewrite H0 in H.
          econstructor 2; apply IHt1.
          destruct (word_indexed (nth t t1) t); try discriminate.
          f_equal; apply Fin.FS_inj; congruence.
  Qed.

  Theorem Enum_decode_correct
          (tb_OK : NoDupVector tb)
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    : CorrectDecoder monoid (fun _ => True) (fun _ _ => True) format_enum decode_enum P.
  Proof.
    split; unfold format_enum, decode_enum.
    { intros env env' xenv c c' ext ? Eeq Ppred Ppred_rest Penc.
      destruct (proj1 (Word_decode_correct P_OK) _ _ _ _ _ ext env_OK Eeq I I Penc) as [? [? ?] ].
      rewrite H; simpl.
      apply (word_indexed_correct _ c) in tb_OK.
      subst; simpl in *.
      destruct (word_indexed (nth tb c) tb);
        intros; simpl in *.
      + eexists; intuition eauto.
        repeat f_equal.
        simpl in H; subst.
        reflexivity.
      + intuition.
    }
    { intros.
      destruct (decode_word bin env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
      destruct (word_indexed w tb) eqn: ? ;
        simpl in *; try discriminate; injections.
      eapply (proj2 (Word_decode_correct P_OK)) in Heqo; eauto;
        destruct Heqo; destruct_ex; intuition; subst.
      simpl.
      unfold format_word in *; computes_to_inv; injections.
      unfold format_word; repeat eexists; eauto.
      repeat f_equal.
      revert Heqo0; clear.
      remember (S len) as n'; clear len Heqn'.
      revert w tb; induction data.
      - intros w tb; pattern n, tb;
          eapply Vector.caseS; simpl.
        intros; destruct (weqb w h) eqn: ?.
        eapply weqb_true_iff; eauto.
        destruct ( word_indexed w t); try discriminate.
      - intros w tb.
        revert w data IHdata.
        pattern n, tb; eapply Vector.rectS; simpl; intros.
        inversion data.
        intros; destruct (weqb w a) eqn: ?.
        discriminate.
        destruct (word_indexed w v) eqn : ? ; try discriminate.
        eapply IHdata.
        rewrite Heqo.
        f_equal.
        eapply Fin.FS_inj.
        revert Heqo0.
        congruence.
    }
  Qed.
End Enum.

Lemma VectorIn_cons {A} {n}
  : forall (v : Vector.t A n) a a',
    Vector.In a' (Vector.cons _ a _ v) -> a = a' \/ Vector.In a' v.
Proof.
  intros; inversion H; subst; eauto.
  apply Eqdep_dec.inj_pair2_eq_dec in H3; subst; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma forall_Vector_P {A} (P : A -> Prop) {n}
  : forall v : Vector.t A n,
    Vector.Forall P v
    -> forall idx, P (Vector.nth v idx).
Proof.
  induction v; simpl; intros.
  - inversion idx.
  - revert v IHv H; pattern n, idx; apply Fin.caseS; simpl;
      intros; inversion H; subst; eauto.
    eapply IHv.
    apply Eqdep_dec.inj_pair2_eq_dec in H2; subst; eauto using Peano_dec.eq_nat_dec.
Qed.

Ltac Discharge_NoDupVector :=
  match goal with
  |- NoDupVector _ =>
  repeat econstructor; intro;
  repeat match goal with
         | H : Vector.In _ _ |- _ =>
           first [apply VectorIn_cons in H; destruct H; try discriminate
                 | inversion H]
         end
  end.