Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Lists.List.
Inductive ty : Set :=
| base : ty
| arr : list ty -> ty -> ty.

Fixpoint ty_Prop (t : ty) : Prop :=
  match t with
  | base => False
  | arr ts t' =>
    (fix tys_Prop (ts : list ty) :=
       match ts with
       | nil => True
       | t'' :: ts' => ty_Prop t'' /\ tys_Prop ts'
       end) ts /\ ty_Prop t'
  end.

Inductive ty_Prop' : ty -> Prop :=
| base_Prop : ty_Prop' base
| arr_Prop : forall ts t,
    Forall ty_Prop' ts -> ty_Prop' t ->
    ty_Prop' (arr ts t).

Require Import
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Numbers.BinNums
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts.

Inductive ASN1_Simple : Set :=
| ASN_Boolean : ASN1_Simple (* Universal 1 *)
| ASN_Null : ASN1_Simple (* Universal 5 *)
| ASN_Integer : ASN1_Simple (* Universal 2 *)
| ASN_Enum : (* Universal 10 *)
    list nat (* Codes *)
    -> ASN1_Simple
| ASN_BitString : ASN1_Simple (* Universal 3 *)
| ASN_OctetString : ASN1_Simple (* Universal 4 *)
| ASN_NumericString : ASN1_Simple (* Universal 18*)
| ASN_PrintableString : ASN1_Simple (* Universal 19 *)
| ASN_IA5String : ASN1_Simple. (* Universal 22 *)

Inductive ASN1_Simple_Modifier : Set :=
| ASN_Size_Fixed : nat -> ASN1_Simple_Modifier
| ASN_Size_Range : nat -> nat -> ASN1_Simple_Modifier
| ASN_None : ASN1_Simple_Modifier.

Definition ASN1_Simple_denote (desc : ASN1_Simple) : Set :=
  match desc with
  | ASN_Boolean => bool
  | ASN_Null => unit
  | ASN_Integer => Z
  | ASN_Enum n => Fin.t (List.length n)
  | ASN_BitString => list bool
  | ASN_OctetString => list (word 8)
  | ASN_NumericString => string
  | ASN_PrintableString => string
  | ASN_IA5String => string
  end.

Inductive ASN1_Structured : Set :=
| ASN_Sequence : list ASN1_Sequence_Element -> ASN1_Structured
| ASN_Choice : list ASN1_Type -> ASN1_Structured
| ASN_Sequence_Of : ASN1_Type -> ASN1_Structured

with ASN1_Sequence_Element : Set :=
     | Normal_Sequence_Element :
         ASN1_Type -> ASN1_Sequence_Element
     | Optional_Sequence_Element :
         ASN1_Type -> ASN1_Sequence_Element
     | Default_Sequence_Element :
         forall (desc : ASN1_Simple),
           ASN1_Simple_Modifier
           -> ASN1_Simple_denote desc
           -> ASN1_Sequence_Element

with ASN1_Type : Set :=
     | ASN_Simple : ASN1_Simple -> ASN1_Simple_Modifier -> ASN1_Type
     | ASN_Structured : ASN1_Structured -> ASN1_Type.

Coercion ASN_Structured : ASN1_Structured >-> ASN1_Type.

Definition ASN_Simple_UnModified (desc : ASN1_Simple) : ASN1_Type :=
  ASN_Simple desc ASN_None.
Coercion ASN_Simple_UnModified : ASN1_Simple >-> ASN1_Type.

Fixpoint ASN1_Structured_denote (desc : ASN1_Structured) : Set :=
  match desc with
  | ASN_Sequence l =>
    (fix ASN1_Sequence_denote (descs : list ASN1_Sequence_Element) {struct descs} : Set :=
       match descs with
       | Normal_Sequence_Element desc :: descs' =>
         (ASN1_Type_denote desc) * (ASN1_Sequence_denote descs')
       | Optional_Sequence_Element desc :: descs' =>
         option (ASN1_Type_denote desc) * (ASN1_Sequence_denote descs')
       | Default_Sequence_Element desc _ _ :: descs' =>
         (ASN1_Simple_denote desc) * (ASN1_Sequence_denote descs')
       | [ ] => unit
       end)%type l
  | ASN_Choice l =>
    (fix ASN1_Choice_denote (descs : list ASN1_Type) {struct descs} : Set :=
       match descs with
       | desc :: descs' => (ASN1_Type_denote desc) + (ASN1_Choice_denote descs')
       | [ ] => unit
       end)%type l
  | ASN_Sequence_Of desc' => list (ASN1_Type_denote desc')
  end

with ASN1_Type_denote (desc : ASN1_Type) : Set :=
       match desc with
       | ASN_Simple desc' mod => ASN1_Simple_denote desc'
       | ASN_Structured desc' => ASN1_Structured_denote desc'
       end.

Section ASN1_Format.

  Require Import
          Bedrock.Word.

  Require Import
          Fiat.Common.EnumType
          Fiat.Common.BoundedLookup
          Fiat.Narcissus.Formats.WordOpt
          Fiat.Narcissus.Formats.EnumOpt
          Fiat.Narcissus.Formats.Bool
          Fiat.Narcissus.Formats.NatOpt
          Fiat.Narcissus.Formats.FixStringOpt
          Fiat.Narcissus.Common.ComposeOpt.

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

  Import Coq.Vectors.Vector.VectorNotations.

  Definition Tag_Classes :=
    ["Universal"; "Application"; "Context-Specific"; "Private"]%string.

  Definition Tag_Class_Codes :=
    [WO~0~0; WO~0~1; WO~1~0; WO~1~1].

  Definition Tag_Class := EnumType Tag_Classes.

  Definition ASN1_Format_Tag
           (tag : BoundedString Tag_Classes)
           (primitive : bool)
           (identifier : nat)
    : CacheFormat -> Comp (B * CacheFormat) :=
          format_enum Tag_Class_Codes (ibound (indexb tag))
    ThenC format_word (WS primitive WO)
    ThenC (If (NPeano.ltb identifier 31) Then
              format_nat 5 identifier
              Else (format_nat 31 identifier
              ThenC (* TODO: Put actual high-tag formating rule here. *)
              format_nat 5 identifier))
    DoneC.

  Definition ASN1_Format_Definite_Length
             (length : nat)
    : CacheFormat -> Comp (B * CacheFormat) :=
    If (NPeano.ltb length 127) Then
       format_nat 8 length
    Else
       (format_word WO~1 (* Set highest bit to 1 *)
       ThenC format_nat (S (NPeano.div (NPeano.log2 length) 8)) 7
       ThenC format_nat length (S (NPeano.div (NPeano.log2 length) 8) * 8))
       DoneC.

  Fixpoint ASN1_Format_Simple_DER
         (desc : ASN1_Simple)
  : ASN1_Simple_denote desc -> CacheFormat -> Comp (B * CacheFormat) :=
  match desc return
        ASN1_Simple_denote desc
        -> CacheFormat
        -> Comp (B * CacheFormat) with

  | ASN_Boolean =>
    fun data =>
          ASN1_Format_Tag ``"Universal" false 1
    ThenC ASN1_Format_Definite_Length 1
    ThenC format_word (if data then natToWord 8 255 else natToWord 8 0)
    DoneC

  | ASN_Null =>
    fun data =>
          ASN1_Format_Tag ``"Universal" false 5
    ThenC ASN1_Format_Definite_Length 0
    DoneC

  | ASN_Integer => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_Enum n => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_BitString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_OctetString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_NumericString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_PrintableString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_IA5String =>
    fun data =>
          ASN1_Format_Tag ``"Universal" false 22
    ThenC ASN1_Format_Definite_Length (String.length data)
    ThenC format_string data
    DoneC
  end.

End ASN1_Format.

Arguments ASN1_Format_Definite_Length _ _ / . (* Always simplify this format*)
Arguments ASN1_Format_Tag _ _ / . (* Always simplify this format*)

Section ASN1_Decoder_Example.

  Require Import
          Fiat.Narcissus.Stores.EmptyStore
          Fiat.Narcissus.Automation.Solver
          Fiat.Narcissus.BinLib.AlignedByteString
          Fiat.Narcissus.BinLib.AlignWord
          Fiat.Narcissus.BinLib.AlignedDecoders.

  Instance ByteStringQueueMonoid : Monoid ByteString :=
    ByteStringQueueMonoid.

  Example Simple_Format : ASN1_Simple :=
    ASN_IA5String.

  Ltac normalize_Compose Monoid :=
    eapply SetoidMorphisms.refine_refineEquiv_Proper;
    [ unfold flip;
      repeat first
             [ etransitivity; [ apply refineEquiv_compose_compose with (monoid := Monoid) | idtac ]
             | etransitivity; [ apply refineEquiv_compose_Done with (monoid := Monoid) | idtac ]
             | apply refineEquiv_under_compose with (monoid := Monoid) ];
      intros; first [reflexivity | higher_order_reflexivity]
    | reflexivity | ].

  Add Parametric Morphism
      (E B : Type) (monoid : Monoid B)
    : (@compose E B monoid)
      with signature
      (pointwise_relation _ (@refine (B * E)))
        ==> (pointwise_relation _ (@refine (B * E)))
        ==> (@eq E)
        ==> (@refine (B * E))
        as refine_compose.
  Proof.
    unfold pointwise_relation, compose, Bind2; intros.
    setoid_rewrite H; setoid_rewrite H0; reflexivity.
  Qed.

  Lemma refine_compose_compose
     : forall (E B : Type) (monoid : Monoid B) (format1 format2 format3 : E -> Comp (B * E)) (ctx : E),
      refine (((format1 ThenC format2) ThenC format3) ctx)
             ((format1 ThenC format2 ThenC format3) ctx).
  Proof.
    unfold pointwise_relation; intros.
    apply refineEquiv_compose_compose.
  Qed.

  Lemma refine_ThenC_beta_reduce
    : forall (E B : Type) (monoid : Monoid B) (format1 format2 : E -> Comp (B * E)) (ctx : E),
      refine ((format1 ThenC (fun ctx' => format2 ctx')) ctx)
             ((format1 ThenC format2) ctx).
  Proof.
    intros; reflexivity.
  Qed.

  Lemma refine_If_Then_Else_beta_reduce
    : forall (E B : Type) (monoid : Monoid B) (format1 format2 : E -> Comp (B * E)) (ctx : E) b,
      refine ((If b Then format1 Else format2) ctx)
             (If b Then format1 ctx Else format2 ctx).
  Proof.
    intros; destruct b; reflexivity.
  Qed.

  Corollary AlignedFormatNat
            {numBytes}
    : forall (n : nat) ce ce' (c : _ -> Comp _) (v : Vector.t _ numBytes),
      refine (c (addE ce 8)) (ret (build_aligned_ByteString v, ce'))
      -> refine (((format_nat 8 (monoidUnit := ByteString_QueueMonoidOpt) n)
                    ThenC c) ce)
                (ret (build_aligned_ByteString (Vector.cons _ (natToWord 8 n) _ v), ce')).
  Proof.
    unfold format_nat; cbv beta; intros.
    rewrite <- AlignedFormatChar; eauto.
    reflexivity.
  Qed.

  Definition Variational_Vector
             {numBytesT numBytesE}
             (b : bool)
             (vT : Vector.t Core.char numBytesT)
             (vE : Vector.t Core.char numBytesE)
    : Vector.t Core.char (If b Then numBytesT Else numBytesE) :=
    match b return
          Vector.t Core.char (If b Then numBytesT Else numBytesE)
    with
    | true => vT
    | false => vE
    end.

  Lemma AlignedFormat_If_Then_Else
            {numBytesT numBytesE}
    : forall (b : bool) ctx ctxT ctxE
             (vT : Vector.t Core.char numBytesT)
             (vE : Vector.t Core.char numBytesE)
             (format1 format2 : CacheFormat -> Comp (_ * CacheFormat)),
      (b = true
       -> refine (format1 ctx) (ret (build_aligned_ByteString vT, ctxT)))
      -> (b = false
          -> refine (format2 ctx) (ret (build_aligned_ByteString vE, ctxE)))
      -> refine (If b Then (format1 ctx) Else (format2 ctx))
                (ret (build_aligned_ByteString (Variational_Vector b vT vE)

                      , If b Then ctxT Else ctxE)).
  Proof.
    destruct b; simpl; intros; eauto.
  Qed.

  Lemma build_aligned_ByteString_id {B}
    : forall ctx : B,
      refine (ret (ByteString_id, ctx))
             (ret (build_aligned_ByteString (Vector.nil _), ctx)).
  Proof.
    intros; replace ByteString_id
             with (build_aligned_ByteString (Vector.nil _)).
    reflexivity.
    eapply ByteString_f_equal;
      instantiate (1 := eq_refl _); reflexivity.
  Qed.

  (* We'll restrict this example to strings with fewer than 127 bytes. *)
  Definition Simple_Format_OK
             (t : ASN1_Simple_denote Simple_Format)
    := NPeano.Nat.ltb (String.length t) 127 = true.

  Lemma If_Then_Else_format_correct
      {A B}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_invT P /\ P_invE P))
      (monoid : Monoid B)
      (predicate predicateT predicateE : A -> Prop)
      (predicate_rest : A -> B -> Prop)
      (proj : A -> bool)
      (ICompb : B -> bool)
      (formatT : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeT : B -> CacheDecode -> option (A * B * CacheDecode))
      (formatE : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeE : B -> CacheDecode -> option (A * B * CacheDecode))
      (decodeT_pf :
         cache_inv_Property P P_invT
         -> CorrectDecoder
              cache monoid predicateT predicate_rest
              formatT decodeT P)
      (decodeE_pf :
         cache_inv_Property P P_invE
         -> CorrectDecoder
              cache monoid predicateE predicate_rest
              formatE decodeE P)
      (ICompb_OKT : forall data bin env xenv ext,
          predicateT data
          -> formatT data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = true)
      (ICompb_OKT' : forall data bin env xenv ext,
          ICompb bin = true
          -> decodeT bin env = Some (data, ext, xenv)
          -> proj data = true)
      (ICompb_OKE : forall data bin env xenv ext,
          predicateE data
          -> formatE data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = false)
      (ICompb_OKE' : forall data bin env xenv ext,
          ICompb bin = false
          -> decodeE bin env = Some (data, ext, xenv)
          -> proj data = false)
      (predicateT_OK : forall a, proj a = true
                                 -> (predicate a
                                     <-> predicateT a))
      (predicateE_OK : forall a, proj a = false
                                 -> (predicate a
                                 <-> predicateE a))
  : CorrectDecoder
      cache monoid
      (fun a => predicate a)
      predicate_rest
      (fun (data : A) (ctx : CacheFormat) =>
         (If (proj data)
            Then (formatT data ctx)
            Else (formatE data ctx))
      )%comp
      (fun (b' : B) (env : CacheDecode) =>
         If ICompb b' Then
            decodeT b' env
            Else
            decodeE b' env
      ) P.
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm pred_pm_rest com_pf.
    specialize (predicateT_OK data).
    specialize (predicateE_OK data).
    destruct (proj data); simpl in com_pf.
    - erewrite ICompb_OKT; eauto.
      simpl; eapply decodeT_pf; intuition eauto.
      intuition eauto.
    - erewrite ICompb_OKE; eauto.
      simpl; eapply decodeE_pf; intuition eauto.
      intuition eauto.
  }
  { intros.
    destruct (ICompb bin) eqn : IComp_v ; simpl in *.
    - rewrite (ICompb_OKT' _ _ _ _ _ IComp_v H1).
      pose proof H1.
      eapply decodeT_pf in H1; simpl in *; intuition eauto.
      destruct_ex; eexists _, _; intuition eauto.
      eapply predicateT_OK; try eassumption.
      erewrite ICompb_OKT'; eauto.
    - rewrite (ICompb_OKE' _ _ _ _ _ IComp_v H1).
      pose proof H1.
      eapply decodeE_pf in H1; intuition eauto.
      destruct_ex; eexists _, _; intuition eauto.
      eapply predicateE_OK; try eassumption.
      erewrite ICompb_OKE'; eauto.

  }
Qed.

  Definition Correct_simple_formatr
    : { simple_formatr : _ &
                         forall (t : ASN1_Simple_denote Simple_Format),
                           Simple_Format_OK t
                           -> refine (ASN1_Format_Simple_DER Simple_Format t ())
                     (ret (simple_formatr t)) }.
  Proof.
    simpl; eexists; intros.
    unfold format_nat at 1, format_enum; simpl.
    eapply SetoidMorphisms.refine_refineEquiv_Proper;
      [ unfold flip;
        repeat first
               [ etransitivity; [ apply refineEquiv_compose_compose with (monoid := ByteStringQueueMonoid) | idtac ]
               | etransitivity; [ apply refineEquiv_compose_Done with (monoid := ByteStringQueueMonoid) | idtac ]
               | apply refineEquiv_under_compose with (monoid := ByteStringQueueMonoid) ];
        intros; higher_order_reflexivity
      | reflexivity | ];
      rewrite refine_ThenC_beta_reduce.
    rewrite (@CollapseFormatWord _ test_cache); simpl; eauto.
    rewrite !refine_ThenC_beta_reduce.
    rewrite (@CollapseFormatWord _ test_cache); simpl; eauto.
    rewrite !refine_ThenC_beta_reduce.
    eapply (@AlignedFormatChar test_cache); eauto.
    rewrite refine_If_Then_Else_ThenC.
    eapply AlignedFormat_If_Then_Else; intros.
    eapply (@AlignedFormatNat _).
    eapply (@format_string_aligned_ByteString test_cache); eauto.
    apply build_aligned_ByteString_id.
    congruence.
    Grab Existential Variables.
    exact ().
    apply Vector.nil.
  Defined.

  Arguments natToWord : simpl never.

  Definition byte_aligned_simple_formatr
             (t :  ASN1_Simple_denote Simple_Format)
    := Eval simpl in (projT1 Correct_simple_formatr t).

  Print byte_aligned_simple_formatr.

  Definition Simple_Format_decoder
    : CorrectDecoderFor Simple_Format_OK (ASN1_Format_Simple_DER Simple_Format).
  Proof.
    start_synthesizing_decoder.
    normalize_compose ByteStringQueueMonoid.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    simpl; omega.
    decode_step idtac.
    intros; eapply If_Then_Else_format_correct.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    intros; eapply String_decode_correct.
  Abort.
  (*intros.

    decode_step idtac.
    decode_step idtac.
    eauto.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    auto with arith.
    auto with arith.
    simpl.
    decode_step idtac.

    auto with arith.
    auto with arith.
    intros. setoid_rewrite refine_If_Then_Else_ThenC.
    intros.

    intros; eauto using FixedList_predicate_rest_True.
    synthesize_cache_invariant.
    cbv beta; optimize_decoder_impl.
  Defined.

Definition SimpleDecoderImpl
    := Eval simpl in (projT1 Simple_Format_decoder).

  Ltac rewrite_DecodeOpt2_fmap :=
    set_refine_evar;
    progress rewrite ?BindOpt_map, ?DecodeOpt2_fmap_if,
    ?DecodeOpt2_fmap_if_bool;
    subst_refine_evar.

Definition ByteAligned_SimpleDecoderImpl {A}
           (f : _ -> A)
           n
  : {impl : _ & forall (v : Vector.t _ (3 + n)),
         f (fst SimpleDecoderImpl (build_aligned_ByteString v) ()) =
         impl v () }.
Proof.
  eexists _; intros.
  etransitivity.
  set_refine_evar; simpl.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecodeNat NoCache.test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecode2Char NoCache.test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  erewrite optimize_align_decode_list.
  rewrite Ifopt_Ifopt; simpl.
  etransitivity.
  eapply optimize_under_if_opt; simpl; intros.
  higher_order_reflexivity.
  reflexivity.
  Focus 2.
  clear H; intros.
  etransitivity.
  match goal with
    |- ?b = _ =>
    let b' := (eval pattern (build_aligned_ByteString v0) in b) in
    let b' := match b' with ?f _ => f end in
      eapply (@optimize_Guarded_Decode n0 _ 1 b')
  end.
  destruct n0 as [ | [ | ?] ]; intros; try omega.
  apply (@decode_word_aligned_ByteString_overflow NoCache.test_cache) with (sz := 1); auto.
  destruct n0 as [ | ?]; intros; try omega.
  higher_order_reflexivity.
  instantiate (1 := fun n1 v1 (cd0 : CacheDecode) =>
                      If NPeano.leb 1 n1 Then (Some ((Vector.hd (Guarded_Vector_split 1 n1 v1), @existT _ (Vector.t _) _ (Vector.tl (Guarded_Vector_split 1 n1 v1))), cd0)) Else None).
  simpl; find_if_inside; simpl; try reflexivity.
  pattern n0, v0; apply Vector.caseS; simpl; intros.
  unfold decode_word, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; reflexivity.
  subst_refine_evar; higher_order_reflexivity.
  higher_order_reflexivity.
Defined.

Definition ByteAligned_SimpleDecoderImpl' n :=
  Eval simpl in (projT1 (ByteAligned_SimpleDecoderImpl id n)). *)

End ASN1_Decoder_Example.

Section ASN1_Example.
  (* Suppose a company owns several sales outlets linked to a central *)
  (* warehouse where stocks are maintained and deliveries start from. The *)
  (* company requires that its protocol have the following features: *)
  (* 1) the orders are collected locally at the sales outlets ; *)
  (* 2) they are transmitted to the warehouse, where the delivery *)
  (*    procedure should be managed ; *)
  (* 3) an account of the delivery must be sent back to the sales outlets *)
  (*    for following through the client's order. *)
  (* Example taken from: http://www.itu.int/en/ITU-T/asn1/Pages/introduction.aspx. *)

  (* Item-code ::= NumericString(SIZE (7)) *)
  Definition ItemCode : ASN1_Type :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 7).

  (* Label ::= PrintableString(SIZE (1..30)) *)
  Definition Label : ASN1_Type :=
    ASN_Simple ASN_PrintableString (ASN_Size_Range 1 30).

  (* Quantity ::= CHOICE {
   unites        INTEGER,
   millimetres   INTEGER,
   milligrammes  INTEGER
} *)

  Definition Quantity : ASN1_Type :=
    ASN_Choice [ASN_Simple_UnModified ASN_Integer;
                  ASN_Simple_UnModified ASN_Integer;
                  ASN_Simple_UnModified ASN_Integer].

  (* Cents ::= INTEGER *)
  Definition Cents : ASN1_Type := ASN_Integer.

  (* Order-number ::= NumericString(SIZE (12)) *)
  Definition Order_Number : ASN1_Type :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 12).

  (* Delivery-line ::= SEQUENCE {item      Item-code,
                            quantity  Quantity *)
  Definition Delivery_Line : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element ItemCode;
                    Normal_Sequence_Element Quantity].

  (*Delivery-report ::= SEQUENCE {
  order-code  Order-number,
  delivery    SEQUENCE OF Delivery-line
} *)

  Definition Delivery_Report : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Number;
                    Normal_Sequence_Element (ASN_Structured (ASN_Sequence_Of Delivery_Line))].

  (* Date ::= NumericString(SIZE (8)) -- MMDDYYYY *)
  Definition Date : ASN1_Type  :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 8).

  (* default-country PrintableString ::= "France" *)
  Definition Default_Country : ASN1_Type_denote ASN_PrintableString := "France"%string.

  (* Client ::= SEQUENCE {
  name      PrintableString(SIZE (1..20)),
  street    PrintableString(SIZE (1..50)) OPTIONAL,
  postcode  NumericString(SIZE (5)),
  town      PrintableString(SIZE (1..30)),
  country   PrintableString(SIZE (1..20)) DEFAULT default-country
  } *)
  Definition Client : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 20));
                    Optional_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 50));
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 5));
                    Normal_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 30));
                    Default_Sequence_Element ASN_PrintableString (ASN_Size_Range 1 20) Default_Country].

  (* Card-type ::= ENUMERATED {
  cb(0), visa(1), eurocard(2), diners(3), american-express(4)} *)
  Definition Card_Type : ASN1_Type :=
    ASN_Enum [ 0; 1; 2; 3; 4].

  (* Credit-card ::= SEQUENCE {
  type         Card-type,
  number       NumericString(SIZE (20)),
  expiry-date  NumericString(SIZE (6))-- MMYYYY --
  }*)
  Definition Credit_Card : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Card_Type;
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 20));
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 6))
                 ].

  (* Payment-method ::= CHOICE {
  check        NumericString(SIZE (15)),
  credit-card Credit-card,
  cash         NULL
} *)
  Definition Payment_Method : ASN1_Type :=
    ASN_Choice [ASN_Simple ASN_NumericString (ASN_Size_Fixed 8);
                  Credit_Card;
                  ASN_Simple ASN_Null ASN_None].

  (* Order-header ::= SEQUENCE {
  number   Order-number,
  date     Date,
  client   Client,
  payment  Payment-method
} *)
  Definition Order_Header : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Number;
                    Normal_Sequence_Element Date;
                    Normal_Sequence_Element Client;
                    Normal_Sequence_Element Payment_Method].

  (* Item-code ::= NumericString(SIZE (7)) *)
  Definition Item_Code : ASN1_Type  :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 7).

  (* Order-line ::= SEQUENCE {
  item-code  Item-code,
  label      Label,
  quantity   Quantity,
  price      Cents
} *)
  Definition Order_Line : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Item_Code;
                    Normal_Sequence_Element Label;
                    Normal_Sequence_Element Quantity;
                    Normal_Sequence_Element Cents].

  (* Order ::= SEQUENCE {header  Order-header,
                    items   SEQUENCE OF Order-line
} *)
  Definition Order : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Header;
                    Normal_Sequence_Element (ASN_Sequence_Of Order_Line)].

  (*
PDU ::= CHOICE {
  question
    CHOICE {question1  Order,
            question2  Item-code,
            question3  Order-number,
            ...},
  answer
    CHOICE {answer1  Delivery-report,
            answer2  Quantity,
            answer3  Delivery-report,
            ...}
} *)

  Definition PDU : ASN1_Type :=
    ASN_Choice [ASN_Structured (ASN_Choice [Order; Item_Code; Order_Number]);
                  ASN_Structured (ASN_Choice [Delivery_Report; Quantity; Delivery_Report])
               ].

End ASN1_Example.


Require Export Groupoid Functor SetCategory NaturalTransformation ComputableCat.
Require Import Common (*Adjoint*).

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope morphism_scope.

Section FunctorFromGroupoid.
  Context `{IsTrunc 1 X}.
  Variable D : PreCategory.
  Variable objOf : X -> D.

  Let FunctorFromGroupoid_MorphismOf s d (m : Morphism (Groupoid X) s d)
  : Morphism D (objOf s) (objOf d)
    := match m with
         | idpath => Identity _
       end.

  Local Ltac t :=
    intros; simpl in *; path_induction; simpl; apply symmetry; auto with morphism.

  Lemma FunctorFromGroupoid_FCompositionOf s d d'
        (m1 : Morphism (Groupoid X) s d)
        (m2 : Morphism (Groupoid X) d d')
  : FunctorFromGroupoid_MorphismOf (m2 ∘ m1) =
    FunctorFromGroupoid_MorphismOf m2 ∘ FunctorFromGroupoid_MorphismOf m1.
  Proof.
    t.
  Defined.

  Lemma FunctorFromGroupoid_FIdentityOf x
  : FunctorFromGroupoid_MorphismOf (Identity x) = Identity (objOf x).
  Proof.
    t.
  Defined.

  Global Arguments FunctorFromGroupoid_FCompositionOf / .
  Global Arguments FunctorFromGroupoid_FIdentityOf / .
  Global Opaque FunctorFromGroupoid_FIdentityOf FunctorFromGroupoid_FCompositionOf.

  Definition FunctorFromGroupoid : Functor (Groupoid X) D
    := @Build_Functor (Groupoid X)
                      D
                      objOf
                      FunctorFromGroupoid_MorphismOf
                      FunctorFromGroupoid_FCompositionOf
                      FunctorFromGroupoid_FIdentityOf.
End FunctorFromGroupoid.

Section Obj.
  Context `{fs : Funext}.
  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Notation build_obj_functor_evar C D typ build :=
    (@Build_Functor C D
                    (fun C' : I => build (Object (Index2Cat C')) (typ C'))
                    (fun _ _ F => ObjectOf F)
                    (fun _ _ _ _ _ => idpath)
                    (fun _ => idpath)).

  Local Ltac build_obj_functor build :=
    let C := match goal with |- Functor ?C ?D => constr:(C) end in
    let D := match goal with |- Functor ?C ?D => constr:(D) end in
    let T := fresh in
    let t := fresh in
    evar (T : Type);
      cut T; subst T;
      [ intro t;
        exact (build_obj_functor_evar C D t build)
      | ];
      instantiate;
      typeclasses eauto.

  Definition SetObjectFunctor `{H0 : forall i : I, IsTrunc 0 (Index2Cat i)}
  : Functor (ComputableCat Index2Cat) SetCat.
  Proof.
    build_obj_functor BuildhSet.
  Defined.

  (** We need to force the shape of the computable cat, or else
      [PropObjectFunctor] and [PropMorphismFunctor] pick up different
      instances.  Pick this typeclass instance arbitrarily. *)

  Definition PropObjectFunctor `{H0 : forall i : I, IsHProp (Index2Cat i)}
  : Functor (@ComputableCat _ _ Index2Cat (fun _ _ => Functor_IsTrunc _ _)) PropCat.
  Proof.
    build_obj_functor hp.
  Defined.
End Obj.

Arguments SetObjectFunctor {_ _ _ _}.
Arguments PropObjectFunctor {_ _ _ _}.

Section Mor.
  Context `{Funext}.
  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Ltac build_mor_functor build :=
    let C := match goal with |- Functor ?C ?D => constr:(C) end in
    let D := match goal with |- Functor ?C ?D => constr:(D) end in
    refine (Build_Functor
              C D
              (fun C' => build { sd : Index2Cat C' * Index2Cat C' & Morphism (Index2Cat C') (fst sd) (snd sd) } _)
              (fun _ _ F => (fun sdm =>
                               existT (fun sd => Morphism _ (fst sd) (snd sd))
                                      (F (fst (projT1 sdm)), F (snd (projT1 sdm)))
                                      (MorphismOf F (s := fst (projT1 sdm)) (d := snd (projT1 sdm)) (projT2 sdm))))
              (fun _ _ _ _ _ => idpath)
              _);
      simpl; intro; apply path_forall; intros [[? ?] ?]; exact idpath.

  Definition SetMorphismFunctor `{forall i : I, IsHSet (Index2Cat i)}
  : Functor (ComputableCat Index2Cat) SetCat.
  Proof.
    build_mor_functor BuildhSet.
  Defined.

  Definition PropMorphismFunctor `{forall i : I, IsHProp (Index2Cat i)}
             `{forall i s d, IsHProp (Morphism (Index2Cat i) s d)}
  : Functor (@ComputableCat _ _ Index2Cat (fun _ _ => Functor_IsTrunc _ _)) PropCat.
  Proof.
    build_mor_functor hp.
  Defined.
End Mor.

Arguments SetMorphismFunctor {_ _ _ _}.
Arguments PropMorphismFunctor {_ _ _ _ _}.

Section dom_cod.
  Context `{Funext}.
  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Notation build_dom_cod F G fst_snd :=
    (*let F := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in
    let G := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in*)
    (Build_NaturalTransformation
       F G
       (fun _ => (fun sdf => fst_snd _ _ (projT1 sdf)))
       (fun _ _ _ => idpath)).

  Definition SetDomainNaturalTransformation
             `{forall i, IsHSet (Index2Cat i)}
    := build_dom_cod (SetMorphismFunctor (Index2Cat := Index2Cat))
                     SetObjectFunctor
                     (@fst).

  Definition SetCodomainNaturalTransformation
             `{forall i, IsHSet (Index2Cat i)}
    := build_dom_cod (SetMorphismFunctor (Index2Cat := Index2Cat))
                     SetObjectFunctor
                     (@snd).

  Definition PropDomainNaturalTransformation
             `{forall i, IsHProp (Index2Cat i)}
             `{forall i s d, IsHProp (Morphism (Index2Cat i) s d)}
    := build_dom_cod (PropMorphismFunctor (Index2Cat := Index2Cat))
                     PropObjectFunctor
                     (@fst).

  Definition PropCodomainNaturalTransformation
             `{forall i, IsHProp (Index2Cat i)}
             `{forall i s d, IsHProp (Morphism (Index2Cat i) s d)}
    := build_dom_cod (PropMorphismFunctor (Index2Cat := Index2Cat))
                     PropObjectFunctor
                     (@snd).
End dom_cod.
(*
Section disc.
(*  Local Ltac t := simpl; intros; functor_eq;
    repeat (apply functional_extensionality_dep; intro);
      hnf in *; subst;
        auto.*)

  Definition DiscreteSetFunctor : Functor SetCat Cat.
    refine (Build_Functor TypeCat Cat
      (fun O => Groupoid O : PreCategory)
      (fun s d f => InducedGroupoidFunctor (Groupoid d) f)
      _
      _
    );
    abstract t.
  Defined.

  Definition GroupoidSetFunctor : Functor SetCat Cat.
    refine (Build_Functor SetCat Cat
      (fun O => Groupoid O : PreCategory)
      (fun s d f => InducedGroupoidFunctor (Groupoid d) f)
      _
      _
    );
    abstract t.
  Defined.
End disc.
*)(*
Section Adjoints.
  Lemma GroupoidObjectIdentity : ComposeFunctors ObjectFunctor GroupoidFunctor = IdentityFunctor _.
    functor_eq.
  Qed.

  Definition GroupoidObjectAdjunction : HomAdjunction GroupoidFunctor ObjectFunctor.
    match goal with
      | [ |- HomAdjunction ?F ?G ] =>
        refine (Build_HomAdjunction F G
          (fun _ _ F => (fun x => F x))
          _
          _
        )
    end;
    try abstract trivial;
      simpl; intros.
    exists (fun f => (InducedGroupoidFunctor _ f));
      abstract (repeat match goal with
                         | _ => progress trivial
                         | _ => progress repeat (apply functional_extensionality_dep; intro)
                         | _ => hnf in *;
                           match goal with
                             | [ H : _ = _ |- _ ] => destruct H; simpl in *
                           end
                         | _ => rewrite FIdentityOf
                         | _ => progress functor_eq
                       end).
  Defined.
End Adjoints.
*)


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

(****************************************************************************)
(* This is a small library to do epsilon - N reasonning.                    *)
(* In order to use it, one only has to know the following tactics:          *)
(*                                                                          *)
(*      pose_big_enough i == pose a big enough natural number i             *)
(*   pose_big_modulus m F == pose a function m : F -> nat which should      *)
(*                           provide a big enough return value              *)
(* exists_big_modulus m F := pose_big_modulus m F; exists m                 *)
(*             big_enough == replaces a big enough constraint x <= i        *)
(*                           by true and implicity remembers that i should  *)
(*                           be bigger than x.                              *)
(*                close   == all "pose" tactics create a dummy subgoal to   *)
(*                           force the user to explictely indicate that all *)
(*                           constraints have been found                    *)
(****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module BigEnough.

Record big_rel_class_of T (leq : rel T) :=
  BigRelClass {
      leq_big_internal_op : rel T;
      bigger_than_op : seq T -> T;
      _ : leq_big_internal_op = leq;
      _ : forall i s, leq_big_internal_op i (bigger_than_op (i :: s));
      _ : forall i j s, leq_big_internal_op i (bigger_than_op s) ->
                        leq_big_internal_op i (bigger_than_op (j :: s))
}.

Record big_rel_of T := BigRelOf {
  leq_big :> rel T;
  big_rel_class : big_rel_class_of leq_big
}.

Definition bigger_than_of T (b : big_rel_of T)
           (phb : phantom (rel T) b) :=
  bigger_than_op (big_rel_class b).
Notation bigger_than leq := (@bigger_than_of _ _ (Phantom (rel _) leq)).

Definition leq_big_internal_of T (b : big_rel_of T)
           (phb : phantom (rel T) b) :=
  leq_big_internal_op (big_rel_class b).
Notation leq_big_internal leq := (@leq_big_internal_of _ _ (Phantom (rel _) leq)).

Lemma next_bigger_than T (b : big_rel_of T) i j s :
  leq_big_internal b i (bigger_than b s) ->
  leq_big_internal b i (bigger_than b (j :: s)).
Proof. by case: b i j s => [? []]. Qed.

Lemma instantiate_bigger_than T (b : big_rel_of T) i s :
  leq_big_internal b i (bigger_than b (i :: s)).
Proof. by case: b i s => [? []]. Qed.

Lemma leq_big_internalE T (b : big_rel_of T) : leq_big_internal b = leq_big b.
Proof. by case: b => [? []]. Qed.

(* Lemma big_enough  T (b : big_rel_of T) i s : *)
(*   leq_big_internal b i (bigger_than b s) -> *)
(*   leq_big b i (bigger_than b s). *)
(* Proof. by rewrite leq_big_internalE. Qed. *)

Lemma context_big_enough P T (b : big_rel_of T) i s :
  leq_big_internal b i (bigger_than b s) ->
  P true ->
  P (leq_big b i (bigger_than b s)).
Proof. by rewrite leq_big_internalE => ->. Qed.

Definition big_rel_leq_class : big_rel_class_of leq.
Proof.
exists leq (foldr maxn 0%N) => [|i s|i j s /leq_trans->] //;
by rewrite (leq_maxl, leq_maxr).
Qed.
Canonical big_enough_nat := BigRelOf big_rel_leq_class.

Definition closed T (i : T) := {j : T | j = i}.
Ltac close :=  match goal with
                 | |- context [closed ?i] =>
                   instantiate (1 := [::]) in (Value of i); exists i
               end.

Ltac pose_big_enough i :=
  evar (i : nat); suff : closed i; first do
    [move=> _; instantiate (1 := bigger_than leq _) in (Value of i)].

Ltac pose_big_modulus m F :=
  evar (m : F -> nat); suff : closed m; first do
    [move=> _; instantiate (1 := (fun e => bigger_than leq _)) in (Value of m)].

Ltac exists_big_modulus m F := pose_big_modulus m F; first exists m.

Ltac olddone :=
   trivial; hnf; intros; solve
   [ do ![solve [trivial | apply: sym_equal; trivial]
         | discriminate | contradiction | split]
   | case not_locked_false_eq_true; assumption
   | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Ltac big_enough :=
  do ?[ apply context_big_enough;
        first do [do ?[ now apply instantiate_bigger_than
                      | apply next_bigger_than]]].

Ltac big_enough_trans :=
  match goal with
    | [leq_nm : is_true (?n <= ?m)%N |- is_true (?x <= ?m)] =>
        apply: leq_trans leq_nm; big_enough; olddone
    | _ => big_enough; olddone
  end.

Ltac done := do [olddone|big_enough_trans].

End BigEnough.


Require Import Bedrock Bool.

Open Scope list_scope.

Inductive bexp :=
| Test : rvalue -> test -> rvalue -> bexp
| Not : bexp -> bexp
| And : bexp -> bexp -> bexp
| Or : bexp -> bexp -> bexp.

Fixpoint bexpD (b : bexp) (stn : settings) (st : state) : option bool :=
  match b with
    | Test rv1 t rv2 =>
      match evalRvalue stn st rv1, evalRvalue stn st rv2 with
        | Some v1, Some v2 => Some (evalTest t v1 v2)
        | _, _ => None
      end
    | Not b => match bexpD b stn st with
                 | Some b => Some (negb b)
                 | None => None
               end
    | And b1 b2 => match bexpD b1 stn st, bexpD b2 stn st with
                     | Some v1, Some v2 => Some (v1 && v2)
                     | Some false, None => Some false
                     | _, _ => None
                   end
    | Or b1 b2 => match bexpD b1 stn st, bexpD b2 stn st with
                    | Some v1, Some v2 => Some (v1 || v2)
                    | Some true, None => Some true
                    | _, _ => None
                  end
  end.

Fixpoint bexpTrue (b : bexp) (stn : settings) (st : state) : Prop :=
  match b with
    | Test rv1 t rv2 => evalCond rv1 t rv2 stn st = Some true
    | Not b => bexpFalse b stn st
    | And b1 b2 => bexpTrue b1 stn st /\ bexpTrue b2 stn st
    | Or b1 b2 => bexpTrue b1 stn st \/ (bexpFalse b1 stn st /\ bexpTrue b2 stn st)
  end

with bexpFalse (b : bexp) (stn : settings) (st : state) : Prop :=
  match b with
    | Test rv1 t rv2 => evalCond rv1 t rv2 stn st = Some false
    | Not b => bexpTrue b stn st
    | And b1 b2 => bexpFalse b1 stn st \/ (bexpTrue b1 stn st /\ bexpFalse b2 stn st)
    | Or b1 b2 => bexpFalse b1 stn st /\ bexpFalse b2 stn st
  end.

Theorem bexpD_truth : forall stn st b,
  match bexpD b stn st with
    | None => True
    | Some true => bexpTrue b stn st
    | Some false => bexpFalse b stn st
  end.
  induction b; simpl; unfold evalCond; intuition;
    repeat match goal with
             | [ H : _ = _ |- _ ] => rewrite H in *
             | [ |- context[match ?E with None => _ | _ => _ end] ] =>
               match E with
                 | context[match _ with None => _ | _ => _ end] => fail 1
                 | _ => case_eq E; intros
               end
             | [ b : bool |- _ ] => destruct b; simpl in *
             | [ |- context[if ?E then _ else _] ] => destruct E
           end; intuition; try discriminate.
Qed.

Fixpoint bexpSafe (b : bexp) (stn : settings) (st : state) : Prop :=
  match b with
    | Test rv1 t rv2 => ~(evalCond rv1 t rv2 stn st = None)
    | Not b => bexpSafe b stn st
    | And b1 b2 => bexpSafe b1 stn st /\ (bexpTrue b1 stn st -> bexpSafe b2 stn st)
    | Or b1 b2 => bexpSafe b1 stn st /\ (bexpFalse b1 stn st -> bexpSafe b2 stn st)
  end.

Theorem bexpSafe_really : forall stn st b,
  bexpSafe b stn st
  -> bexpD b stn st = None -> False.
  induction b; simpl; intuition;
    repeat match goal with
             | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
               match E with
                 | bexpD ?b ?stn ?st => specialize (bexpD_truth stn st b)
               end; destruct E
             | [ b : bool |- _ ] => destruct b
           end; intuition; try discriminate.
Qed.

Fixpoint size (b : bexp) : nat :=
  match b with
    | Test _ _ _ => 1
    | Not b => size b
    | And b1 b2 => size b1 + size b2
    | Or b1 b2 => size b1 + size b2
  end.

Import DefineStructured.

Section Cond.
  Variable imports : LabelMap.t assert.
  Hypothesis imports_global : importsGlobal imports.
  Variable modName : string.

  Fixpoint blocks (Base : N) (pre : assert) (b : bexp) (Tru Fals : N) : list (assert * block) :=
    match b with
      | Test rv1 t rv2 => (pre, (nil, Cond rv1 t rv2
        (modName, Local Tru)
        (modName, Local Fals))) :: nil
      | Not b => blocks Base pre b Fals Tru
      | And b1 b2 =>
        let Base' := (Base + N_of_nat (size b1))%N in
        blocks Base pre b1 Base' Fals
        ++ blocks Base' (fun stn_st =>
          [| bexpD b1 (fst stn_st) (snd stn_st) = Some true |] /\ pre stn_st)%PropX b2 Tru Fals
      | Or b1 b2 =>
        let Base' := (Base + N_of_nat (size b1))%N in
        blocks Base pre b1 Tru Base'
        ++ blocks Base' (fun stn_st =>
          [| bexpD b1 (fst stn_st) (snd stn_st) = Some false |] /\ pre stn_st)%PropX b2 Tru Fals
    end.

  Lemma blocks_first : forall b Base pre Tru Fals,
    exists bl, exists rest, blocks Base pre b Tru Fals = (pre, bl) :: rest.
    induction b; simpl; intuition eauto;
      match goal with
        | [ H : context[blocks _ _ ?B _ _] |- context[blocks ?Base ?pre ?B ?Tru ?False] ] =>
          specialize (H Base pre Tru False); destruct H as [ ? [ ? H ] ]; rewrite H
      end; simpl; eauto.
  Qed.

  Lemma length_size : forall b Base pre Tru Fals,
    length (blocks Base pre b Tru Fals) = size b.
    induction b; simpl; intuition; rewrite app_length; struct.
  Qed.

  Transparent evalInstrs.

  Hint Extern 1 => match goal with
                     | [ H : ?E = _ |- match ?E with None => _ | _ => _ end = _ ] =>
                       rewrite H; reflexivity
                   end.

  Lemma blocks_ok : forall imps b Base pre Tru Fals Tru_spec Fals_spec,
    (forall specs st, interp specs (pre st)
      -> exists v, bexpD b (fst st) (snd st) = Some v)
    -> LabelMap.MapsTo (modName, Local Tru) Tru_spec imps
    -> LabelMap.MapsTo (modName, Local Fals) Fals_spec imps
    -> (forall specs stn_st, bexpD b (fst stn_st) (snd stn_st) = Some true
      -> interp specs (pre stn_st)
      -> interp specs (Tru_spec stn_st))
    -> (forall specs stn_st, bexpD b (fst stn_st) (snd stn_st) = Some false
      -> interp specs (pre stn_st)
      -> interp specs (Fals_spec stn_st))
    -> (forall n pre' bl, nth_error (blocks Base pre b Tru Fals) n = Some (pre', bl)
      -> LabelMap.MapsTo (modName, Local (Base + N_of_nat n)) pre' imps)
    -> List.Forall (fun p => blockOk imps (fst p) (snd p))
    (blocks Base pre b Tru Fals).
    induction b; simpl; intuition; repeat match goal with
                                            | [ |- List.Forall _ _ ] => (constructor || apply Forall_app); simpl
                                          end.

    Ltac t := repeat match goal with
                       | [ |- blockOk _ _ _ ] => hnf; simpl; intros
                       | [ H1 : _, H2 : interp _ _ |- _ ] => destruct (H1 _ _ H2); clear H1; simpl in *
                       | [ H : Some _ = Some _ |- _ ] => injection H; clear H; intros; subst
                       | [ H : _ = _ |- _ ] => rewrite H in *
                       | [ H : match ?E with Some _ => _ | _ => _ end = Some _ |- _ ] => case_eq E; intros
                       | [ |- context[if ?E then _ else _] ] => case_eq E; intros
                       | [ H : LabelMap.MapsTo ?Which _ _ |- context[Labels _ ?Which] ] =>
                         match goal with
                           | [ H' : LabelMap.MapsTo _ _ _ |- _ ] =>
                             match H' with
                               | H => fail 1
                               | _ => clear H'
                             end
                         end
                     end; discriminate || intuition; struct;
    repeat match goal with
             | [ |- Logic.ex _ ] => eexists
             | [ |- _ /\ _ ] => split
           end; (simpl; simpl; eauto);
    try match goal with
          | [ |- interp _ _ ] =>
            propxFo;
            try match goal with
                  | [ H : _ |- _ ] => apply H; auto
                end; simpl;
            repeat match goal with
                     | [ H : _ = _ |- _ ] => rewrite H in *
                   end; trivial
        end.

    t.
    eapply IHb; intuition eauto; t.

    edestruct (blocks_first b2) as [ ? [ ] ].
    eapply IHb1; intros.
    t.
    eapply H4.
    rewrite Expr.nth_error_app_R.
    rewrite length_size.
    replace (size b1 - size b1) with 0 by omega.
    rewrite H5.
    reflexivity.
    rewrite length_size; auto.
    eauto.
    propxFo.
    t.
    t.
    eapply H4.
    rewrite Expr.nth_error_app_L.
    eauto.
    eapply nth_error_bound; eauto.

    eapply IHb2; intros.
    propxFo.
    t.
    eauto.
    eauto.
    t.
    t.
    replace (Base + N.of_nat (size b1) + N.of_nat n)%N
      with (Base + N.of_nat (size b1 + n))%N by nomega.
    eapply H4.
    rewrite Expr.nth_error_app_R.
    rewrite length_size.
    replace (size b1 + n - size b1) with n by omega.
    eauto.
    rewrite length_size; omega.

    edestruct (blocks_first b2) as [ ? [ ] ].
    eapply IHb1; intros.
    t.
    eauto.
    eapply H4.
    rewrite Expr.nth_error_app_R.
    rewrite length_size.
    replace (size b1 - size b1) with 0 by omega.
    rewrite H5.
    reflexivity.
    rewrite length_size; auto.
    t.
    propxFo.
    eapply H4.
    rewrite Expr.nth_error_app_L.
    eauto.
    eapply nth_error_bound; eauto.

    eapply IHb2; intros.
    propxFo.
    t.
    eauto.
    eauto.
    t.
    t.
    replace (Base + N.of_nat (size b1) + N.of_nat n)%N
      with (Base + N.of_nat (size b1 + n))%N by nomega.
    eapply H4.
    rewrite Expr.nth_error_app_R.
    rewrite length_size.
    replace (size b1 + n - size b1) with n by omega.
    eauto.
    rewrite length_size; omega.
  Qed.

  Ltac choosePost :=
    match goal with
      | [ _ : LabelMap.MapsTo _ _ (imps _ _ _ _ _ ?post) |- LabelMap.MapsTo _ _ (imps _ _ _ _ _ ?post') ] =>
        equate post' post
    end.

  Hint Extern 2 (LabelMap.MapsTo _ _ _) =>
    eapply imps_app_2; [ assumption | | eassumption | nomega ];
      rewrite length_size; choosePost.

  Hint Extern 1 (_ < _)%N => nomega.
  Hint Extern 1 (~(eq (A := LabelMap.key) _ _)) => lomega.

  Lemma imps_app_1 : forall k v exit post bls2 bls1 base,
    LabelMap.MapsTo k v (imps imports modName bls1 base exit post)
    -> k <> (modName, Local exit)
    -> (exit < base + N_of_nat (length bls1))%N
    -> LabelMap.MapsTo k v (imps imports modName (bls1 ++ bls2) base exit post).
    intros; eapply imps_app_1; eauto.
  Qed.

  Lemma imps_app_2 : forall k v exit post bls2 bls1 base,
    LabelMap.MapsTo k v (imps imports modName bls2 (base + N_of_nat (length bls1)) exit post)
    -> k <> (modName, Local exit)
    -> (exit < base)%N
    -> LabelMap.MapsTo k v (imps imports modName (bls1 ++ bls2) base exit post).
    intros; eapply imps_app_2; eauto.
  Qed.

  Lemma interp_eta : forall specs (pre : assert) st,
    interp specs (pre st)
    -> interp specs (pre (fst st, snd st)).
    destruct st; auto.
  Qed.

  Lemma ex_up : forall A (e : option A),
    (e = None -> False)
    -> exists v, e = Some v.
    destruct e; intuition eauto.
  Qed.

  Hint Resolve interp_eta ex_up bexpSafe_really.

  Definition Cond_ (b : bexp) (Then Else : cmd imports modName) : cmd imports modName.
    red; refine (fun pre =>
      let cout1 := Then (fun stn_st => pre stn_st /\ [|bexpTrue b (fst stn_st) (snd stn_st)|])%PropX in
      let cout2 := Else (fun stn_st => pre stn_st /\ [|bexpFalse b (fst stn_st) (snd stn_st)|])%PropX in
      {|
        Postcondition := (fun stn_st => Postcondition cout1 stn_st \/ Postcondition cout2 stn_st)%PropX;
        VerifCond := (forall stn st specs, interp specs (pre (stn, st)) -> bexpSafe b stn st)
          :: VerifCond cout1 ++ VerifCond cout2;
        Generate := fun Base Exit =>
          let Base' := (Nsucc (Nsucc Base) + N_of_nat (size b))%N in
          let cg1 := Generate cout1 Base' Base in
          let Base'' := (Base' + N_of_nat (length (Blocks cg1)))%N in
          let cg2 := Generate cout2 Base'' (Nsucc Base) in
          {|
            Entry := 2;
            Blocks := (Postcondition cout1, (nil, Uncond (RvLabel (modName, Local Exit))))
              :: (Postcondition cout2, (nil, Uncond (RvLabel (modName, Local Exit))))
              :: blocks (Nsucc (Nsucc Base)) pre b (Base' + Entry cg1) (Base'' + Entry cg2)
              ++ Blocks cg1 ++ Blocks cg2
          |}
      |}); abstract (struct;
        try match goal with
              | [ |- context[blocks ?Base ?pre ?b ?Tru ?Fals] ] =>
                solve [ let H := fresh in destruct (blocks_first b Base pre Tru Fals) as [ ? [ ? H ] ];
                  rewrite H; struct ]
              | [ H : context[imps _ ?modName _ _ ?Exit ?post] |- context[Labels _ (?modName, Local ?Exit)] ] =>
                let H' := fresh in destruct (H (modName, Local Exit) post) as [ ? [ H' ] ]; eauto; rewrite H';
                  repeat esplit; eauto; propxFo
            end;
        repeat apply Forall_app;
          (eapply blocks_ok; (intros; eauto; propxFo;
            try match goal with
                  | [ H : bexpD ?b ?stn ?st = _ |- _ ] => specialize (bexpD_truth stn st b); rewrite H; tauto
                end;
            repeat (apply LabelMap.add_2; [ lomega | ]);
            match goal with
              | [ H : nth_error ?Blocks (N.to_nat ?Entry) = Some _
                  |- LabelMap.MapsTo (_, Local (_ + ?Entry)) _ ?m ] =>
                apply imps_app_2; auto;
                  match m with
                    | context[Blocks ++ _] => apply imps_app_1
                    | _ => apply imps_app_2
                  end; auto; eapply lookup_imps in H; rewrite length_size; eauto
              | [ H : nth_error ?Blocks ?n = Some _ |- LabelMap.MapsTo (_, Local (_ + N.of_nat ?n)) _ ?m ] =>
                apply imps_app_1; auto; eapply lookup_imps; rewrite Nat2N.id; eauto
            end)) || eauto 15).
  Defined.

End Cond.

(** * Notation *)

Inductive bexp' :=
| Test' : condition -> bexp'
| Not' : bexp' -> bexp'
| And' : bexp' -> bexp' -> bexp'
| Or' : bexp' -> bexp' -> bexp'.

Coercion Test' : condition >-> bexp'.
Notation "!" := Not' : Condition_scope.
Infix "&&" := And' : Condition_scope.
Infix "||" := Or' : Condition_scope.

Delimit Scope Condition_scope with Condition.

Fixpoint makeBexp (b : bexp') (ns : list string) : bexp :=
  match b with
    | Test' c => Test (c.(COperand1) ns) c.(CTest) (c.(COperand2) ns)
    | Not' b => Not (makeBexp b ns)
    | And' b1 b2 => And (makeBexp b1 ns) (makeBexp b2 ns)
    | Or' b1 b2 => Or (makeBexp b1 ns) (makeBexp b2 ns)
  end.

Definition Cond (b : bexp') (Then Else : chunk) : chunk := fun ns res =>
  Structured nil (fun im mn H => Cond_ im H mn (makeBexp b ns)
    (toCmd Then mn H ns res) (toCmd Else mn H ns res)).

Notation "'If*' c { b1 } 'else' { b2 }" := (Cond c%Condition b1 b2)
  (no associativity, at level 95, c at level 0) : SP_scope.


(* * Constructors and Deconstructors for Comens *)

From Undecidability.TM Require Import ProgrammingTools.
From Undecidability Require Import TM.Code.CaseNat TM.Code.CaseSum TM.Code.CaseFin LM_heap_def .
From Undecidability.TM.L Require Import Alphabets.

Definition CaseCom : pTM sigCom^+ (option ACom) 1 :=
  If (CaseSum _ _)
     (Return Nop None)
     (Relabel (ChangeAlphabet (CaseFin (FinType(EqType(ACom))) ) _) Some).

Definition CaseCom_size (t : Tok) : nat -> nat :=
  match t with
  | varT n => S
  | _ => S >> S >> S
  end.

Definition CaseCom_Rel : pRel sigCom^+ (FinType (EqType (option ACom))) 1 :=
  fun tin '(yout, tout) =>
    forall (t : Tok) (s : nat),
      tin[@Fin0] ≃(;s) t ->
      match yout with
      | Some c =>
          isVoid_size tout[@Fin0] (CaseCom_size t s) /\ ACom2Com c = t
      | None => exists n, t = varT n /\ tout[@Fin0] ≃(;CaseCom_size t s) n
      end.

Definition CaseCom_steps := 11.

Lemma CaseCom_Sem : CaseCom ⊨c(CaseCom_steps) CaseCom_Rel.
Proof.
  unfold CaseCom_steps. eapply RealiseIn_monotone.
  { unfold CaseCom. TM_Correct. }
  { cbn. reflexivity. }
  {
    intros tin (yout, tout) H. intros t s HEncT. TMSimp.
    unfold sigCom in *.
    destruct H; TMSimp.
    { (* "Then" branche *)
      specialize (H t s HEncT).
      destruct t; cbn in H;now eauto.
    }
    { (* "Else" branche *)
      rename H into HCaseSum.
      simpl_tape in *; cbn in *.
      specialize (HCaseSum t s HEncT).
      destruct t; cbn in *; eauto; modpon H1; subst; eauto.
    }
  }
Qed.

(* Constructors *)

(* Use [WriteValue] for [appT], [lamT], and [retT] *)

Definition Constr_ACom (t : ACom) : pTM sigCom^+ unit 1 := WriteValue (ACom2Com t).
Definition Constr_ACom_Rel (t : ACom) : pRel sigCom^+ unit 1 :=
  Mk_R_p (ignoreParam (fun tin tout => isVoid tin -> tout ≃ ACom2Com t)).
Definition Constr_ACom_steps := 7.
Lemma Constr_ACom_Sem t : Constr_ACom t ⊨c(Constr_ACom_steps)Constr_ACom_Rel t.
Proof.
  unfold Constr_ACom_steps. eapply RealiseIn_monotone.
  - unfold Constr_ACom. apply WriteValue_Sem.
  - cbn. destruct t; cbn; reflexivity.
  - intros tin ((), tout) H. cbn in *. intros HRight.
    modpon H. contains_ext.
Qed.

Definition Constr_varT : pTM sigCom^+ unit 1 := Constr_inl _ _.
Definition Constr_varT_Rel : pRel sigCom^+ (FinType (EqType unit)) 1 :=
  Mk_R_p (ignoreParam (fun tin tout => forall (x : nat) (s : nat), tin ≃(;s) x -> tout ≃(;pred s) varT x)).
Definition Constr_varT_steps := 3.
Lemma Constr_varT_Sem : Constr_varT ⊨c(Constr_varT_steps) Constr_varT_Rel.
Proof.
  unfold Constr_varT_steps. eapply RealiseIn_monotone.
  - unfold Constr_varT. apply Constr_inl_Sem.
  - reflexivity.
  - intros tin ((), tout) H. intros n s HEncN. TMSimp. modpon H. auto.
Qed.

Arguments CaseCom : simpl never.
Arguments Constr_ACom : simpl never.
Arguments Constr_varT : simpl never.

From Undecidability Require Import Hoare.

Lemma CaseCom_SpecT_size (t : Tok) (ss : Vector.t nat 1) :
  TripleT
    ≃≃([], withSpace  [|Contains _ t |] ss)
    CaseCom_steps
    CaseCom
     (fun yout => ≃≃([match yout with Some c => t = ACom2Com c | None => exists n, t = varT n end]
        ,withSpace ([|match Com_to_sum t with inr _ => Void | inl n => Contains _ n end|]) (appSize ([|CaseCom_size t|]) ss))).
Proof.
  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply CaseCom_Sem.
  - intros tin yout tout H HEnc. specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H.
    destruct yout.
    +destruct H as [? <-]. tspec_solve. easy. destruct a;cbn in *. all:isVoid_mono.
    +destruct H as (?&->&?). cbn. tspec_solve. easy.
Qed.

Lemma Constr_varT_SpecT_size (n : nat) (ss : Vector.t nat 1) :
  TripleT
    ≃≃([], withSpace  [|Contains _ n |] ss)
    Constr_varT_steps
    Constr_varT
     (fun yout => ≃≃([],withSpace ([|Contains _ (varT n)|]) (appSize ([|pred|]) ss))).
Proof.
  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply Constr_varT_Sem.
  - intros tin yout tout H HEnc. specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H.
    destruct yout. tspec_solve.
Qed.

Ltac hstep_Com :=
  lazymatch goal with
  | [ |- TripleT ?P ?k CaseCom ?Q ] => eapply CaseCom_SpecT_size
  | [ |- TripleT ?P ?k Constr_varT ?Q ] => eapply Constr_varT_SpecT_size
  end.

Smpl Add hstep_Com : hstep_Spec.


Require Export Iron.Language.SystemF2Data.Type.Exp.
Require Export Iron.Language.SystemF2Data.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Data.Type.Def.DaCon.

(********************************************************************)
(* Definitions.
   Carries meta information about type and data constructors. *)
Inductive def  : Type :=
 (* Definition of a data type constructor *)
 | DefDataType
   :  tycon        (* Name of data type constructor *)
   -> list ki      (* Kinds of type parameters *)
   -> list datacon (* Data constructors that belong to this type *)
   -> def

 (* Definition of a data constructor *)
 | DefData
   :  datacon      (* Name of data constructor *)
   -> list ty      (* Types of arguments *)
   -> tycon        (* Type constructor of constructed data *)
   -> def.
Hint Constructors def.

(* Definition environment.
   Holds the definitions of all current type and data constructors. *)
Definition defs  := list def.

(* Lookup the def of a given type constructor.
   Returns None if it's not in the list. *)
Fixpoint getTypeDef (tc: tycon) (ds: defs) : option def :=
 match ds with
 | ds' :> DefDataType tc' _ _ as d
 => if tycon_beq tc tc'
     then  Some d
     else  getTypeDef tc ds'

 | ds' :> _ => getTypeDef tc ds'
 | Empty    => None
 end.

Lemma getTypeDef_in
 :  forall tc ds ddef
 ,  getTypeDef tc ds = Some ddef
 -> In ddef ds.
Proof.
 intros.
 induction ds.
 - false.
 - destruct a; burn.
Qed.
Hint Resolve getTypeDef_in.

(* Lookup the def of a given data constructor.
   Returns None if it's not in the list. *)
Fixpoint getDataDef (dc: datacon) (ds: defs) : option def :=
 match ds with
 | ds' :> DefData dc' _ _ as d
 => if datacon_beq dc dc'
     then  Some d
     else  getDataDef dc ds'

 | ds' :> _ => getDataDef dc ds'
 | Empty    => None
 end.

Lemma getDataDef_in
 :  forall tc ds ddef
 ,  getDataDef tc ds = Some ddef
 -> In ddef ds.
Proof.
 intros.
 induction ds.
 - false.
 - destruct a; burn.
Qed.
Hint Resolve getDataDef_in.


Require Import Coq.Relations.Relations.

Require Export CatSem.CAT.retype_functor_po.
Require Export CatSem.CAT.rmonad_gen_type_po.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Notation "^ f" := (lift (M:= opt_monad _) f) (at level 5).

Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin.

Hint Unfold lift : fin.
Hint Extern 1 (_ = _) => f_equal : fin.

Notation "V *" := (opt (T:=unit) _ V) (at level 5).

Definition TT := ITYPE unit.

Lemma l_eq (V W : TT) (f g : forall t, V t -> W t) r:
   (forall t v, f t v = g t v) ->
       (forall t (v : opt r V t),
       lift (M:=opt_monad r) f t v = ^g t v).
Proof.
  intros.
  destruct v;
  unfold lift;
  simpl;
  auto.
  rewrite H.
  auto.
Qed.

Inductive ULC (V : TT) : TT :=
  | Var : forall t, V t -> ULC V t
  | Abs : forall t : unit, ULC (opt t V) t -> ULC V t
  | App : forall t, ULC V t -> ULC V t -> ULC V t.

Lemma App_eq V t (M M' N N' : ULC V t) :
  M = M' -> N = N' -> App M N = App M' N'.
Proof.
  intros.
  rewrite H.
  rewrite H0.
  auto.
Qed.

Fixpoint rename V W (f : V ---> W) t (y : ULC V t) :
          ULC W t :=
  match y with
  | Var _ v => Var (f _ v)
  | Abs _ v => Abs (rename ^f v)
  | App _  s t => App (rename f s) (rename f t)
  end.

Definition inj u V := rename (V:=V) (W:= opt u V)
                (@some unit u V).

Definition _shift (u : unit) (V W : TT) (f : V ---> ULC W) :
         V*  ---> ULC (W*) :=
   fun t v =>
   match v in (opt _ _ y) return (ULC (W *) y) with
   | some t0 p => inj u (f t0 p)
   | none => Var (none u W)
   end.

Fixpoint _subst V W (f : V ---> ULC W) t (y : ULC V t) :
         ULC W t :=
  match y with
  | Var _ v => f _ v
  | Abs _ v => Abs (_subst (_shift f) v)
  | App _ s t => App (_subst f s) (_subst f t)
  end.

Definition substar (u : unit) (V : TT) (M : ULC V u) :
           ULC (opt u V) ---> ULC V :=
 _subst (fun t (y : opt u V t) => match y with
         | none => M
         | some _ v => Var v
         end).

Notation "M [*:= N ]" := (substar N M) (at level 50).

(** Notations for functions *)
Notation "y //- f" := (rename f y)
  (at level 42, left associativity).
Notation "y >- f" := (_shift f y) (at level 40).
Notation "y >>= f" := (_subst f y)
  (at level 42, left associativity).

Lemma rename_eq : forall (V : TT) (t : unit) (v : ULC V t)
         (W : TT) (f g : V ---> W),
     (forall t y, f t y = g t y) -> v //- f = v //- g.
Proof.
  intros V t v.
  induction v;
  intros;
  simpl.
  rewrite H;
  auto.

  apply f_equal.
  apply IHv.
  simpl in *.
  intros.
  destruct t.
  destruct t0.
  assert (H':= l_eq (r:=tt) H (t:=tt) y).
  simpl in *.
  rewrite <- H'.
  auto.

  rewrite (IHv1 _ _ _ H).
  rewrite (IHv2 _ _ _ H).
  auto.
Qed.

Hint Resolve rename_eq l_eq : fin.
Hint Rewrite rename_eq l_eq : fin.

Lemma rename_comp V t (y : ULC V t) W
         (f : V ---> W) Z (g : W ---> Z):
 y //- (fun s y => g s (f s y)) =  y //- f //- g.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.

  apply f_equal.
  rewrite <- IHy.
  apply rename_eq.
  intros r y0.
  destruct y0;
  fin.
Qed.

Lemma rename_id_eq V t (y : ULC V t) (f : V ---> V)
        (H : forall t v, f t v = v) :
    y //- f = y.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.
  apply f_equal.
  apply IHy.
  intros r v;
  destruct v;
  fin. unfold lift.
  fin.
Qed.

Lemma rename_id V t (y : ULC V t) : y //- id _ = y .
Proof.
  intros V t y.
  apply rename_id_eq.
  fin.
Qed.

Lemma _shift_eq u V W (f g : V ---> ULC W)
     (H : forall t v, f t v = g t v) t (y : opt u V t) :
          y >- f = y >- g.
Proof.
  intros u V W f g H t v.
  destruct v;
  fin.
Qed.

Hint Resolve  rename_id _shift_eq : fin.
Hint Rewrite  rename_id _shift_eq : fin.

Lemma shift_var u (V : TT) t (y : opt u V t) :
       y >- @Var _ = Var y.
Proof.
  intros u V t y;
  induction y;
  fin.
Qed.

Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.

Lemma var_lift_shift (u : unit) V W
    (f : V ---> W) t (y : opt u V t) :
     Var (^f _ y) = y >- (f ;; @Var _ ).
Proof.
  intros u V W f t y;
  induction y; fin.
Qed.

Hint Resolve var_lift_shift : fin.

Lemma shift_lift u V W Z (f : V ---> W)
         (g : W ---> ULC Z) t (y : opt u V t) :
      (^f _ y) >- g = y >- (f ;; g).
Proof.
  intros u V W Z f g t y.
  induction y; fin.
Qed.

Hint Resolve shift_lift : fin.
Hint Rewrite shift_lift : fin.

Lemma subst_eq V t (y : ULC V t)
      W (f g : V ---> ULC W)
       (H : forall t y, f t y = g t y):
      y >>= f = y >>= g.
Proof.
  intros V t y.
  induction y;
  fin.
Qed.

Hint Resolve subst_eq : fin.
Hint Rewrite subst_eq : fin.

Obligation Tactic := unfold Proper; red; fin.

Program Instance subst_oid V W :
 Proper (equiv ==> equiv (Setoid:=mor_oid (ULC V) (ULC W)))
                (@_subst V W).

Lemma subst_var (V : TT) :
    forall t (v : ULC V t), v >>= (@Var V) = v .
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy at 2.
  apply subst_eq.
  fin.
Qed.

Lemma subst_eq_rename V t (v : ULC V t) W
            (f : V ---> W)  :
     v //- f  = v >>= (f ;; Var (V:=W)).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_shift a V W Z (f : V ---> ULC W)
           (g : W ---> Z) t
       (y : opt a V t) :
    (y >- f) //- ^g = y >- (f ;; rename g).
Proof.
  intros a V W Z f g t y.
  induction y;
  fin.
  unfold inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  fin.
Qed.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Hint Unfold inj : fin.

Lemma rename_subst V t (v : ULC V t) W Z (f : V ---> ULC W)
      (g : W ---> Z) :
      (v >>= f) //- g  = v >>= (f ;; rename g).
Proof.
  intros V t y.
  induction y;
  fin.
  rewrite IHy.
  apply f_equal.
  apply subst_eq.
  intros tr z;
  destruct z;
  simpl; auto.
  unfold inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  apply rename_eq.
  fin.
Qed.

Lemma subst_rename V t (v : ULC V t) W Z (f : V ---> W)
      (g : W ---> ULC Z) :
      v //- f >>= g = v >>= (f ;; g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_substar V u t (v : ULC (opt u V) t) W
       (f : V ---> W) N:
     v [*:= N] //- f = (v //- ^f) [*:= N //- f ].
Proof.
  intros.
  unfold substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  intros t0 z ;
  destruct z ;
  fin.
Qed.

Hint Rewrite subst_rename rename_subst : fin.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Lemma subst_shift_shift (u:unit) V (t : unit)
      (v : opt u V t)
         W Z (f: V ---> ULC W) (g: W ---> ULC Z):
    (v >- f) >>= (_shift g)  =
             v >- (f ;; _subst g).
Proof.
  intros u V t v.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
  unfold inj.
  rewrite subst_rename.
  fin.
Qed.

Hint Resolve subst_shift_shift : fin.
Hint Rewrite subst_shift_shift : fin.

Lemma subst_subst V t (v : ULC V t) W Z
             (f : V ---> ULC W)
             (g : W ---> ULC Z) :
     v >>= f >>= g = v >>= (f;; _subst g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
  unfold inj.
  fin.
Qed.

Lemma lift_rename V t (s : ULC V t) W (f : V ---> W) :
          s >>= (fun t z => Var (f t z)) = s //- f.
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_rename V W Z (f : V ---> W)
        (g : W ---> Z) t (v : ULC V t) :
  v //- f //- g = v //- (f ;; g).
Proof.
  intros.
  repeat rewrite <- lift_rename.
  rewrite subst_subst.
  fin.
Qed.

Lemma subst_var_eta (V:TT) t (v:ULC V t):
        v >>= (fun t z => @Var V t z) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv1. rewrite IHv2; auto.
Qed.

Lemma subst_substar (V W : TT)
       t (M: ULC (opt t V) t) (N:ULC V t)
      (f:forall t, V t -> ULC W t):
   M [*:=N]  >>= f = (M >>= _shift f) [*:= (N >>= f)].
Proof.
  intros V W t M N f.
  unfold substar. simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  intros t0 y.
  simpl.
  destruct y. unfold _shift.
  unfold inj.
  simpl.
  rewrite subst_rename. simpl.
  rewrite (subst_var_eta (f t0 v)). auto.
  simpl.
  apply subst_eq; auto.
Qed.

Hint Resolve subst_var subst_subst lift_rename : fin.
Hint Rewrite subst_subst lift_rename: fin.

Ltac sim := unfold substar; simpl ;
            unfold inj; simpl.

Section Relations_on_ULC.

Reserved Notation "x :> y" (at level 70).

Variable rel : forall (V:TT) t, relation (ULC V t).

Inductive ULCpropag (V: TT)
       : forall t, relation (ULC V t) :=
| relorig : forall t (v v': ULC V t), rel v v' ->  v :> v'
| relApp1: forall t (M M' : ULC V t) N,
       M :> M' -> App M N :> App M' N
| relApp2: forall t (M:ULC V t) N N',
      N :> N' -> App M N :> App M N'
| relAbs: forall t (M M':ULC (opt t V) t),
      M :> M' -> Abs M :> Abs M'

where "y :> z" := (@ULCpropag _ _ y z).

Notation "y :>> z" :=
  (clos_refl_trans_1n _ (@ULCpropag _ _ ) y z) (at level 50).

Variable V : TT.
Variable t : unit.

(** these are some trivial lemmata  which will be used later *)

Lemma cp_App1 (M M': ULC V t) N :
    M :>> M' -> App M N :>> App M' N.
Proof.
  intros. generalize N.
  induction H. constructor.
  intros. constructor 2 with (App y N0); auto.
  constructor 2. auto.
Qed.

Lemma cp_App2 (M : ULC V t) N N':
    N :>> N' -> App M N :>> App M N'.
Proof.
  intros. generalize M.
  induction H. constructor.
  intros. constructor 2 with (App M0 y); auto.
  constructor 3. auto.
Qed.

Lemma cp_Abs (M M': ULC (opt t V) t ):
      M :>> M' -> Abs M :>> Abs M'.
Proof.
  intros. induction H. constructor.
  constructor 2 with (Abs y); auto.
  constructor 4. auto.
Qed.

End Relations_on_ULC.

(** Beta reduction *)

Reserved Notation "a >> b" (at level 70).

Inductive beta (V : TT): forall t, relation (ULC V t) :=
| app_abs : forall t (M: ULC (opt t V) t) N,
               beta (App (Abs M) N) (M [*:= N]).

Definition beta_star := ULCpropag beta.

Definition beta_rel :=
   fun (V : TT) t => clos_refl_trans_1n _ (@beta_star V t).

Notation "a >> b" := (beta_rel a b).

(** lemmata *)

Lemma beta_eq : forall V t (M N : ULC V t),
   M = N -> M >> N.
Proof.
  intros.
  destruct H.
  reflexivity.
Qed.

Lemma beta_trans : forall V t (M N K : ULC V t),
 M >> K -> N >> M -> N >> K.
Proof.
  intros.
  transitivity M;
  auto.
Qed.

Lemma beta_beta : forall V t M (N : ULC V t),
   App (Abs M) N >> M [*:= N].
Proof.
  intros.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.

Lemma app_abs_red V t (M : ULC _ t) (N M' : ULC V t) :
   M [*:= N ] >> M' -> App (Abs M) N >> M'.
Proof.
  intros.
  apply (beta_trans H).
  apply beta_beta.
Qed.

Definition eta_red V t (M : ULC V t) :=
 Abs (App (inj t M) (Var (V:=V *) (none t (V) ))) >> M.

Lemma App1_app_abs V t M M' (N : ULC V t) K:
  beta_rel (App (M [*:= N]) M') K ->
  beta_rel (App (App (Abs M) N) M') K.
Proof.
  intros.
  transitivity (App (M[*:=N]) M').
  apply cp_App1.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
  auto.
Qed.

Lemma App2_app_abs V t M M' (N : ULC V t) K:
  beta_rel (App M' (M [*:= N])) K ->
  beta_rel (App M' (App (Abs M) N)) K.
Proof.
  intros.
  transitivity (App M' (M[*:=N])).
  apply cp_App2.
  apply beta_beta.
  auto.
Qed.

Lemma App1_App1_app_abs V t M  N K L (R : ULC V t):
  beta_rel (App (App (M[*:=N]) K) L) R ->
  beta_rel (App (App (App (Abs M) N) K) L) R.
Proof.
  simpl; intros.
  transitivity (App (App (M [*:=N]) K) L).
  apply cp_App1.
  apply cp_App1.
  apply beta_beta.
  auto.
Qed.

Lemma App1_App1_App1_app_abs V t M N K L J (R : ULC V t):
  beta_rel (App (App (App (M[*:=N]) K) L) J) R ->
  beta_rel (App (App (App (App (Abs M) N) K) L) J) R.
Proof.
  simpl; intros.
  apply (beta_trans H).
  do 3 apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_App1_Abs_app_abs V t M N K L (R : ULC V t):
beta_rel (Abs (Abs (App (App (Abs (M[*:=N])) K) L))) R ->
beta_rel (Abs (Abs (App (App (Abs (App (Abs M) N)) K) L))) R.
Proof.
  intros.
  apply (beta_trans H).
  repeat apply cp_Abs.
  repeat apply cp_App1.
  apply cp_Abs.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_App1_app_abs V t M N K L (R : ULC V t):
beta_rel (Abs (Abs (App (App ((M[*:=N])) K) L))) R ->
beta_rel (Abs (Abs (App (App ((App (Abs M) N)) K) L))) R.
Proof.
  intros.
  apply (beta_trans H).
  repeat apply cp_Abs.
  repeat apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_app_abs V t M N K (R : ULC V t) :
beta_rel (Abs (Abs (App (M[*:=N]) K))) R ->
beta_rel (Abs (Abs (App (App (Abs M) N) K))) R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_app_abs V t M N (R : ULC V t) :
beta_rel (Abs (Abs (M[*:=N]))) R ->
beta_rel (Abs (Abs (App (Abs M) N))) R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply beta_beta.
Qed.

Lemma App2_App1_app_abs V t M N K L (R:ULC V t) :
  App K (App (M [*:=N]) L) >> R ->
  App K (App (App (Abs M) N) L) >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_Abs_App2_App1_app_abs V t M N K L J
       (R:ULC V t):
   Abs (Abs (App (Abs (App K
             (App (M[*:=N]) J))) L)) >> R ->
   Abs (Abs (App (Abs (App K
     (App (App (Abs M) N) J))) L)) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App1.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_Abs_App2_app_abs V t M N K L
       (R:ULC V t):
   Abs (Abs (App (Abs (App K
             (M[*:=N]) )) L)) >> R ->
   Abs (Abs (App (Abs (App K
      (App (Abs M) N) )) L)) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App1.
  apply cp_Abs.
  apply cp_App2.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App2_app_abs V t M N K (R:ULC V t) :
  Abs (Abs (App K (M[*:=N]))) >> R ->
  Abs (Abs (App K (App (Abs M) N))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App2.
  apply beta_beta.
Qed.

Lemma App2_Abs_Abs_App2_App1_app_abs V t M N K L J (R:ULC V t) :
   App K (Abs (Abs (App L (App (M[*:=N]) J)))) >> R ->
   App K (Abs (Abs (App L (App (App (Abs M) N) J)))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App2.
  do 2 apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App1_App1_App1_app_abs V t M N K L J (R:ULC V t) :
  Abs (Abs (App (App (App (M [*:=N]) K) L) J)) >> R ->
  Abs (Abs (App (App (App (App (Abs M) N) K) L) J)) >> R .
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  do 3 apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App2_App1_App1_app_abs V t M N K L J (R:ULC V t):
   Abs (Abs (App K (App (App (M[*:=N]) L) J))) >> R ->
   Abs (Abs (App K (App (App (App (Abs M) N) L) J))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App2.
  do 2 apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_Abs_App2_App1_app_abs V t M N K L (R:ULC V t):
  Abs (Abs (App K (App (M[*:=N]) L))) >> R ->
  Abs (Abs (App K (App (App(Abs M) N) L))) >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma Abs_App2_app_abs V t M N K (R : ULC V t) :
   Abs (App K (M[*:=N])) >> R ->
   Abs (App K (App (Abs M) N)) >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_Abs.
  apply cp_App2.
  apply beta_beta.
Qed.

Lemma App1_Abs_app_abs V t M N K (R:ULC V t) :
  App (Abs (M[*:=N])) K >> R ->
  App (Abs (App (Abs M) N)) K >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App1.
  apply cp_Abs.
  apply beta_beta.
Qed.

Lemma App1_Abs_App2_App1_app_abs V t M N K L J (R:ULC V t) :
  App (Abs (App K (App (M[*:=N]) L))) J >> R ->
  App (Abs (App K (App (App (Abs M) N) L))) J >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App1.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma App1_Abs_Abs_App2_App1_app_abs V t M N K L J (R:ULC V t) :
  App (Abs (Abs (App K (App (M[*:=N]) L)))) J >> R ->
  App (Abs (Abs (App K (App (App (Abs M) N) L)))) J >> R.
Proof.
  intros.
  apply (beta_trans H).
  apply cp_App1.
  do 2 apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply beta_beta.
Qed.

Lemma App1_App1_Abs_app_abs V t M N K L (R:ULC V t) :
  App (App (Abs (M[*:=N])) K) L >> R ->
  App (App (Abs (App (Abs M)N)) K) L >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_App1.
  apply cp_Abs.
  apply beta_beta.
Qed.

Lemma App1_App1_Abs_Abs_app_abs V t M N K L (R:ULC V t) :
  App (App (Abs (Abs (M[*:=N]))) K) L >> R ->
  App (App (Abs (Abs (App (Abs M)N))) K) L >> R.
Proof.
  intros.
  apply (beta_trans H).
  do 2 apply cp_App1.
  do 2 apply cp_Abs.
  apply beta_beta.
Qed.

Obligation Tactic := idtac.

Program Instance ULCBETA_struct (V : TT) :
   ipo_obj_struct (ULC V) := {
 IRel t := @beta_rel V t
}.
Next Obligation.
Proof.
  constructor.
  constructor.
  assert (H':= @clos_rt_is_preorder _ (@beta_star V t)).
  unfold beta_rel in *.
  unfold Transitive.
  intros.
  destruct H' as [H1 H2].
  unfold transitive in H2.
  simpl in *.
  apply trans_rt1n.
  apply H2 with y;
    apply rt1n_trans;
    auto.
Qed.

Definition ULCBETA (V: TT) : IPO unit :=
    Build_ipo_obj (ULCBETA_struct V ).

Program Instance Var_s (V : TT) :
    ipo_mor_struct (a:=SM_ipo _ V) (b:=ULCBETA V) (Var (V:=V)).
Next Obligation.
Proof.
  intros V t.
  unfold Proper;
  red.
  simpl.
  intros y z H.
  induction H.
  reflexivity.
Qed.

Definition VAR V := Build_ipo_mor (Var_s V).

Lemma rename_beta (V W : TT)(f : V ---> W) t (v w : ULC V t):
     v >> w -> v //- f >> w //- f.
Proof.
  intros V W f t v w H.
  generalize dependent W.
  induction H.
  reflexivity.
  intros W f.
  transitivity (y //- f);
  auto.
  clear dependent z.
  generalize dependent W.
  induction H.
  induction H.

  simpl.
  intros W f.
  apply app_abs_red.
  simpl.
  unfold substar.
  rewrite  rename_subst.
  simpl.
  rewrite subst_rename.
  simpl.
  apply beta_eq.
  apply (subst_eq M).
  intros s y;
  destruct y as [s y| ];
  simpl;
  auto.

  intros W f.
  simpl.
  apply cp_App1.
  apply IHULCpropag.
  intros W f.
  simpl.
  apply cp_App2.
  apply IHULCpropag.
  simpl.
  intros W f.
  apply cp_Abs.
  apply IHULCpropag.
Qed.

Program Instance subst_s (V W : TT)
     (f : SM_ipo _ V ---> ULCBETA W) :
   ipo_mor_struct
     (a:=ULCBETA V) (b:=ULCBETA W) (_subst f).
Next Obligation.
Proof.
  intros V W f t.
  unfold Proper;
  red.
  intros y z H.
  generalize dependent W.
  induction H;
  simpl;
  intros.
  constructor.
  transitivity (_subst f y);
  try apply IHclos_refl_trans_1n.
  clear dependent z.

    generalize dependent W.
  induction H;
  simpl;
  intros.

  Focus 2.
  apply cp_App1.
  apply IHULCpropag.
  Focus 2.
  apply cp_App2.
  apply IHULCpropag.
  Focus 2.
  apply cp_Abs.
  simpl in *.
  apply (IHULCpropag _ (SM_ind
            (V:=opt _ V) (W:=ULCBETA (opt t W))
      (fun t y => _shift f y))).

  generalize dependent W.
    induction H;
    simpl;
    intros.
    apply clos_refl_trans_1n_contains.
    apply relorig.
    assert (H:=app_abs (_subst (_shift f) M) (_subst f N)).
    rewrite subst_substar.
    auto.
Qed.

Lemma subst_beta (V W : TT) (f : V ---> ULC W) t
    (v w : ULC V t) :
   v >> w -> v >>= f >> w >>= f.
Proof.
  intros.
  assert (H':= subst_s _ _ (SM_ind (W:= ULCBETA W) f)).
  apply H'.
  simpl.
  auto.
Qed.

Definition SUBST V W f := Build_ipo_mor (subst_s V W f).

Obligation Tactic := fin.

Program Instance ULCBETAM_s : RMonad_struct (SM_ipo unit) ULCBETA := {
   rweta := VAR;
   rkleisli a b f := SUBST f
}.
Next Obligation.
Proof.
  unfold Proper;
  red;
  fin.
Qed.

Definition ULCBETAM : RMonad (SM_ipo unit) := Build_RMonad ULCBETAM_s.

Lemma rename_lift V t (v : ULC V t) W (f : V ---> W) :
       v //- f = rlift ULCBETAM f _ v.
Proof.
  unfold lift;
  fin.
Qed.
(*
Hint Rewrite lift_rename : fin.
*)

Lemma shift_shift r s V W (f : SM_ipo _ V ---> ULCBETAM W)
                (y : (opt r V) s) :
   sshift_ (P:=ULCBETAM) (W:=W) f y = y >- f .
Proof.
  intros r  s V W f y.
  destruct y as [t y | ];
  simpl;
  unfold inj;
  fin.
Qed.

Hint Resolve shift_shift : fin.
Hint Rewrite shift_shift : fin.

(* the Turing fixpoint operator Theta.
   it has (Theta g) --> g (Theta g)
*)
Definition ULC_theta_h (V : TT) : ULC V tt :=
 Abs(
  Abs(
   App
    (Var (none tt _ ))
    (App
      (App
        (Var (some tt (none tt V)))
        (Var (some tt (none tt V))))
      (Var (none tt _)))
)).

Definition ULC_theta (V : TT) : ULC V tt :=
App (ULC_theta_h V) (ULC_theta_h V).

(* Y = \f. (\x. f (x x)) (\x. f (x x))  *)

Definition ULC_fix (V : TT) : ULC V tt :=
 Abs (
   App
    (Abs
      (App
        (Var (some tt (none tt V)))
        (App
          (Var (none tt (opt tt V)))
          (Var (none tt (opt tt V))))
     ))
    (Abs
      (App
        (Var (some tt (none tt V)))
        (App
          (Var (none tt (opt tt V)))
          (Var (none tt (opt tt V))))
     ))

).

(* not: [m+1] =
     \f.\n. ([m] f) (f n)

instead : [m+1] = \fn. f ([m] f n)
*)

(* note : [m] has 2*m redexes in it *)

Fixpoint ULC_Nat (n : nat) (V : TT) := match n with
| 0 => Abs (Abs (Var (none tt (opt tt V))))
| S n' =>
    Abs(
     Abs (
      App
       (Var (some tt (none tt _ )))
       (App
         (App
           (ULC_Nat n' _ )
           (Var (some tt (none tt _ ))))
         (Var (none tt _ )))))
end.

(* naturals are constant under renaming *)

Lemma ulc_nats_rename n :
  forall (V W : TT) (f : V ---> W),
     ULC_Nat n W = ULC_Nat n V //- f.
Proof.
  induction n.
  simpl.
  intros.
  unfold lift.
  simpl.
  auto.

  simpl.
  intros.
  apply f_equal.
  apply f_equal.
  apply f_equal.
  rewrite <- IHn.
  auto.
Qed.

(* nats are constant under substitution *)

Lemma ulc_nats_subst n :
 forall (V W : TT)
       (f : V ---> ULC W),
     ULC_Nat n W = ULC_Nat n V >>= f.
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  rewrite <- (IHn (V * *)).
  reflexivity.
Qed.

(* - pow 0 T = \x.x
   - pow Sn T = \x. T ((pow n T) x)

   - pow 1 T = \x. T ((pow 0 T) x) =
             = \x. T (\y.y x) -> \x. T x

   - pow 2 T = \x. T ((pow 1 T) x) =
             -> \x. T ((\x.Tx) x) ->
                \x. T (T x)
*)

Fixpoint pow n V (T : ULC V tt) : ULC V tt :=
  match n return ULC V tt with
  | 0 => Abs (Var (none tt V ))
  | S n' => Abs (t:=tt)
      (App
        (inj _ T)
        (App
          (inj tt (pow n' T))
          (Var (none tt _))))
  end.

(* lets build  fun f x => App f (f^n x) *)
(* - ULC_nat_skel 0 f y = y
   - ULC_nat_skel Sn f y = App f (...)
*)

Fixpoint ULC_nat_skel n V
   (f : ULC (opt tt V) tt)
   (y : ULC (opt tt (opt tt V)) tt) :
      ULC (opt tt (opt tt V)) tt :=
match n with
| 0 => y
| S n' => App (inj tt f) (ULC_nat_skel n' f y)
end.

(*  take the to-be-bound-next free variables as f and y *)

Definition ULC_nat_sk n V :=
 ULC_nat_skel n (Var (none tt V)) (Var (none tt (V*))).

(*  have free variables f, y

   - ULC_Nat_noredex 0 = y
   - ULC_Nat_noredex Sn = f (...)
*)

Fixpoint ULC_Nat_noredex n V t :=
  match n with
  | 0 => Var (V:=opt t (opt t V)) (none t (opt t V))
  | S n' => App (Var (some t (none t V)))
                   (ULC_Nat_noredex n' V t)
  end.

(* ULC_nat_sk = ULC_Nat_noredex *)
(* both have two free variables f, y
*)

Lemma ULC_nat_sk_ULC_Nat_noredex n V :
   ULC_nat_sk n V = ULC_Nat_noredex n V tt.
Proof.
  induction n.
  reflexivity.
  simpl; intros.
  rewrite <- IHn.
  reflexivity.
Qed.

(* we bind the free variables f, y
   in order to define the natural numbers
*)

Definition ULC_Nat_nox n V t : ULC V t :=
  Abs (
   Abs (ULC_Nat_noredex n V t)).

Definition ULC_N n V : ULC V tt :=
  Abs (Abs (ULC_nat_sk n V)).

Lemma ULC_nat_skel_rename_lift n V W
     (f : V* ---> W*) a b :
  ULC_nat_skel n a b //- (^f) =
         ULC_nat_skel n (a//-f) (b//-^f).
Proof.
induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq;
  auto.
  unfold inj.
  repeat rewrite rename_rename.
  fin.
Qed.

Lemma ULC_nat_skel_rename_some n V
       a b :
   ULC_nat_skel n a b //- (some tt (A:=V * *)) =
     ULC_nat_skel n (inj _ a) (b //- some tt (A:= V * * )).
Proof.
  simpl.
  intros.
  induction n.
  reflexivity.
  simpl.
  apply App_eq.
  auto.
  simpl.
  auto.
Qed.

Lemma ULC_N_skel_subst_shift n V W
   (f : V* ---> ULC W*) a b :
  ULC_nat_skel n a b >>= (_shift f) =
  ULC_nat_skel n (a>>= f) (b>>=(_shift f)).
Proof.
  induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq;
  auto.
  unfold inj;
  simpl.
  rewrite rename_subst.
  rewrite subst_rename.
  fin.
Qed.

(* is less useful than it might seem *)

Lemma ULC_N_skel_substar n V (M : ULC (V* * ) tt)
                (a : ULC (V* * ) tt)
                (b:ULC (opt tt (opt tt V) * ) tt) :
  inj tt (ULC_nat_skel n (a) b [*:= M]) =
  ( ULC_nat_skel n a ((inj tt (b[*:= M])))).
Proof.
  induction n.
  reflexivity.
  simpl;
  intros.
  rewrite <- IHn.
  unfold inj;
  simpl.
  apply App_eq;
  auto.
  rewrite subst_rename.
  rewrite rename_subst.
  simpl.
  rewrite rename_lift.
  simpl.
  auto.
Qed.

(* renaming with 2 times lifted map doesn't change
   ULC_nat_sk (which has only 2 free vars)
*)

Lemma ULC_N_sk_rename n V W (f : V ---> W)  :
  ULC_nat_sk n V //- ^(^f) = ULC_nat_sk n _ .
Proof.
  induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq.
  auto.
  rewrite IHn.
  auto.
Qed.

(* similar for substitution with 2times shifted map
*)

Lemma ULC_N_sk_subst n V W (f : V ---> ULC W) :
  ULC_nat_sk n V >>= _shift (_shift f) =
    ULC_nat_sk n W .
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  rewrite IHn.
  unfold inj.
  simpl.
  reflexivity.
Qed.

(* the naturals defined with skel are constant under
   substitution
*)

Lemma ULC_N_subst n V W (f : V ---> ULC W) :
  ULC_N n V >>= f = ULC_N n W.
Proof.
  simpl.
  intros.
  rewrite ULC_N_sk_subst.
  auto.
Qed.

(* the following lemma are the same as for skel.
   no surprise, the defs are equal
*)

Lemma ULC_Nat_noredex_rename n V W (f : V ---> W) t :
  ULC_Nat_noredex n V t //- ^(^f) = ULC_Nat_noredex n _ t.
Proof.
  induction n.
  reflexivity.
  intros;
  simpl in *.
  apply App_eq.
  auto.
  rewrite IHn.
  auto.
Qed.

Lemma ULC_Nat_noredex_subst n V W (f : V ---> ULC W) t :
  ULC_Nat_noredex n V t >>= _shift (_shift f) =
    ULC_Nat_noredex n W t.
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  apply App_eq;
  auto.
Qed.

Lemma ULC_Nat_nox_subst n V W (f : V ---> ULC W) t:
  ULC_Nat_nox n V t >>= f = ULC_Nat_nox n W t.
Proof.
  induction n.
  reflexivity.
  simpl in *.
  intros.
  (**)
  unfold _shift in IHn.
  unfold inj in IHn.
  simpl in IHn.
  (**)
  unfold ULC_Nat_nox in *.
  simpl.
  repeat apply f_equal.
  apply ULC_Nat_noredex_subst.
Qed.

(* Nat n reduces to Nat_nox n *)
(* Nat n has 2n redexes *)

Lemma ULC_nat_red_ULC_Nat_alt n V :
  ULC_Nat n V >> ULC_Nat_nox n V tt.
Proof.
  induction n.
  reflexivity.
  intros.
  simpl.
  unfold ULC_Nat_nox in *.
  assert (H:= IHn (opt tt (opt tt V))).
transitivity (
Abs
  (Abs
     (App (Var (V:=(V *) *) (t:=tt)
             (some tt (A:=V *) (t:=tt) (none tt V)))
        (App
           (App

(Abs (Abs (ULC_Nat_noredex n (V *) * tt)))

              (Var (V:=(V *) *) (t:=tt)
                 (some tt (A:=V *) (t:=tt) (none tt V))))
           (Var (V:=(V *) *) (t:=tt) (none tt V *)))))
).
  apply cp_Abs.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  apply cp_App1.
  apply H.
  clear H IHn.
  sim.
  apply cp_Abs.
  apply cp_Abs.
  apply cp_App2.
  apply App1_app_abs.
  sim.
  apply app_abs_red.
  sim.
  rewrite subst_subst.
  simpl.

  apply beta_eq.
  generalize dependent V.

  induction n.
  reflexivity.
  simpl.
  intro V.
  rewrite IHn.
  auto.
Qed.

Lemma pow_rename (n: nat) (V W : TT)(f : V ---> W) T :
   pow n T //- f = pow n (T //- f).
Proof.
  induction n.
  reflexivity.
  intros;
  simpl.
  apply f_equal.
  apply App_eq.
  unfold inj; simpl.
  repeat rewrite rename_rename;
  fin.
  apply App_eq.
  unfold inj; simpl.
  rewrite <- IHn.
  repeat rewrite rename_rename;
  fin.
  fin.
Qed.

Lemma pow_subst (n: nat) (V W : TT)(f : V ---> ULC W) T :
   pow n T >>= f = pow n (T >>= f).
Proof.
  induction n.
  reflexivity.
  simpl.
  intros.
  apply f_equal.
  apply App_eq.
  unfold inj.
  rewrite rename_subst.
  rewrite subst_rename.
  fin.
  apply App_eq.
  unfold inj.
  rewrite <- IHn.
  rewrite rename_subst.
  rewrite subst_rename.
  fin.
  auto.
Qed.

Lemma n_red_pow n V T :
  App (ULC_Nat n V) T >> pow n T.
Proof.
  intro n;
  induction n.
  simpl.
  intros V T.
  apply app_abs_red.
  unfold substar;
  simpl.
  reflexivity.
  simpl in IHn.
  unfold pow in IHn.
  intros V T.
  simpl.
  apply app_abs_red.
  unfold substar;
  simpl.
  unfold pow.
  simpl.
  rewrite <- ulc_nats_subst.
  apply cp_Abs.
  apply cp_App2.
  apply cp_App1.
  unfold inj;
  simpl.
  assert (H':= rename_beta (some tt (A:=V))
                (IHn V T)).
  apply (beta_trans H').
  apply beta_eq.
  simpl.
  rewrite <- ulc_nats_rename.
  auto.
Qed.

Definition ULC_Nat_alt n V : ULC V tt :=
  Abs (pow n (Var (none tt V))).

(** plus = \n.\m.\f.\x. n(f) (m(f)x) *)

Definition ULC_plus (V : TT) :=
  Abs (V:=V)
   (
   Abs (V:=opt tt V)
     (
    Abs (V:= opt tt (opt tt V))
         (
          Abs (V:= opt tt (opt tt (opt tt V)))
           (
             App (V:=opt tt (opt tt (opt tt (opt tt V))))
               (App (V:=opt tt (opt tt (opt tt (opt tt V))))
                    (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (some tt (some tt (some tt (none tt V)))))
                    (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (some tt (A:=(opt tt (opt tt (opt tt V))))
                              (none tt (opt tt (opt tt V)) ))) )
               (App (V:=opt tt (opt tt (opt tt (opt tt V))))
                    (App (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                              (some tt (some tt (none tt (opt tt V) ))))
                         (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                              (some tt (A:= opt tt (opt tt (opt tt V)))
                                  (none tt (opt tt (opt tt V))))))
                    (Var (V:=opt tt (opt tt (opt tt (opt tt V))))
                         (none tt (opt tt (opt tt (opt tt V) )) )))
              )

             )
       )
 ).

(** SUCC := \nfx.f (n f x) *)
Definition ULCsucc V : ULC V tt :=
  Abs (
   Abs (
    Abs (
      App
       (Var (some tt (none tt _ )))
       (App
         (App
           (Var (some tt (some tt (none tt _ ))))
           (Var (some tt (none tt _ )))
         )
         (Var (none tt _ ))
       )))).

(* alternative definition for succ :
    succ := \m.\f.\n. (m f)(f n)
*)
(*
Definition ULCsucc_alt V : ULC V tt :=
  Abs (
   Abs (
    Abs(
     App
      (App
        (Var (some tt (some tt (none tt V))))
        (Var (some tt (none tt (opt tt V)))))
      (App
        (Var (some tt (none tt _ )))
        (Var (none tt _ )))

))).
*)

(** if then else = \a.\b.\c. a(b)(c) *)

Definition ULC_cond (V : TT) :=
     Abs (V:=V)
        ( Abs (V:=opt tt V)
            ( Abs (V:=opt tt (opt tt V))
               (
                   App (V:= opt tt (opt tt (opt tt V)))
                      (App (V:= opt tt (opt tt (opt tt V)))
                         (Var (V:= opt tt (opt tt (opt tt V)))
                            (some tt (some tt (none tt V))))
                         (Var (some tt (none tt (opt tt V))))
                      )
                      (Var (none tt (opt tt (opt tt V)))
                      )
               )
            )
        ).

Definition ULC_omega (V : TT) :=
    Abs (V:= V)
      ( App (Var (none tt V)) (Var (none tt V))).

(* TRUE = \xy.x *)
Definition ULC_True V : ULC V tt :=
  Abs (Abs (Var (some tt (none tt V)))).

(* FALSE = \xy.y *)
Definition ULC_False V : ULC V tt :=
  Abs (Abs (Var (none tt V*))).

(* zero? = \n.((n)(true)false)true     *)

Definition ULC_zero (V : TT) :=
  Abs (
   App
     (App
       (Var (none tt V ))
       (Abs (ULC_False _)))
     (ULC_True _ )).

(* T f := \gh. h (g f) *)
Definition ULC_T V f : ULC V tt :=
  Abs (
   Abs (
    App
     (Var (none tt _))
     (App
       (Var (some tt (none tt V)))
       (inj _ (inj _ f))))
).

Lemma T_rename (V W : TT) (g : V ---> W) f :
  ULC_T  f //- g = ULC_T (f//-g).
Proof.
  simpl.
  unfold ULC_T.
  intros.
  repeat apply f_equal.
  unfold inj;
  simpl.
  repeat rewrite rename_rename.
  apply rename_eq.
  simpl.
  auto.
Qed.

(*PRED := \nfx.n (\gh.h (g f)) (\u.x) (\u.u)*)

Definition ULC_pred_alt (V : TT) : ULC V tt :=
  Abs (
   Abs (
    Abs (
     App
       (App
         (App
           (Var (some tt (some tt (none tt V))))
           (ULC_T (Var (some tt (none tt _ ))))
)
         (Abs (Var (some tt (none tt _ )))))
       (Abs (Var (none _ _ )))
))).

Definition ULC_pred (V : TT) : ULC V tt :=
  Abs (
   Abs (
    Abs (
     App
       (App
         (App
           (Var (some tt (some tt (none tt V))))
           (Abs (
             Abs (
              App
               (Var (none tt _ ))
               (App
                 (Var (some tt (none tt _ )))
                 (Var (some tt (some tt (some tt (none tt _ )))))
             )))))
         (Abs (Var (some tt (none tt _ )))))
       (Abs (Var (none _ _ )))
))).

Lemma ULC_pred_alt_correct V :
  ULC_pred_alt V = ULC_pred V.
Proof.
  reflexivity.
Qed.