Require Import Coq.Program.Syntax.
Require Export ZArith.
Require Import Coq.Program.Basics.
Require Import SetoidTactics.
Require Import SetoidClass.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.

Require Import HDI.Util.
Require Import HDI.Syntax.
Require Import HDI.Heap.
Require Import HDI.OpSem.
Require Import HDI.Bisimulation.
Require HDI.HoareDoubles.
Require HDI.HoareDoublesI.

Local Open Scope Z.
Local Open Scope stmt.
Local Open Scope char.
Local Open Scope bool.

Section Implementation.

  CoFixpoint parseWS a : stmt:=
    x <- read a;
    if x =? zero then
      ret 1 (* Title Case *)
    else if x =? " " then
      parseWS (1+a)
    else if (negb (is_letterZ x)) || (is_upperZ x) then
      parseLetters (1+a)
    else
      ret 0 (* not type case *)
  with parseLetters (a:Z) :=
    x <- read a;
    if x =? zero then
      ret 1 (* Title Case *)
    else if x =? " " then
      parseWS (1+a)
    else if negb (is_letterZ x) || is_lowerZ x then
        parseLetters (1+a)
      else
        ret 0 (* cAps in woRd *).

  Definition isTitleCase := parseWS.

  Lemma unfold_parseWS: forall a,
    parseWS a =
    x <- read a;
    if x =? zero then
      ret 1 (* Title Case *)
    else if x =? " " then
      parseWS (1+a)
    else if (negb (is_letterZ x)) || (is_upperZ x) then
      parseLetters (1+a)
    else
      ret 0 (* not type case *).
  Proof. intros; rewrite (unfold_stmt_eq (parseWS a)); reflexivity. Qed.

  Lemma unfold_parseLetters: forall a,
    parseLetters a =
    x <- read a;
    if x =? zero then
      ret 1 (* Title Case *)
    else if x =? " " then
      parseWS (1+a)
    else if negb (is_letterZ x) || is_lowerZ x then
        parseLetters (1+a)
      else
        ret 0 (* cAps in woRd *).
  Proof. intros; rewrite (unfold_stmt_eq (parseLetters a)); reflexivity. Qed.

End Implementation.

Section Verification.

  Fixpoint is_title_case_ (in_word: bool) (s: string) {struct s} : bool :=
    match s with
    | String x s' =>
      if ascii_dec x zero then
        true (* Title Case *)
      else if ascii_dec x " " then
        is_title_case_ false s'
      else if in_word then
        if negb (is_letter x) || is_lower x then
          is_title_case_ true s'
        else
          false  (* cAps in woRd *)
      else
        let check_word x s :=
          if (negb (is_letter x)) || (is_upper x) then
            is_title_case_ true s'
          else
            false (* not type case *)
        in
        check_word x s'
    | empty => true (* Title Case *)
    end.
  Definition is_title_case s := is_title_case_ false s.

  Goal is_title_case "" = true. reflexivity. Abort.
  Goal is_title_case "  " = true. reflexivity. Abort.
  Goal is_title_case "67" = true. reflexivity. Abort.
  Goal is_title_case "A" = true. reflexivity. Abort.
  Goal is_title_case "z" = false. reflexivity. Abort.
  Goal is_title_case "Hello World" = true. reflexivity. Abort.
  Goal is_title_case "Hello world" = false. reflexivity. Abort.
  Goal is_title_case "hello World" = false. reflexivity. Abort.
  Goal is_title_case "HeLlo World" = false. reflexivity. Abort.
  Goal is_title_case "  Hello     World  " = true. reflexivity. Abort.
  Goal is_title_case "8ello World" = true. reflexivity. Abort.
  Goal is_title_case "8ellO World" = false. reflexivity. Abort.

  Lemma is_title_case_in_word: forall s,
    is_title_case_ true s = is_title_case (String "A" s).
  Proof. intros; reflexivity. Qed.

  Section HD.
    Import HoareDoubles.

    Lemma isTitleCase_ok: forall a s F k,
      |-{{a |->0 s && F}}  k (if is_title_case s then 1 else 0) ->
      |-{{a |->0 s && F}}  isTitleCase a >>= k.
    Proof.
    Abort.

  End HD.

  Import HoareDoublesI.
  Require Import CoInduction.

  Definition tc_ret s := if is_title_case s then 1 else 0.

  Lemma parseLetters_ind_ok: forall (I: predicate heap -> stmt -> Prop) a s F k,
    I ||= {{a |->0 s && F}}  k (tc_ret ("A"++s)%string) ->
    (forall a s0 s' F,
      append s0 s' = s ->
      I ||= {{a |->0 s' && F}}  k (tc_ret s') ->
      I ||- {{a |->0 s' && F}} (parseWS a >>= k)) ->
    I ||- {{a |->0 s && F}}  parseLetters a >>= k.
  Proof.
    intros I a s F k.
    intros Hsafe_k Hsafe_sws.
    unfold tc_ret in Hsafe_k; simpl in Hsafe_k.
    rewrite <-is_title_case_in_word in Hsafe_k.
    revert a F Hsafe_k.
    induction s; simpl; intros.
    * rewrite unfold_parseLetters.
    step.
    mcase_eq.
    step; auto.
    *
    (* x <- parseLetters a; k x *)
    rewrite unfold_parseLetters.
    (* x <- act (read a); *)
    step.
    (* (if x =? Z_of_ascii zero *)
    mcase_eq.
    (*  then ret 1 *)
    { apply Z_of_ascii_inv in H; subst a.
      step; auto.
    }
    (*  else if x =? Z_of_ascii " " *)
    destruct (ascii_dec a zero); subst.
    congruence.
    destruct (ascii_dec a " "); subst.
    (*   then parseWS (1 + a) *)
    { rewrite Z.eqb_refl.
      rewrite str0_cons, (inter_comm ((1+a0) |->0 _)), <-!inter_assoc in Hsafe_k |- *.
      apply hd'_safe.
      eapply (Hsafe_sws (1+a0) " "%string s); auto.
    }
    rewrite (proj2 (Z.eqb_neq _ _)); [ | apply Z_of_ascii_neq; auto ].
    (*   else if negb (is_letterZ x) || is_lowerZ x *)
    rewrite is_letterZ_of_ascii, is_lowerZ_of_ascii.
    rewrite is_letter_eq in Hsafe_k |- *.
    rewrite Bool.negb_orb, Bool.orb_andb_distrib_l, negb_orb_cancel_l in Hsafe_k |- *.
    rewrite Bool.andb_true_r in Hsafe_k |- *.
    mcase_eq.
    (*     then parseLetters (1 + a) *)
    { rewrite str0_cons, (inter_comm ((1+a0) |->0 _)), <-!inter_assoc in Hsafe_k |- *.
      apply hd'_safe.
      apply IHs; intros; auto.
      eapply Hsafe_sws with (s0:=String a s0); auto.
      subst s.
      reflexivity.
    }
    (*     else ret 0 >>= k *)
    step; assumption.
  Qed.

  Lemma parseWS_ind_ok: forall I a s F k,
    I ||= {{a |->0 s && F}}  k (tc_ret s) ->
    I ||- {{a |->0 s && F}}  parseWS a >>= k.
  Proof.
    intros I a s F k Hsafe_k.
    unfold tc_ret, is_title_case in Hsafe_k.
    revert Hsafe_k.
    remember (append EmptyString s) as s1.
    revert Heqs1.
    generalize EmptyString as s0.
    revert a s F.
    induction s1; simpl; intros; subst.
    * rewrite unfold_parseWS.
    destruct s0, s; try solve [inversion Heqs1].
    step.
    mcase_eq.
    step; auto.
    *
    (* x <- parseWS a; k x *)
    rewrite unfold_parseWS.
    (* x <- read a *)
    step.
    (* if x =? Z_of_ascii zero *)
    mcase_eq.
    (* then ret 1 *)
    { step; auto.
      repeat mcase_eq in *.
      destruct s0; inversion Heqs1; subst; eauto.
      apply Z_of_ascii_inv in H; subst; auto.
      apply Z_of_ascii_inv in H; subst; auto.
      simpl in H0; discriminate.
    }
    (* else if x =? " " *)
    destruct s.
    compute in H; exfalso; eauto.
    rewrite str0_cons, (inter_comm ((1+a0) |->0 _)), <-!inter_assoc in Hsafe_k |- *.
    rewrite is_letterZ_of_ascii, is_upperZ_of_ascii.
    unfold is_title_case_ in Hsafe_k.
    fold is_title_case_ in Hsafe_k.
    destruct (ascii_dec a1 zero); subst.
    congruence.
    destruct (ascii_dec a1 " "); subst.
    (* then parseWS (1+a) *)
    { rewrite Z.eqb_refl.
      apply hd'_safe; eauto.
      destruct s0; inversion Heqs1; subst; eauto.
      eapply IHs1 with (s1:=""%string); auto.
      eapply IHs1 with (s2:= (s0++" ")%string); auto.
      clear.
      induction s0; simpl in *; congruence.
    }
    (* else if (negb (is_letterZ x)) || (is_upperZ x) *)
    rewrite (proj2 (Z.eqb_neq _ _)); [ | apply Z_of_ascii_neq; auto ].
    repeat mcase_eq.
    (* then parseLetters (1+a) *)
    apply hd'_safe, parseLetters_ind_ok; intros; subst; eauto.
    destruct s0; inversion Heqs1; subst; eauto.
    eapply IHs1 with (s1:=(s0++String a1 s2)%string); eauto.
    clear; induction s0; simpl in *; congruence.
    (* else ret 0 (* not type case *) *)
    step; auto.
  Qed.

  Lemma parseLetters_ok: forall (I0 I: predicate heap -> stmt -> Prop) a s F k,
    I0 ||= {{a |->0 s && F}}  k (tc_ret ("A"++s)%string) ->
    incl_inv I0 I ->
    (forall a s F,
      I0 ||= {{a |->0 s && F}}  k (tc_ret s) ->
      I ||= {{a |->0 s && F}} parseWS a >>= k) ->
    I ||- {{a |->0 s && F}}  parseLetters a >>= k.
  Proof.
    intros I0 I a s F k.
    intros Hsafe_k HI0 Hsafe_sws.
    unfold tc_ret in Hsafe_k; simpl in Hsafe_k.
    rewrite <-is_title_case_in_word in Hsafe_k.
    revert a s F Hsafe_k.
    hd_coind.
    (* x <- parseLetters a; k x *)
    rewrite unfold_parseLetters.
    (* x <- act (read a); *)
    step.
    (* if x =? Z_of_ascii zero *)
    mcase_eq.
    (*   then ret 1 *)
    { rewrite HI0, H0 in Hsafe_k.
      destruct s; simpl in *.
      step; auto.
      apply Z_of_ascii_inv in H1; subst.
      simpl in *.
      step; auto.
    }
    destruct s.
    compute in H1; congruence.
    (*   else if x =? Z_of_ascii " " *)
    unfold is_title_case in Hsafe_k.
    simpl in Hsafe_k.
    destruct (ascii_dec a0 zero); subst.
    congruence.
    destruct (ascii_dec a0 " "); subst.
    (*   then parseWS (1 + a) *)
    { rewrite Z.eqb_refl.
      rewrite str0_cons, (inter_comm ((1+a) |->0 _)), <-!inter_assoc in Hsafe_k |- *.
      rewrite <-H0.
      apply Hsafe_sws; assumption.
    }
    rewrite (proj2 (Z.eqb_neq _ _)); [ | apply Z_of_ascii_neq; auto ].
    (*   else if negb (is_letterZ x) || is_lowerZ x *)
    rewrite is_letterZ_of_ascii, is_lowerZ_of_ascii.
    rewrite is_letter_eq in Hsafe_k |- *.
    rewrite Bool.negb_orb, Bool.orb_andb_distrib_l, negb_orb_cancel_l in Hsafe_k |- *.
    rewrite Bool.andb_true_r in Hsafe_k |- *.
    mcase_eq.
    (*     then parseLetters (1 + a) *)
    rewrite str0_cons, (inter_comm ((1+a) |->0 _)), <-!inter_assoc in Hsafe_k |- *.
    eauto.
    (*   else ret 0 >>= k *)
    rewrite <-H0, <-HI0.
    step; assumption.
  Qed.

  Lemma parseWS_ok: forall I a s F k,
    I ||= {{a |->0 s && F}}  k (tc_ret s) ->
    I ||- {{a |->0 s && F}}  parseWS a >>= k.
  Proof.
    intros I a s F k Hsafe_k.
    unfold tc_ret, is_title_case in Hsafe_k.
    revert a s F Hsafe_k.
    hd_coind.
    (* x <- parseWS a; k x *)
    rewrite unfold_parseWS.
    (* x <- read a *)
    step.
    (* if x =? Z_of_ascii zero *)
    mcase_eq.
    (* then ret 1 *)
    { rewrite H0 in Hsafe_k.
      destruct s; simpl in *.
      step; auto.
      apply Z_of_ascii_inv in H1; subst.
      simpl in *.
      step; auto.
    }
    destruct s.
    compute in H1; congruence.
    (* else if x =? " " *)
    rewrite str0_cons, (inter_comm ((1+a) |->0 _)), <-!inter_assoc in Hsafe_k |- *.
    simpl (is_title_case_ _ _) in Hsafe_k.
    rewrite is_letterZ_of_ascii, is_upperZ_of_ascii.
    destruct (ascii_dec a0 zero); subst.
    congruence.
    destruct (ascii_dec a0 " "); subst.
    (* then parseWS (1+a) *)
    rewrite Z.eqb_refl; auto.
    (* else if (negb (is_letterZ x)) || (is_upperZ x) *)
    rewrite (proj2 (Z.eqb_neq _ _)); [ | apply Z_of_ascii_neq; auto ].
    repeat mcase_eq.
    (* then parseLetters (1+a) *)
    apply hd'_safe, parseLetters_ok with (I0:=I); auto.
    (* else ret 0 (* not type case *) *)
    rewrite <-H0; step; assumption.
  Qed.

  Lemma isTitleCase_ok: forall I a s F k,
    I ||= {{a |->0 s && F}}  k (if is_title_case s then 1 else 0) ->
    I ||- {{a |->0 s && F}}  isTitleCase a >>= k.
  Proof.
    intros I a s F k Hsafe_k.
    unfold isTitleCase.
    apply parseWS_ok; assumption.
  Qed.

End Verification.


Require Export Iron.Language.SystemF2Effect.Value.
Require Export Iron.Language.SystemF2Effect.Store.
Require Export Iron.Language.SystemF2Effect.Step.Frame.
Require Export Iron.Language.SystemF2Effect.Step.TypeF.

(********************************************************************)
(* Type of an expression in a frame context. *)
Inductive TypeC
   :  kienv -> tyenv
   -> stenv -> stprops
   -> stack -> exp
   -> ty    -> ty -> Prop :=
 | TcExp
   :  forall ke te se sp fs x1 t1 e1 t2 e2 e3
   ,  EquivT ke sp (TSum e1 e2) e3 KEffect
   -> TypeX  ke te se sp x1 t1 e1
   -> TypeF  ke te se sp fs t1 t2 e2
   -> TypeC  ke te se sp fs x1 t2 e3.

Hint Constructors TypeC.

Ltac inverts_typec :=
 repeat
  (try (match goal with
        | [H: TypeC _ _ _ _ _ _ _ _ |- _ ] => inverts H
        end);
   try inverts_typef).

(********************************************************************)
Lemma typeC_kindT_effect
 :  forall ke te se sp fs x t e
 ,  TypeC  ke te se sp fs x t e
 -> KindT  ke sp e KEffect.
Proof.
 intros.
 induction H; eauto.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.derive.Derive.
Require Import Crypto.Util.Option.
Require Crypto.Util.Tuple.
Require Crypto.Util.OptionList.
Import ListNotations.

Local Open Scope list_scope.

Local Set Implicit Arguments.
Local Set Boolean Equality Schemes.
Local Set Decidable Equality Schemes.
Local Set Primitive Projections.

Inductive REG :=
|     rax |     rcx |     rdx |     rbx | rsp  | rbp  | rsi  | rdi  | r8  | r9  | r10  | r11  | r12  | r13  | r14  | r15
|     eax |     ecx |     edx |     ebx | esp  | ebp  | esi  | edi  | r8d | r9d | r10d | r11d | r12d | r13d | r14d | r15d
|      ax |      cx |      dx |      bx |  sp  |  bp  |  si  |  di  | r8w | r9w | r10w | r11w | r12w | r13w | r14w | r15w
| ah | al | ch | cl | dh | dl | bh | bl |  spl |  bpl |  sil |  dil | r8b | r9b | r10b | r11b | r12b | r13b | r14b | r15b
.

Definition CONST := Z.
Coercion CONST_of_Z (x : Z) : CONST := x.

Inductive AccessSize := byte | word | dword | qword.
Coercion bits_of_AccessSize (x : AccessSize) : N
  := match x with
     | byte => 8
     | word => 16
     | dword => 32
     | qword => 64
     end.

Record MEM := { mem_bits_access_size : option AccessSize ; mem_base_reg : option REG ; mem_scale_reg : option (Z * REG) ; mem_base_label : option string ; mem_offset : option Z }.

Definition mem_of_reg (r : REG) : MEM :=
  {| mem_base_reg := Some r ; mem_offset := None ; mem_scale_reg := None ; mem_bits_access_size := None ; mem_base_label := None |}.

Inductive FLAG := CF | PF | AF | ZF | SF | OF.

Inductive OpPrefix :=
| rep
| repz
| repnz
.

Inductive OpCode :=
| adc
| adcx
| add
| adox
| and
| bzhi
| call
| clc
| cmovb
| cmovc
| cmovnz
| cmp
| db
| dd
| dec
| dq
| dw
| imul
| inc
| je
| jmp
| lea
| mov
| movzx
| mul
| mulx
| pop
| push
| rcr
| ret
| sar
| sbb
| setc
| seto
| shl
| shlx
| shr
| shrx
| shrd
| sub
| test
| xchg
| xor
.

Record JUMP_LABEL := { jump_near : bool ; label_name : string }.

Inductive ARG := reg (r : REG) | mem (m : MEM) | const (c : CONST) | label (l : JUMP_LABEL).
Coercion reg : REG >-> ARG.
Coercion mem : MEM >-> ARG.
Coercion const : CONST >-> ARG.

Record NormalInstruction := { prefix : option OpPrefix ; op : OpCode ; args : list ARG }.

Inductive RawLine :=
| SECTION (name : string)
| GLOBAL (name : string)
| LABEL (name : string)
| ALIGN (amount : string)
| DEFAULT_REL
| EMPTY
| INSTR (instr : NormalInstruction)
.
Coercion INSTR : NormalInstruction >-> RawLine.
Record Line := { indent : string ; rawline :> RawLine ; pre_comment_whitespace : string ; comment : option string }.
Definition Lines := list Line.

Definition reg_size (r : REG) : N :=
      match r with
      |(    rax |     rcx |     rdx |     rbx | rsp  | rbp  | rsi  | rdi  | r8  | r9  | r10  | r11  | r12  | r13  | r14  | r15 )
       => 64
      |(    eax |     ecx |     edx |     ebx | esp  | ebp  | esi  | edi  | r8d | r9d | r10d | r11d | r12d | r13d | r14d | r15d)
       => 32
      |(     ax |      cx |      dx |      bx |  sp  |  bp  |  si  |  di  | r8w | r9w | r10w | r11w | r12w | r13w | r14w | r15w)
       => 16
      |(ah | al | ch | cl | dh | dl | bh | bl |  spl |  bpl |  sil |  dil | r8b | r9b | r10b | r11b | r12b | r13b | r14b | r15b)
       => 8
      end.

Definition standalone_operand_size (x : ARG) : option N :=
  match x with
  | reg r => Some (reg_size r)
  | mem m => option_map bits_of_AccessSize m.(mem_bits_access_size)
  | const c => None
  | label _ => None
  end%N.

Definition opcode_size (op : OpCode) :=
  match op with
  | seto | setc => Some 8
  | ret => Some 64 (* irrelevant? *)
  | clc => Some 1 (* irrelevant? *)
  | _ => None
  end%N.

Definition operation_size instr :=
  match opcode_size instr.(op) with
  | Some s => Some s | None =>
  let argsizes := List.map standalone_operand_size instr.(args) in
  match OptionList.Option.List.lift argsizes with
  | Some szs => match szs with
                | nil => None (* unspecified *)
                | _ => Some (List.fold_right N.max 0%N szs) (* fully specified *)
                end
  | _ => match OptionList.Option.List.map id argsizes with
         | nil => None (* unspecified *)
         | szs =>
             let m := List.fold_right N.max 0%N szs in
             let n := List.fold_right N.min m szs in
             if N.eqb m n (* uniquely inferred from annotations *)
             then Some n
             else None (* inference needed but ambiguous *)
         end
  end
  end.

Definition operand_size (x : ARG) (operation_size : N) : N :=
  match standalone_operand_size x with
  | Some s => s
  | None => operation_size
  end.

Definition reg_index (r : REG) : nat
  :=  match r with
      |     rax
      |     eax
      |      ax
      |(ah | al)
       => 0
      |     rcx
      |     ecx
      |      cx
      |(ch | cl)
       => 1
      |     rdx
      |     edx
      |      dx
      |(dh | dl)
       => 2
      |     rbx
      |     ebx
      |      bx
      |(bh | bl)
       => 3
      | rsp
      | esp
      |  sp
      |( spl)
       => 4
      | rbp
      | ebp
      |  bp
      |( bpl)
       => 5
      | rsi
      | esi
      |  si
      |( sil)
       => 6
      | rdi
      | edi
      |  di
      |( dil)
       => 7
      | r8
      | r8d
      | r8w
      | r8b
        => 8
      | r9
      | r9d
      | r9w
      | r9b
        => 9
      | r10
      | r10d
      | r10w
      | r10b
        => 10
      | r11
      | r11d
      | r11w
      | r11b
        => 11
      | r12
      | r12d
      | r12w
      | r12b
        => 12
      | r13
      | r13d
      | r13w
      | r13b
        => 13
      | r14
      | r14d
      | r14w
      | r14b
        => 14
      | r15
      | r15d
      | r15w
      | r15b
        => 15
      end.
Definition reg_offset (r : REG) : N :=
      match r with
      |(    rax |     rcx |     rdx |     rbx | rsp  | rbp  | rsi  | rdi  | r8  | r9  | r10  | r11  | r12  | r13  | r14  | r15 )
      |(    eax |     ecx |     edx |     ebx | esp  | ebp  | esi  | edi  | r8d | r9d | r10d | r11d | r12d | r13d | r14d | r15d)
      |(     ax |      cx |      dx |      bx |  sp  |  bp  |  si  |  di  | r8w | r9w | r10w | r11w | r12w | r13w | r14w | r15w)
      |(     al |      cl |      dl |      bl |  spl |  bpl |  sil |  dil | r8b | r9b | r10b | r11b | r12b | r13b | r14b | r15b)
       => 0
      |(ah      | ch      | dh      | bh      )
       => 8
      end.
Definition index_and_shift_and_bitcount_of_reg (r : REG) :=
  (reg_index r, reg_offset r, reg_size r).

Definition regs_of_index (index : nat) : list (list REG) :=
  match index with
  |  0 => [ [  al ; ah] ; [  ax] ; [ eax] ; [rax] ]
  |  1 => [ [  cl ; ch] ; [  cx] ; [ ecx] ; [rcx] ]
  |  2 => [ [  dl ; dh] ; [  dx] ; [ edx] ; [rdx] ]
  |  3 => [ [  bl ; bh] ; [  bx] ; [ ebx] ; [rbx] ]
  |  4 => [ [ spl     ] ; [  sp] ; [ esp] ; [rsp] ]
  |  5 => [ [ bpl     ] ; [  bp] ; [ ebp] ; [rbp] ]
  |  6 => [ [ sil     ] ; [  si] ; [ esi] ; [rsi] ]
  |  7 => [ [ dil     ] ; [  di] ; [ edi] ; [rdi] ]
  |  8 => [ [ r8b     ] ; [ r8w] ; [ r8d] ; [r8 ] ]
  |  9 => [ [ r9b     ] ; [ r9w] ; [ r9d] ; [r9 ] ]
  | 10 => [ [r10b     ] ; [r10w] ; [r10d] ; [r10] ]
  | 11 => [ [r11b     ] ; [r11w] ; [r11d] ; [r11] ]
  | 12 => [ [r12b     ] ; [r12w] ; [r12d] ; [r12] ]
  | 13 => [ [r13b     ] ; [r13w] ; [r13d] ; [r13] ]
  | 14 => [ [r14b     ] ; [r14w] ; [r14d] ; [r14] ]
  | 15 => [ [r15b     ] ; [r15w] ; [r15d] ; [r15] ]
  | _  => []
  end.

(** convenience printing function *)
Definition widest_register_of_index (n : nat) : REG
  := match n with
     | 0 => rax
     | 1 => rcx
     | 2 => rdx
     | 3 => rbx
     | 4 => rsp
     | 5 => rbp
     | 6 => rsi
     | 7 => rdi
     | 8 => r8
     | 9 => r9
     | 10 => r10
     | 11 => r11
     | 12 => r12
     | 13 => r13
     | 14 => r14
     | 15 => r15
     | _ => rax
     end%nat.

Definition reg_of_index_and_shift_and_bitcount_opt :=
  fun '(index, offset, size) =>
    let sz := N.log2 (size / 8) in
    let offset_n := (offset / 8)%N in
    if ((8 * 2^sz =? size) && (offset =? offset_n * 8))%N%bool
    then (rs <- nth_error (regs_of_index index) (N.to_nat sz);
          nth_error rs (N.to_nat offset_n))%option
    else None.
Definition reg_of_index_and_shift_and_bitcount :=
  fun '(index, offset, size) =>
    match reg_of_index_and_shift_and_bitcount_opt (index, offset, size) with
    | Some r => r
    | None => widest_register_of_index index
    end.

Lemma widest_register_of_index_correct
  : forall n,
    (~exists r, reg_index r = n)
    \/ (let r := widest_register_of_index n in reg_index r = n
       /\ forall r', reg_index r' = n -> r = r' \/ (reg_size r' < reg_size r)%N).
Proof.
  intro n; set (r := widest_register_of_index n).
  cbv in r.
  repeat match goal with r := context[match ?n with _ => _ end] |- _ => destruct n; [ right | ] end;
    [ .. | left; intros [ [] H]; cbv in H; congruence ].
  all: subst r; split; [ reflexivity | ].
  all: intros [] H; cbv in H; try (exfalso; congruence).
  all: try (left; reflexivity).
  all: try (right; vm_compute; reflexivity).
Qed.

Lemma reg_of_index_and_shift_and_bitcount_opt_correct v r
  : reg_of_index_and_shift_and_bitcount_opt v = Some r <-> index_and_shift_and_bitcount_of_reg r = v.
Proof.
  split; [ | intro; subst; destruct r; vm_compute; reflexivity ].
  cbv [index_and_shift_and_bitcount_of_reg]; destruct v as [ [index shift] bitcount ].
  cbv [reg_of_index_and_shift_and_bitcount_opt].
  generalize (shift / 8)%N (N.log2 (bitcount / 8)); intros *.
  repeat first [ congruence
               | progress subst
               | match goal with
                 | [ H : _ /\ _ |- _ ] => destruct H
                 | [ H : N.to_nat _ = _ |- _ ] => apply (f_equal N.of_nat) in H; rewrite N2Nat.id in H; subst
                 | [ |- Some _ = Some _ -> _ ] => inversion 1; subst
                 | [ |- context[match ?x with _ => _ end] ] => destruct x eqn:?; subst
                 end
               | progress cbv [regs_of_index]
               | match goal with
                 | [ |- context[nth_error _ ?n] ] => destruct n eqn:?; cbn [nth_error Option.bind]
                 end
               | rewrite Bool.andb_true_iff, ?N.eqb_eq in * |- ].
  all: vm_compute; reflexivity.
Qed.

Lemma reg_of_index_and_shift_and_bitcount_of_reg r
  : reg_of_index_and_shift_and_bitcount (index_and_shift_and_bitcount_of_reg r) = r.
Proof. destruct r; vm_compute; reflexivity. Qed.

Lemma reg_of_index_and_shift_and_bitcount_eq v r
  : reg_of_index_and_shift_and_bitcount v = r
    -> (index_and_shift_and_bitcount_of_reg r = v
        \/ ((~exists r, index_and_shift_and_bitcount_of_reg r = v)
            /\ r = widest_register_of_index (fst (fst v)))).
Proof.
  cbv [reg_of_index_and_shift_and_bitcount].
  destruct v as [ [index offset] size ].
  destruct reg_of_index_and_shift_and_bitcount_opt eqn:H;
    [ left | right; split; [ intros [r' H'] | ] ]; subst; try reflexivity.
  { rewrite reg_of_index_and_shift_and_bitcount_opt_correct in H; assumption. }
  { rewrite <- reg_of_index_and_shift_and_bitcount_opt_correct in H'; congruence. }
Qed.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.

From PromisingLib Require Import Event.
Require Import Time.

Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Mapping.
Require Import Pred.
Require Import Trace.
Require Import MemoryProps.

Set Implicit Arguments.

Module CompressSteps.
  Section CompressSteps.
    Variable (lang: language).

    Inductive spatial_mem (mem_src mem_tgt: Memory.t): Prop :=
    | spatial_mem_intro
        loc from to
        (SPACE: Time.lt (Memory.max_ts loc mem_tgt) from)
        (ADD: Memory.add mem_tgt loc from to Message.reserve mem_src)
    .

    Inductive spatial_thread (e_src e_tgt: Thread.t lang): Prop :=
    | spatial_thread_intro
        (STATE: (Thread.state e_src) = (Thread.state e_tgt))
        (LOCAL: (Thread.local e_src) = (Thread.local e_tgt))
        (SC: (Thread.sc e_src) = (Thread.sc e_tgt))
        (MEMORY: spatial_mem (Thread.memory e_src) (Thread.memory e_tgt))
    .

    Lemma spatial_memory_map mem_src mem_tgt times
          (SPATIAL: spatial_mem mem_src mem_tgt)
          (CLOSED: Memory.closed mem_tgt)
      :
        exists (f: Loc.t -> Time.t -> Time.t -> Prop),
          (<<IDENT: map_ident_in_memory f mem_tgt>>) /\
          (<<MAPLT: mapping_map_lt_iff f>>) /\
          (<<MEMORY: memory_map f mem_tgt mem_src>>) /\
          (<<COMPLETE: forall loc to (IN: List.In to (times loc)),
              exists fto, (<<MAPPED: f loc to fto>>)>>).
    Proof.
      inv SPATIAL.
      hexploit shift_map_exists.
      { refl. }
      { eapply SPACE. }
      i. des.
      exists (fun loc' => if (Loc.eq_dec loc loc') then f else eq).
      assert (IDENT: map_ident_in_memory (fun loc' => if LocSet.Facts.eq_dec loc loc' then f else eq) mem_tgt).
      { ii. des_ifs. eapply SAME; eauto. } splits; ss.
      - ii. des_ifs. eapply MAPLT; eauto.
      - econs.
        + i. right. exists to0, from0, msg, msg. splits; auto.
          * des_ifs. eapply SAME.
            eapply Memory.max_ts_spec in GET. des. eauto.
          * eapply map_ident_in_memory_closed_message; eauto.
            inv CLOSED. eapply CLOSED0 in GET. des. auto.
          * refl.
          * eapply Memory.add_get1; eauto.
        + i. erewrite Memory.add_o in GET; eauto.
          destruct (loc_ts_eq_dec (loc0, fto) (loc, to)).
          { ss. des; clarify. right. ii. des_ifs.
            destruct (Time.le_lt_dec ts (Memory.max_ts loc mem_tgt)).
            - dup l. eapply SAME in l. replace fts with ts in *.
              + eapply TimeFacts.le_lt_lt; eauto.
              + destruct (Time.le_lt_dec ts fts).
                * destruct l1; auto.
                  eapply MAPLT in H; eauto.
                  exfalso. eapply Time.lt_strorder; eauto.
                * eapply MAPLT in l1; eauto.
                  exfalso. eapply Time.lt_strorder; eauto.
            - eapply BOUND in MAP; eauto. des. auto. }
          { guardH o. left. exists fto, ffrom, fto, ffrom. splits.
            - eapply IDENT. eapply Memory.max_ts_spec in GET. des; auto.
            - refl.
            - refl.
            - eapply IDENT. dup GET. eapply Memory.max_ts_spec in GET. des; auto.
              eapply Memory.get_ts in GET0. des; clarify.
              etrans; eauto. left. auto.
            - i. econs; eauto. }
      - i. des_ifs.
        + eapply COMPLETE in IN; eauto.
        + eauto.
    Qed.

    Lemma compress_steps_failure
          e1_src e1_tgt
          (THREAD1: spatial_thread e1_src e1_tgt)
          (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
          (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
          (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
          (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
          (MEM1_SRC: Memory.closed (Thread.memory e1_src))
          (MEM1_TGT: Memory.closed (Thread.memory e1_tgt))
          (STEPS_TGT: @Thread.steps_failure lang e1_tgt):
      Thread.steps_failure e1_src.
    Proof.
      inv THREAD1. destruct e1_src, e1_tgt. ss. clarify.
      unfold Thread.steps_failure in *. des.
      eapply pred_steps_thread_steps in STEPS.
      eapply pred_steps_trace_steps in STEPS. des.
      hexploit (trace_times_list_exists tr). i. des.
      hexploit (spatial_memory_map times MEMORY); eauto. i. des.
      destruct e2. hexploit trace_steps_map; try apply STEPS0; try apply MEMORY0; eauto.
      { eapply mapping_map_lt_iff_map_le; eauto. }
      { eapply map_ident_in_memory_bot; eauto. }
      { eapply mapping_map_lt_iff_map_eq; eauto. }
      { eapply mapping_map_lt_iff_map_lt; eauto. }
      { eapply wf_time_mapped_mappable; eauto. }
      { eapply map_ident_in_memory_local; eauto. }
      { eapply mapping_map_lt_iff_collapsable_unwritable; eauto. }
      { eapply map_ident_in_memory_closed_timemap; eauto. }
      { refl. }
      i. des.
      inv STEP_FAILURE; inv STEP; ss. inv LOCAL0; ss.
      { esplits.
        - eapply thread_steps_pred_steps.
          eapply pred_steps_trace_steps2.
          + eapply STEPS.
          + instantiate (1:=fun _ => True). eapply List.Forall_forall. ii.
            eapply list_Forall2_in in H; eauto. des.
            eapply List.Forall_forall in EVENTS; try apply IN. destruct a, x.
            ss. des. split; auto. rewrite <- TAU.
            eapply tevent_map_same_machine_event; eauto.
        - econs 2. econs; [|econs 7]; eauto.
          eapply failure_step_map; eauto.
          + eapply mapping_map_lt_iff_map_le; eauto.
          + eapply mapping_map_lt_iff_map_eq; eauto.
        - ss.
      }
      { exploit racy_write_step_map; eauto.
        { eapply mapping_map_lt_iff_map_le; eauto. }
        { eapply mapping_map_lt_iff_map_eq; eauto. }
        { eapply mapping_map_lt_iff_map_lt; eauto. }
        { exploit Trace.steps_future; try exact STEPS0; eauto. s. i. des. ss. }
        { eapply mapping_map_lt_iff_collapsable_unwritable; eauto. }
        i. des. esplits.
        - eapply thread_steps_pred_steps.
          eapply pred_steps_trace_steps2.
          + eapply STEPS.
          + instantiate (1:=fun _ => True). eapply List.Forall_forall. ii.
            eapply list_Forall2_in in H; eauto. des.
            eapply List.Forall_forall in EVENTS; try apply IN. destruct a, x.
            ss. des. split; auto. rewrite <- TAU.
            eapply tevent_map_same_machine_event; eauto.
        - econs 2. econs; [|econs 10]; eauto.
        - ss.
      }
      { exploit racy_update_step_map; eauto.
        { eapply mapping_map_lt_iff_map_le; eauto. }
        { eapply map_ident_in_memory_bot; eauto. }
        { eapply mapping_map_lt_iff_map_eq; eauto. }
        { eapply mapping_map_lt_iff_map_lt; eauto. }
        { exploit Trace.steps_future; try exact STEPS0; eauto. s. i. des. ss. }
        { eapply mapping_map_lt_iff_collapsable_unwritable; eauto. }
        i. des. esplits.
        - eapply thread_steps_pred_steps.
          eapply pred_steps_trace_steps2.
          + eapply STEPS.
          + instantiate (1:=fun _ => True). eapply List.Forall_forall. ii.
            eapply list_Forall2_in in H; eauto. des.
            eapply List.Forall_forall in EVENTS; try apply IN. destruct a, x.
            ss. des. split; auto. rewrite <- TAU.
            eapply tevent_map_same_machine_event; eauto.
        - econs 2. econs; [|econs 11]; eauto.
        - ss.
      }
    Qed.

    Lemma compress_steps_fulfill
          e1_src e1_tgt
          e2_tgt
          (THREAD1: spatial_thread e1_src e1_tgt)
          (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
          (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
          (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
          (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
          (MEM1_SRC: Memory.closed (Thread.memory e1_src))
          (MEM1_TGT: Memory.closed (Thread.memory e1_tgt))
          (STEPS_TGT: rtc (@Thread.tau_step lang) e1_tgt e2_tgt)
          (PROMISES_TGT: (Local.promises (Thread.local e2_tgt)) = Memory.bot):
      exists e2_src,
        <<STEPS_SRC: rtc (@Thread.tau_step lang) e1_src e2_src>> /\
                     <<PROMISES_SRC: (Local.promises (Thread.local e2_src)) = Memory.bot>>.
    Proof.
      inv THREAD1. destruct e1_src, e1_tgt. ss. clarify.
      unfold Thread.steps_failure in *. des.
      eapply pred_steps_thread_steps in STEPS_TGT.
      eapply pred_steps_trace_steps in STEPS_TGT. des.
      hexploit (trace_times_list_exists tr). i. des.
      hexploit (spatial_memory_map times MEMORY); eauto. i. des.
      destruct e2_tgt. hexploit trace_steps_map; try apply STEPS; try apply MEMORY0; eauto.
      { eapply mapping_map_lt_iff_map_le; eauto. }
      { eapply map_ident_in_memory_bot; eauto. }
      { eapply mapping_map_lt_iff_map_eq; eauto. }
      { eapply mapping_map_lt_iff_map_lt; eauto. }
      { eapply wf_time_mapped_mappable; eauto. }
      { eapply map_ident_in_memory_local; eauto. }
      { eapply mapping_map_lt_iff_collapsable_unwritable; eauto. }
      { eapply map_ident_in_memory_closed_timemap; eauto. }
      { refl. }
      i. des. esplits.
      - eapply thread_steps_pred_steps.
        eapply pred_steps_trace_steps2.
        + eapply STEPS0.
        + instantiate (1:=fun _ => True). eapply List.Forall_forall. ii.
          eapply list_Forall2_in in H; eauto. des.
          eapply List.Forall_forall in EVENTS; try apply IN. destruct a, x.
          ss. des. split; auto. inv EVENT; ss.
      - ss. inv LOCAL. rewrite PROMISES_TGT in *.
        eapply bot_promises_map; eauto.
    Qed.
  End CompressSteps.
End CompressSteps.


Require Import ZArith.

Definition zeq := Z_eq_dec.

Definition update (A: Set) (x: Z) (v: A) (s: Z -> A) : Z -> A :=
 fun y => if zeq x y then v else s y.

Implicit Arguments update [A].

Definition ident := Z.
Parameter operator: Set.
Parameter value: Set.
Parameter is_true: value -> Prop.
Definition label := Z.

Inductive expr : Set :=
 | Evar: ident -> expr
 | Econst: value -> expr
 | Eop: operator -> expr -> expr -> expr.

Inductive stmt : Set :=
 | Sskip: stmt
 | Sassign: ident -> expr -> stmt
 | Scall: ident -> ident -> expr -> stmt (* x := f(e) *)
 | Sreturn: expr -> stmt
 | Sseq: stmt -> stmt -> stmt
 | Sifthenelse: expr -> stmt -> stmt -> stmt
 | Sloop: stmt -> stmt
 | Sblock: stmt -> stmt
 | Sexit: nat -> stmt
 | Slabel: label -> stmt -> stmt
 | Sgoto: label -> stmt.

Record function : Set := mkfunction {
 fn_param: ident;
 fn_body: stmt
}.

Parameter program: ident -> option function.

Parameter main_function: ident.

Definition store := ident -> value.

Parameter empty_store : store.

Parameter eval_op: operator -> value -> value -> option value.

Fixpoint eval_expr (st: store) (e: expr) {struct e} : option value :=
 match e with
 | Evar v => Some (st v)
 | Econst v => Some v
 | Eop op e1 e2 =>
     match eval_expr st e1, eval_expr st e2 with
     | Some v1, Some v2 => eval_op op v1 v2
     | _, _ => None
     end
 end.

Inductive outcome: Set :=
 | Onormal: outcome
 | Oexit: nat -> outcome
 | Ogoto: label -> outcome
 | Oreturn: value -> outcome.

Definition outcome_block (out: outcome) : outcome :=
 match out with
 | Onormal => Onormal
 | Oexit O => Onormal
 | Oexit (S m) => Oexit m
 | Ogoto lbl => Ogoto lbl
 | Oreturn v => Oreturn v
 end.

Fixpoint label_defined (lbl: label) (s: stmt) {struct s}: Prop :=
 match s with
 | Sskip => False
 | Sassign id e => False
 | Scall id fn e => False
 | Sreturn e => False
 | Sseq s1 s2 => label_defined lbl s1 \/ label_defined lbl s2
 | Sifthenelse e s1 s2 => label_defined lbl s1 \/ label_defined lbl s2
 | Sloop s1 => label_defined lbl s1
 | Sblock s1 => label_defined lbl s1
 | Sexit n => False
 | Slabel lbl1 s1 => lbl1 = lbl \/ label_defined lbl s1
 | Sgoto lbl => False
 end.

Inductive exec : stmt -> store -> outcome -> store -> Prop :=
 | exec_skip: forall st,
     exec Sskip st Onormal st
 | exec_assign: forall id e st v,
     eval_expr st e = Some v ->
     exec (Sassign id e) st Onormal (update id v st)
 | exec_call: forall id fn e st v1 f v2 st',
     eval_expr st e = Some v1 ->
     program fn = Some f ->
     exec_function f (update f.(fn_param) v1 empty_store) v2 st' ->
     exec (Scall id fn e) st Onormal (update id v2 st)
 | exec_return: forall e st v,
     eval_expr st e = Some v ->
     exec (Sreturn e) st (Oreturn v) st
 | exec_seq_2: forall s1 s2 st st1 out' st',
     exec s1 st Onormal st1 -> exec s2 st1 out' st' ->
     exec (Sseq s1 s2) st out' st'
 | exec_seq_1: forall s1 s2 st out st',
     exec s1 st out st' -> out <> Onormal ->
     exec (Sseq s1 s2) st out st'
 | exec_ifthenelse_true: forall e s1 s2 st out st' v,
     eval_expr st e = Some v -> is_true v -> exec s1 st out st' ->
     exec (Sifthenelse e s1 s2) st out st'
 | exec_ifthenelse_false: forall e s1 s2 st out st' v,
     eval_expr st e = Some v -> ~is_true v -> exec s2 st out st' ->
     exec (Sifthenelse e s1 s2) st out st'
 | exec_loop_loop: forall s st st1 out' st',
     exec s st Onormal st1 ->
     exec (Sloop s) st1 out' st' ->
     exec (Sloop s) st out' st'
 | exec_loop_stop: forall s st st' out,
     exec s st out st' -> out <> Onormal ->
     exec (Sloop s) st out st'
 | exec_block: forall s st out st',
     exec s st out st' ->
     exec (Sblock s) st (outcome_block out) st'
 | exec_exit: forall n st,
     exec (Sexit n) st (Oexit n) st
 | exec_label: forall s lbl st st' out,
     exec s st out st' ->
     exec (Slabel lbl s) st out st'
 | exec_goto: forall st lbl,
     exec (Sgoto lbl) st (Ogoto lbl) st

(** [execg lbl stmt st out st'] starts executing at label [lbl] within [s],
   in initial store [st].  The result of the execution is the outcome
   [out] with final store [st']. *)

with execg: label -> stmt -> store -> outcome -> store -> Prop :=
 | execg_left_seq_2: forall lbl s1 s2 st st1 out' st',
     execg lbl s1 st Onormal st1 -> exec s2 st1 out' st' ->
     execg lbl (Sseq s1 s2) st out' st'
 | execg_left_seq_1: forall lbl s1 s2 st out st',
     execg lbl s1 st out st' -> out <> Onormal ->
     execg lbl (Sseq s1 s2) st out st'
 | execg_right_seq: forall lbl s1 s2 st out st',
     ~(label_defined lbl s1) ->
     execg lbl s2 st out st' ->
     execg lbl (Sseq s1 s2) st out st'
 | execg_ifthenelse_left: forall lbl e s1 s2 st out st',
     execg lbl s1 st out st' ->
     execg lbl (Sifthenelse e s1 s2) st out st'
 | execg_ifthenelse_right: forall lbl e s1 s2 st out st',
     ~(label_defined lbl s1) ->
     execg lbl s2 st out st' ->
     execg lbl (Sifthenelse e s1 s2) st out st'
 | execg_loop_loop: forall lbl s st st1 out' st',
     execg lbl s st Onormal st1 ->
     exec (Sloop s) st1 out' st' ->
     execg lbl (Sloop s) st out' st'
 | execg_loop_stop: forall lbl s st st' out,
     execg lbl s st out st' -> out <> Onormal ->
     execg lbl (Sloop s) st out st'
 | execg_block: forall lbl s st out st',
     execg lbl s st out st' ->
     execg lbl (Sblock s) st (outcome_block out) st'
 | execg_label_found: forall lbl s st st' out,
     exec s st out st' ->
     execg lbl (Slabel lbl s) st out st'
 | execg_label_notfound: forall lbl s lbl' st st' out,
     lbl' <> lbl ->
     execg lbl s st out st' ->
     execg lbl (Slabel lbl' s) st out st'

(** [exec_finish out st st'] takes the outcome [out] and the store [st]
 at the end of the evaluation of the program.  If [out] is a [goto],
 execute again the program starting at the corresponding label.
 Iterate this way until [out] is [Onormal]. *)

with exec_finish: function -> outcome -> store -> value -> store -> Prop :=
 | exec_finish_normal: forall f st v,
     exec_finish f (Oreturn v) st v st
 | exec_finish_goto: forall f lbl st out v st1 st',
     execg lbl f.(fn_body) st out st1 ->
     exec_finish f out st1 v st' ->
     exec_finish f (Ogoto lbl) st v st'

(** Execution of a function *)

with exec_function: function -> store -> value -> store -> Prop :=
 | exec_function_intro: forall f st out st1 v st',
     exec f.(fn_body) st out st1 ->
     exec_finish f out st1 v st' ->
     exec_function f st v st'.

Scheme exec_ind4:= Minimality for exec Sort Prop
 with execg_ind4:= Minimality for execg Sort Prop
 with exec_finish_ind4 := Minimality for exec_finish Sort Prop
 with exec_function_ind4 := Minimality for exec_function Sort Prop.

Scheme exec_dind4:= Induction for exec Sort Prop
 with execg_dind4:= Minimality for execg Sort Prop
 with exec_finish_dind4 := Induction for exec_finish Sort Prop
 with exec_function_dind4 := Induction for exec_function Sort Prop.

Combined Scheme exec_inductiond from exec_dind4, execg_dind4, exec_finish_dind4,
  exec_function_dind4.

Scheme exec_dind4' := Induction for exec Sort Prop
 with execg_dind4' := Induction for execg Sort Prop
 with exec_finish_dind4' := Induction for exec_finish Sort Prop
 with exec_function_dind4' := Induction for exec_function Sort Prop.

Combined Scheme exec_induction from exec_ind4, execg_ind4, exec_finish_ind4,
  exec_function_ind4.

Combined Scheme exec_inductiond' from exec_dind4', execg_dind4', exec_finish_dind4',
  exec_function_dind4'.


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

Require Import Setoid.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import embed.
Require Import joinable.
Require Import approx_rels.
Require Import profinite.
Require Import profinite_adj.
Require Import cont_functors.

(**  * Continuous adjoint functors

     Here we lift the lifting and forgetful adjoint functors into the
     category of embeddings and prove that they are continuous.
  *)

Definition forgetEMBED_map (A B:ob PLT) (f:A ⇀ B) : forgetPLT_ob A ⇀ forgetPLT_ob B :=
  Embedding true (forgetPLT_ob A) (forgetPLT_ob B)
    (@embed_map false A B f)
    (@embed_mono false A B f)
    (@embed_reflects false A B f)
    (fun _ => I)
    (@embed_directed2 false A B f).

Program Definition forgetEMBED : functor (EMBED false) (EMBED true) :=
  Functor (EMBED false) (EMBED true) forgetPLT_ob forgetEMBED_map _ _ _.
Solve Obligations of forgetEMBED using auto.

Program Definition liftEMBED_map (A B:ob ∂PLT) (f:A ⇀ B) : liftPPLT_ob A ⇀ liftPPLT_ob B :=
  Embedding false (liftPPLT_ob A) (liftPPLT_ob B)
    (fun x => match x with None => None | Some a => Some (f a) end)
    _ _ _ _.
Next Obligation.
  simpl. intros.
  destruct a; destruct a'; simpl; auto.
  apply embed_mono. auto.
Qed.
Next Obligation.
  simpl. intros.
  destruct a; destruct a'; simpl; auto.
  apply embed_reflects with B f; auto.
Qed.
Next Obligation.
  intros. exists None. hnf. auto.
Qed.
Next Obligation.
  simpl. intros.
  destruct a; destruct b.
  destruct y.
  destruct embed_directed2 with true A B f c1 c c0 as [q [?[??]]]; auto.
  exists (Some q); auto.
  elim H.
  exists (Some c). auto.
  exists (Some c). auto.
  exists None. auto.
Qed.

Program Definition liftEMBED : functor (EMBED true) (EMBED false) :=
  Functor (EMBED true) (EMBED false) liftPPLT_ob liftEMBED_map _ _ _.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct x; simpl.
  destruct H. apply H. auto.
  destruct x; simpl.
  destruct H. apply H0. auto.
Qed.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct x. destruct H. apply H. auto.
  destruct x. destruct H. apply H0. auto.
Qed.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct x. destruct H. apply H. auto.
  destruct x. destruct H. apply H0. auto.
Qed.

Require Import bilimit.

Lemma forgetEMBED_continuous : continuous_functor forgetEMBED.
Proof.
  hnf; intros.
  apply decompose_is_colimit; simpl.
  intros.
  destruct (colimit_decompose _ I DS CC X x) as [i [s H]].
  exists i. exists s. auto.
Qed.

Lemma liftEMBED_continuous : continuous_functor liftEMBED.
Proof.
  hnf; intros.
  apply decompose_is_colimit; simpl.
  intros.
  destruct x.
  destruct (colimit_decompose _ I DS CC X c) as [i [s H]].
  exists i. exists (Some s). auto.
  destruct (directed.choose_ub_set I nil) as [i0 ?].
  exists i0. exists None. auto.
Qed.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Platform.Cito.Transit.
  Require Import Platform.Cito.Semantics.

  Require Import Platform.Cito.Syntax.
  Require Import Platform.Cito.GLabel.
  Require Import Platform.Cito.GLabelMap.
  Import GLabelMap.
  Require Import Platform.Cito.SemanticsExpr.
  Require Import Platform.Cito.GeneralTactics Platform.Cito.GeneralTactics2 Platform.Cito.GeneralTactics3.

  Notation Callee := (@Callee ADTValue).

  Definition Specs := GLabelMap.t Callee.

  Definition f_var := "_f".

  Notation State := (@State ADTValue).

  Definition RunsToDCall specs retvar f args (v v' : State) :=
    match find f specs with
      | Some (Semantics.Foreign spec) =>
        exists inputs outputs ret_w ret_a f_w,
          let vs := upd (fst v) f_var f_w in
          TransitTo spec (List.map (eval vs) args) inputs outputs ret_w ret_a (snd v) (snd v') /\
          fst v' = upd_option vs retvar ret_w
      | _ => True
    end.

  Definition SafeDCall specs f args (v : State) :=
    match find f specs with
      | Some (Semantics.Foreign spec) =>
        forall f_w,
          let vs := upd (fst v) f_var f_w in
          exists inputs, TransitSafe spec (List.map (eval vs) args) inputs (snd v)
      | _ => False
    end.

  (* shallow embedding *)
  Definition assert := Specs -> State -> State -> Prop.
  Definition entailment := Specs -> Prop.

  Inductive StmtEx :=
  | SkipEx : StmtEx
  | SeqEx : StmtEx -> StmtEx -> StmtEx
  | IfEx : Expr -> StmtEx -> StmtEx -> StmtEx
  | WhileEx : assert -> Expr -> StmtEx -> StmtEx
  | AssignEx : string -> Expr -> StmtEx
  | AssertEx : assert -> StmtEx
  | DCallEx : option string -> glabel -> list Expr -> StmtEx.

  Definition and_lift (a b : assert) : assert := fun specs v v' => a specs v v' /\ b specs v v'.
  Definition or_lift (a b : assert) : assert := fun specs v v' => a specs v v' \/ b specs v v'.
  Definition imply_close (a b : assert) : entailment := fun specs => forall v v', a specs v v' -> b specs v v'.

  Infix "/\" := and_lift : assert_scope.
  Infix "\/" := or_lift : assert_scope.
  Infix "-->" := imply_close (at level 90) : assert_scope.

  Close Scope equiv_scope.

  Definition is_true e : assert := fun _ _ v => eval (fst v) e <> $0.
  Definition is_false e : assert := fun _ _ v => eval (fst v) e = $0.

  Open Scope assert_scope.

  Fixpoint to_stmt s :=
    match s with
      | SkipEx => Syntax.Skip
      | SeqEx a b => Syntax.Seq (to_stmt a) (to_stmt b)
      | IfEx e t f => Syntax.If e (to_stmt t) (to_stmt f)
      | WhileEx _ e b => Syntax.While e (to_stmt b)
      | AssignEx x e => Syntax.Assign x e
      | AssertEx _ => Syntax.Skip
      | DCallEx x f args => Syntax.Seq (Syntax.Label f_var f) (Syntax.Call x (Var f_var) args)
    end.

  Coercion to_stmt : StmtEx >-> Stmt.

  Fixpoint sp (stmt : StmtEx) (p : assert) : assert :=
    match stmt with
      | SeqEx a b => sp b (sp a p)
      | IfEx e t f => sp t (p /\ is_true e) \/ sp f (p /\ is_false e)
      | WhileEx inv e _ => inv /\ is_false e
      | AssertEx a => a
      | SkipEx => p
      | AssignEx x e =>
        (fun specs v0 v' =>
           exists v,
             p specs v0 v /\
             v' = (upd (fst v) x (eval (fst v) e), snd v))%type
      | DCallEx x f args =>
        (fun specs v0 v' =>
           exists v,
             p specs v0 v /\
             RunsToDCall specs x f args v v')%type
    end.

  Fixpoint vc stmt (p : assert) : list entailment :=
    match stmt with
      | SeqEx a b => vc a p ++ vc b (sp a p)
      | IfEx e t f => vc t (p /\ is_true e) ++ vc f (p /\ is_false e)
      | WhileEx inv e body =>
        (p --> inv) :: (sp body (inv /\ is_true e) --> inv) :: vc body (inv /\ is_true e)
      | AssertEx a => (p --> a) :: nil
      | SkipEx => nil
      | AssignEx _ _ => nil
      | DCallEx x f args => (p --> (fun specs _ v => SafeDCall specs f args v)) :: nil
    end.

  Definition and_all : list entailment -> entailment := fold_right (fun a b specs => a specs /\ b specs)%type (fun _ => True).

  Lemma and_all_app : forall ls1 ls2 specs, and_all (ls1 ++ ls2) specs -> and_all ls1 specs /\ and_all ls2 specs.
    induction ls1; simpl; intuition.
    eapply IHls1 in H1; openhyp; eauto.
    eapply IHls1 in H1; openhyp; eauto.
  Qed.

  Lemma is_true_intro : forall e specs v v', wneb (eval (fst v') e) $0 = true -> (is_true e) specs v v'.
    intros.
    unfold is_true.
    unfold wneb in *.
    destruct (weq _ _) in *; intuition.
  Qed.

  Hint Resolve is_true_intro.

  Lemma is_false_intro : forall e specs v v', wneb (eval (fst v') e) $0 = false -> (is_false e) specs v v'.
    intros.
    unfold is_false.
    unfold wneb in *.
    destruct (weq _ _) in *; intuition.
  Qed.

  Hint Resolve is_false_intro.

  Hint Constructors Semantics.RunsTo.
  Hint Constructors Semantics.Safe.

  Ltac inject :=
    match goal with
      | H : _ = _ |- _ => unfold_all; injection H; intros; subst
    end.

  Definition Env := ((glabel -> option W) * (W -> option Callee))%type.

  Open Scope type.

  Definition specs_fs_agree (specs : Specs) (env : Env) :=
    let labels := fst env in
    let fs := snd env in
    forall p spec,
      fs p = Some spec <->
      exists (lbl : glabel),
        labels lbl = Some p /\
        find lbl specs = Some spec.

  Definition labels_in_scope (specs : Specs) (labels : glabel -> option W) :=
    forall lbl, In lbl specs -> labels lbl <> None.

  Definition specs_stn_injective (specs : Specs) stn := forall lbl1 lbl2 (w : W), In lbl1 specs -> In lbl2 specs -> stn lbl1 = Some w -> stn lbl2 = Some w -> lbl1 = lbl2.

  Definition specs_env_agree (specs : Specs) (env : Env) :=
    labels_in_scope specs (fst env) /\
    specs_stn_injective specs (fst env) /\
    specs_fs_agree specs env.

  Require Import Platform.Cito.GLabelMapFacts.
  Require Import Platform.Cito.Option.

  Require Import Platform.Cito.BedrockTactics.

  Lemma RunsTo_RunsToDCall :
    forall specs env r f args v v',
      specs_env_agree specs env ->
      RunsTo env (DCallEx r f args) v v' ->
      RunsToDCall specs r f args v v'.
  Proof.
    intros.
    simpl in *.
    unfold RunsToDCall.
    inv_clear H0.
    inv_clear H3.
    destruct (option_dec(find f specs)).
    destruct s; rewrite e; simpl in *.
    destruct x; simpl in *.
    destruct H; simpl in *.
    destruct env; simpl in *.
    rename a into f0.
    assert (o0 w = Some (Foreign f0)).
    eapply H0.
    descend; eauto.
    generalize H6; intro HH.
    inv_clear H6; simpl in *.
    sel_upd_simpl; rewrite H7 in H1; discriminate.
    sel_upd_simpl; rewrite H7 in H1; injection H1; intros; subst.
    eapply RunsTo_TransitTo in HH.
    Focus 2.
    simpl; sel_upd_simpl; eauto.
    openhyp.
    destruct r; simpl in *.
    subst; simpl in *.
    descend.
    eauto.
    sel_upd_simpl; eauto.
    descend.
    eauto.
    eauto.
    eauto.
    rewrite e; eauto.
  Qed.

  Lemma SafeDCall_Safe :
    forall specs env r f args v,
      specs_env_agree specs env ->
      SafeDCall specs f args v ->
      Safe env (DCallEx r f args) v.
  Proof.
    intros.
    destruct H.
    destruct env; simpl in *.
    unfold SafeDCall in *.
    destruct (option_dec(find f specs)).
    destruct s; rewrite e in *; simpl in *.
    destruct x.
    econstructor.
    econstructor.
    eapply H.
    eapply MapsTo_In; eapply find_mapsto_iff; eauto.
    intros.
    inv_clear H2.
    specialize (H0 w); clear H.
    destruct H0 as [inputs Htsf].
    eapply TransitSafe_Safe; eauto.
    sel_upd_simpl.
    eapply H1.
    descend; eauto.
    intuition.
    rewrite e in *; eauto.
    intuition.
  Qed.

  Lemma sound_runsto' : forall env (s : Stmt) v v', RunsTo env s v v' -> forall s' : StmtEx, s = s' -> forall specs, specs_env_agree specs env -> forall p, and_all (vc s' p) specs -> forall v0, p specs v0 v -> (sp s' p) specs v0 v'.
    induction 1; simpl; intros; destruct s'; try discriminate; simpl in *; try inject.

    (* skip *)
    eauto.

    openhyp.
    eauto.

    (* seq *)
    eapply_in_any and_all_app; openhyp.
    eauto.

    (* call *)
    openhyp.
    descend.
    eauto.
    eapply RunsTo_RunsToDCall; simpl; eauto.

    (* if *)
    eapply_in_any and_all_app; openhyp.
    left.
    eapply IHRunsTo; eauto.
    split; eauto.

    eapply_in_any and_all_app; openhyp.
    right.
    eapply IHRunsTo; eauto.
    split; eauto.

    (* while *)
    openhyp.
    eapply (IHRunsTo2 (WhileEx _ e s')); simpl in *; eauto.
    eapply IHRunsTo1; simpl in *; eauto.
    split; eauto.

    openhyp.
    split; eauto.

    (* assign *)
    descend; eauto.
  Qed.

  Theorem sound_runsto : forall env (s : StmtEx) v v' specs p, RunsTo env s v v' -> specs_env_agree specs env -> and_all (vc s p) specs -> p specs v v -> (sp s p) specs v v'.
    intros.
    eapply sound_runsto'; eauto.
  Qed.

  Close Scope assert_scope.

  Theorem sound_safe : forall specs env (s : Stmt) (s' : StmtEx) v p v0, s = s' -> specs_env_agree specs env -> and_all (vc s' p) specs -> p specs v0 v -> Safe env s v.
    intros.
    eapply (Safe_coind (fun s v => Safe env s v \/ exists (s' : StmtEx) p v0, s = s' /\ and_all (vc s' p) specs /\ p specs v0 v)); [ .. | right; descend; eauto]; generalize H0; clear; intros; openhyp.

    (* seq *)
    inversion H; subst.
    descend; left; eauto.

    destruct x; try discriminate; simpl in *; try inject.
    eapply_in_any and_all_app; openhyp.
    descend.
    right; descend; eauto.
    intros.
    eapply sound_runsto' with (p := x0) in H4; eauto.
    right; descend; eauto.

    (* dcall *)

    openhyp.
    eapply H1 in H2.
    eapply SafeDCall_Safe in H2; eauto.
    simpl in *.
    inv_clear H2.
    split.
    eauto.
    intros.
    eauto.

    (* if *)
    inversion H; subst.
    openhyp; subst.
    left; descend.
    eauto.
    left; eauto.
    right; descend.
    eauto.
    left; eauto.

    destruct x; try discriminate; simpl in *; try inject.
    eapply_in_any and_all_app; openhyp.
    unfold wneb.
    destruct (weq (eval (fst v) e) $0) in *.
    right.
    descend; eauto.
    right; descend; eauto.
    split; eauto.
    left.
    descend; eauto.
    right; descend; eauto.
    split; eauto.

    (* while *)
    inversion H; unfold_all; subst.
    left; descend.
    eauto.
    left; eauto.
    left; eauto.
    right; eauto.

    destruct x; try discriminate; simpl in *; try inject.
    openhyp.
    unfold wneb.
    destruct (weq (eval (fst v) e) $0) in *.
    right.
    eauto.
    left.
    descend; eauto.
    right.
    descend; eauto.
    split; eauto.
    right.
    eapply sound_runsto' with (p := and_lift a (is_true e)) in H5; eauto.
    descend.
    instantiate (1 := WhileEx _ e x).
    eauto.
    2 : eauto.
    simpl.
    descend; eauto.
    split; eauto.

    (* call *)
    inversion H; unfold_all; subst.
    left; descend; eauto.
    right; descend; eauto.

    destruct x; try discriminate; simpl in *; try inject.

    (* label *)
    inversion H; unfold_all; subst.
    eauto.

    destruct x0; try discriminate; simpl in *; try inject.
  Qed.

End ADTValue.


Set Universe Polymorphism.
Require Import Showable String List DepEquivAnti DepEquiv HoTT.

Notation "{ x : A & P }" := (sigT_HSet A (fun x => P)) : type_scope.

(** * Higher-order dependent equivalences *)

(**

We enrich the dependent equivalence class with instances matching
higher-order types.

 *)

(** Triggers for lifting and unlifing search: *)

(* =lift= *)
Definition lift {A: HSet} {B_1 B_2: A ->HSet}{C_1 C_2: HSet}
    `{(forall a, B_1 a ⇀ B_2 a)  ≲ (C_1 ⇀ C_2)} :
    (forall a, B_1 a -> B_2 a) -> C_1 ⇀ C_2  :=
  fun f => c_fun (fun a b => creturn (f a b)).
(* =end= *)

Definition liftA {A: HSet} {B_1 B_2: A ->HSet}{C_1 C_2: HSet}
    `{(forall a, B_1 a ⇀ B_2 a)  ≈ (C_1 ⇀ C_2)} :
    (forall a, B_1 a -> B_2 a) -> C_1 ⇀ C_2  :=
  fun f => ac_fun (fun a b => creturn (f a b)).

(* =unlift= *)
Definition unlift {A: HSet}{B_1 B_2: A -> HSet}{C_1 C_2: HSet}
  `{(forall a, B_1 a ⇀ B_2 a) ≲ (C_1 ⇀ C_2)} :
   (C_1 -> C_2) -> forall a, B_1 a ⇀ B_2 a
(* =end= *)
  := fun ff => c_inv _ (IsConnection := c_isconn (Connection := H)) (clift ff).

Definition unliftA {A:HSet} {B: A -> HSet} {C : A -> HSet} {B_ C_:HSet}
           {H :(forall a, B a ⇀ (C a)) ≈ (B_ ⇀ C_)} :
  (B_ -> C_) -> forall a, B a ⇀ (C a)
  := fun ff => ac_inv _  (clift ff).

Definition lift2 {A A': HSet}
           {B: A -> A' -> HSet} {C: A -> A' -> HSet} {D : A -> A' -> HSet}
           {B_ C_ D_:Type}
           {HB_: IsHSet B_}
           {HC_: IsHSet C_}
           {HD_: IsHSet D_}
           `{(forall a a', B a a' -> C a a' ⇀ D a a') ≲ (hset B_ -> hset C_ ⇀ hset D_)} :
  (forall a a', B a a' -> C a a' -> D a a') -> B_ -> C_ ⇀ D_.
  intros ff. pose (c := fun a a' b c => creturn (ff a a' b c)).
  refine (c_fun c).
  exact H.
Defined.

Definition lift2A {A A': HSet}
           {B: A -> A' -> HSet} {C: A -> A' -> HSet} {D : A -> A' -> HSet}
           {B_ C_ D_:Type}
           {HB_: IsHSet B_}
           {HC_: IsHSet C_}
           {HD_: IsHSet D_}
           `{(forall a a', B a a' -> C a a' ⇀ D a a') ≈ (hset B_ -> hset C_ ⇀ hset D_)} :
  (forall a a', B a a' -> C a a' -> D a a') -> B_ -> C_ ⇀ D_.
  intros ff. pose (c := fun a a' b c => creturn (ff a a' b c)).
  refine (ac_fun c).
  exact H.
Defined.

(** ** Domain transformation: *)

Instance HOAnticonnection_easy (A:HSet) (B: A -> HSet) (C:HSet)(C': HSet)
         (H: B ≈K□ C)
  : (* ------------------------------------*)
         (forall a, B a ⇀ C') ≈ (C ⇀ C')
  | 0
  := {| ac_fun := Build_Mon (to_simpl_dom : (∀ a : A, B a ⇀ C') -> C ⇀ C') _ _;
        ac_isconn := {| ac_inv := Build_Mon to_dep_dom _ _ |}|}.
Proof.
  + intros f g Hfg c. cbn in *. unfold to_simpl_dom.
    destruct (a_c_to_a c) as [a|]; simpl; eauto.
    destruct (to_dep a c) as [b|]; simpl; eauto.
    specialize (Hfg a b). revert Hfg. destruct (f a b); simpl; eauto.
  + cbn. unfold to_simpl_dom. intro x.
    destruct (a_c_to_a x) as [a|]; simpl; eauto; try apply irr_Fail.
    destruct (to_dep a x); simpl; eauto; apply irr_Fail.
  + intros f g Hfg a b. cbn in *. unfold to_dep_dom, kleisliComp.
    destruct (to_simpl b) as [c | c]; simpl; eauto.
    specialize (Hfg c). revert Hfg. simpl. destruct (f c) as [c' | c']; simpl; eauto.
  + cbn. unfold to_dep_dom, kleisliComp. intros a b.
    destruct (to_simpl b) as [c | c]; simpl; eauto; try apply irr_Fail.
  + intros f a b. simpl.
    unfold compose, to_dep_dom, to_simpl_dom in *; simpl in *.
    assert (H'1'1: (a_c_to_a °° (apc_fun (a_partial_equiv a))) (e_fun (a_total_equiv a) b) = Some a)
      by apply a_prop_c_to_a.
    unfold kleisliComp in H'1'1. unfold to_simpl, b_to_c.
    unfold to_dep, to_rich. simpl.
    pose (r:=apc_sect (IsAnticonnectionK := apc_isconn (a := DepAnticonnection_ConnectionK _ _ _ _ ))  _ b).
    generalize dependent r. unfold kleisliComp, to_simpl. cbn in *.  simpl.
    unfold to_simpl, to_dep, b_to_c, compose.
    revert H'1'1.
    Set Printing All. simpl.
    destruct ((@apc_fun (sigT_HSet C (fun c : _typeS C => @a_P A B C H a c)) C
                 (@a_partial_equiv A B C H a)
                 (@e_fun (_typeS (B a))
                    (@sigT (_typeS C) (fun x : _typeS C => _typeP (@a_P A B C H a x)))
                    (@a_total_equiv A B C H a) b))) as [c|c]; simpl ; eauto.
    simpl; intro e. rewrite e. clear e. simpl in *.
    Unset Printing All.
    destruct (apc_inv _ c) as [c0|]; simpl; eauto.
    intro e. inversion e.  rewrite H1.
    destruct (f a b) as [c''|]; simpl; eauto.
  + intros f c.
    unfold compose, to_dep_dom, to_simpl_dom, to_dep, to_rich, to_simpl in *; simpl in *.
    destruct (a_c_to_a c) as [a|]; simpl; eauto.
    pose (r:= apc_retr (IsAnticonnectionK := apc_isconn (a := DepAnticonnection_ConnectionK _ _ _ a)) _ c). unfold kleisliComp in *.
    generalize dependent r. cbn in *. unfold to_dep, to_rich, to_simpl,compose.
    destruct (apc_inv _ c) as [s|]; simpl ; eauto.
    destruct ( @apc_fun (sigT_HSet C (fun c0 : _typeS C => @a_P A B C H a c0)) C
            (@a_partial_equiv A B C H a)
            (@e_fun (_typeS (B a))
               (@sigT (_typeS C) (fun x : _typeS C => _typeP (@a_P A B C H a x)))
               (@a_total_equiv A B C H a)
               (@e_inv (_typeS (B a))
                  (@sigT (_typeS C) (fun x : _typeS C => _typeP (@a_P A B C H a x)))
                  (@e_fun (_typeS (B a))
                     (@sigT (_typeS C) (fun x : _typeS C => _typeP (@a_P A B C H a x)))
                     (@a_total_equiv A B C H a))
                  (@e_isequiv (_typeS (B a))
                     (@sigT (_typeS C) (fun x : _typeS C => _typeP (@a_P A B C H a x)))
                     (@a_total_equiv A B C H a)) s))) as [s'|]; simpl; eauto.
    intro e. inversion e. clear e.
     destruct (f c); simpl ; eauto.
Defined.

Instance HOConnection_easy (A:HSet) (B: A -> HSet) (C:HSet)(C': HSet)
         (H: B ≲K□ C)
  : (* ------------------------------------*)
         (forall a, B a ⇀ C') ≲ (C ⇀ C')
| 0.
Proof.
  unshelve eapply Connection_Anticonnection_K. cbn.
  intros f a b. simpl.
  unfold compose, to_dep_dom, to_simpl_dom in *; simpl in *.
  assert (H'1'1: (c_to_a °° (pc_fun (partial_equiv a))) (e_fun (total_equiv a) b) = Some a)
    by apply prop_c_to_a.
  unfold kleisliComp in H'1'1. unfold to_simpl, b_to_c.
  unfold to_dep, to_rich. simpl.
  pose (r:=pc_sect (IsConnectionK := pc_isconn (c := DepConnection_ConnectionK _ _ _ _ ))  _ b).
  generalize dependent r. unfold kleisliComp, to_simpl. cbn in *.  simpl.
  unfold to_simpl, to_dep, b_to_c, compose.
  revert H'1'1.
  Set Printing All. simpl.
  destruct ((@pc_fun (sigT_HSet C (fun c : _typeS C => @P A B C H a c)) C
                 (@partial_equiv A B C H a)
                 (@e_fun (_typeS (B a))
                    (@sigT (_typeS C) (fun x : _typeS C => _typeP (@P A B C H a x)))
                    (@total_equiv A B C H a) b))) as [c|c]; simpl ; eauto.
    simpl; intro e. rewrite e. clear e. simpl in *.
    Unset Printing All.
    destruct (pc_inv _ c) as [c0|]; simpl; eauto.
    intro e. inversion e. rewrite <- H1.
    destruct (f a b) as [c''|]; simpl; eauto.
    intro e; inversion e.
    intro e; inversion e.
Defined.

(** ** Domain & co-domain transformation: *)

(* =HODepEquiv= *)
Instance HOConnectionAnti {A: HSet} {B_1 B_2: A -> HSet} {C_1 C_2: HSet}:
  (B_1 ≈K□ C_1) -> (B_2 ≈K□ C_2) -> (forall a, B_1 a ⇀ B_2 a) ≈ (C_1 ⇀ C_2)
  := fun _ _ =>
       {| ac_fun := Build_Mon
                    (fun f => to_simpl_dom (fun a b => x <- f a b; to_simpl x)) _ _ ;
          ac_isconn := {| ac_inv := Build_Mon
                    (fun f a b => x <- to_dep_dom f a b; to_dep _ x) _ _ |}|}.
(* =end= *)
Proof.
+ intros f g Hfg c. cbn in *. unfold to_simpl_dom.
  destruct (a_c_to_a c) as [a|]; simpl; eauto.
  destruct (to_dep a c) as [b|]; simpl; eauto.
  specialize (Hfg a b). revert Hfg. destruct (f a b); simpl; eauto.
  destruct (g a b) as [b1|]; simpl; intro e; inversion e; try reflexivity.
  destruct (to_simpl b1); simpl; eauto.
+ cbn. unfold to_simpl_dom. intro x.
  destruct (a_c_to_a x) as [a|]; simpl; eauto; try apply irr_Fail.
  destruct (to_dep a x); simpl; eauto; apply irr_Fail.
+ intros f g Hfg a b. cbn in *. unfold to_dep_dom, to_dep_dom, kleisliComp.
  destruct (to_simpl b) as [c | c]; simpl; eauto.
  specialize (Hfg c). revert Hfg. destruct (f c); simpl; eauto.
  destruct (g c) as [c1 | c1]; simpl; intro e; inversion e.
  subst. destruct (to_dep a c1); simpl; eauto.
+ cbn. unfold to_dep_dom, kleisliComp. intros a b.
  destruct (to_simpl b); simpl; eauto; try apply irr_Fail.
+ intros f a b.  unfold compose in *. cbn in *.
  unfold to_dep_dom, to_dep_dom, to_simpl_dom in *.

    assert (H'1'1: (a_c_to_a °° (apc_fun (a_partial_equiv a))) (e_fun (a_total_equiv a) b) = Some a)
    by apply a_prop_c_to_a.
  unfold kleisliComp in H'1'1. unfold to_simpl, b_to_c.

   unfold to_dep, to_rich. simpl.
   pose (r := apc_sect (IsAnticonnectionK := apc_isconn (a := DepAnticonnection_ConnectionK _ _ _ a )) _ b).
   generalize dependent r. unfold kleisliComp, to_simpl. cbn in *.  simpl.
  unfold to_simpl, to_dep, b_to_c,compose.
  revert H'1'1.
  Set Printing All. simpl.
  destruct (@apc_fun (sigT_HSet C_1 (fun c : _typeS C_1 => @a_P A B_1 C_1 _ a c)) C_1
                 (@a_partial_equiv A B_1 C_1 _ a)
                 (@e_fun (_typeS (B_1 a))
                    (@sigT (_typeS C_1)
                       (fun x : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x)))
                    (@a_total_equiv A B_1 C_1 _ a) b)) as [c | c]; simpl; eauto.
  Unset Printing All.
  intro e; rewrite e. clear e. simpl in *. unfold to_rich.
  destruct (apc_inv _ c) as [s | ]; simpl; eauto.
  intro e; inversion e.
  destruct (f a
      (@e_inv (_typeS (B_1 a))
         (@sigT (_typeS C_1) (fun x : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x)))
         (@e_fun (_typeS (B_1 a))
            (@sigT (_typeS C_1) (fun x : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x)))
            (@a_total_equiv A B_1 C_1 _ a))
         (@e_isequiv (_typeS (B_1 a))
            (@sigT (_typeS C_1) (fun x : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x)))
            (@a_total_equiv A B_1 C_1 _ a)) s) ) as [b0 |]; simpl; eauto.
  pose (r := apc_sect (IsAnticonnectionK := apc_isconn (a := DepAnticonnection_ConnectionK _ _ _ _ )) _ b0). simpl in r.
  generalize dependent r. unfold kleisliComp, to_simpl, to_dep, b_to_c, c_to_b,compose.
  Set Printing All. simpl.
  destruct (@apc_fun (sigT_HSet C_2 (fun c0 : _typeS C_2 => @a_P A B_2 C_2 _ a c0)) C_2
                (@a_partial_equiv A B_2 C_2 _ a)
                (@e_fun (_typeS (B_2 a))
                   (_typeS (sigT_HSet C_2 (fun c0 : _typeS C_2 => @a_P A B_2 C_2 _ a c0)))
                   (@a_total_equiv A B_2 C_2 _ a) b0)) as [c' | ]; simpl; eauto.
  Unset Printing All.
+ intros f x. cbn in *.
  unfold compose,  to_dep_dom, to_dep_dom, to_simpl_dom, to_simpl, clift, to_dep, to_rich in *;
    simpl in *.
  destruct (a_c_to_a x) as [a|]; simpl ; eauto.
  pose (r := apc_retr (IsAnticonnectionK := apc_isconn (a := DepAnticonnection_ConnectionK _ _ _  a)) _ x). unfold kleisliComp in *.
  generalize dependent r. cbn in *. unfold to_dep, to_rich, to_simpl,compose.
  destruct (apc_inv _ x) as [s|]; simpl ; eauto.
  destruct (@apc_fun (sigT_HSet C_1 (fun c : _typeS C_1 => @a_P A B_1 C_1 _ a c)) C_1
            (@a_partial_equiv A B_1 C_1 _ a)
            (@e_fun (_typeS (B_1 a))
               (@sigT (_typeS C_1) (fun x0 : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x0)))
               (@a_total_equiv A B_1 C_1 _ a)
               (@e_inv (_typeS (B_1 a))
                  (@sigT (_typeS C_1)
                     (fun x0 : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x0)))
                  (@e_fun (_typeS (B_1 a))
                     (@sigT (_typeS C_1)
                        (fun x0 : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x0)))
                     (@a_total_equiv A B_1 C_1 _ a))
                  (@e_isequiv (_typeS (B_1 a))
                     (@sigT (_typeS C_1)
                        (fun x0 : _typeS C_1 => _typeP (@a_P A B_1 C_1 _ a x0)))
                     (@a_total_equiv A B_1 C_1 _ a)) s))) as [c | c]; simpl; eauto.
  intro e. inversion e. simpl.
  destruct (f x) as [c0 | c0]; simpl; eauto.
  pose (r := apc_retr (IsAnticonnectionK := apc_isconn (a := DepAnticonnection_ConnectionK _ _ _ a)) _ c0). unfold kleisliComp in *.
  generalize dependent r. cbn in *. unfold to_dep, to_rich, to_simpl.
  destruct (apc_inv _ c0); simpl ; eauto.
Defined.

Instance HOConnection
  {A: HSet} {B_1 B_2: A -> HSet} {C_1 C_2: HSet}:
  (B_1 ≲K□ C_1) -> (B_2 ≲K□ C_2) -> (forall a, B_1 a ⇀ B_2 a)  ≲ (C_1 ⇀ C_2).
Proof.
  intros H1 H2. unshelve eapply Connection_Anticonnection_K. cbn.
  + intros f a b.  unfold compose in *. cbn in *.
  unfold to_dep_dom, to_dep_dom, to_simpl_dom in *.

    assert (H'1'1: (c_to_a °° (pc_fun (partial_equiv a))) (e_fun (total_equiv a) b) = Some a)
    by apply prop_c_to_a.
  unfold kleisliComp in H'1'1. unfold to_simpl, b_to_c.

    unfold to_dep, to_rich. simpl.
    pose (r := pc_sect (IsConnectionK := pc_isconn (c := DepConnection_ConnectionK _ _ _ a )) _ b).
    generalize dependent r. unfold kleisliComp, to_simpl. cbn in *.  simpl.
  unfold to_simpl, to_dep, b_to_c,compose.
  revert H'1'1.
  Set Printing All. simpl.
  destruct (@pc_fun (sigT_HSet C_1 (fun c : _typeS C_1 => @P A B_1 C_1 _ a c)) C_1
                 (@partial_equiv A B_1 C_1 _ a)
                 (@e_fun (_typeS (B_1 a))
                    (@sigT (_typeS C_1)
                       (fun x : _typeS C_1 => _typeP (@P A B_1 C_1 _ a x)))
                    (@total_equiv A B_1 C_1 _ a) b)) as [c | c]; simpl; eauto.
  Unset Printing All.
  intro e; rewrite e. clear e. simpl in *. unfold to_rich.
  destruct (pc_inv _ c) as [s | ]; simpl; eauto.
  intro e; inversion e.
  destruct (f a
      (@e_inv (_typeS (B_1 a))
         (@sigT (_typeS C_1) (fun x : _typeS C_1 => _typeP (@P A B_1 C_1 _ a x)))
         (@e_fun (_typeS (B_1 a))
            (@sigT (_typeS C_1) (fun x : _typeS C_1 => _typeP (@P A B_1 C_1 _ a x)))
            (@total_equiv A B_1 C_1 _ a))
         (@e_isequiv (_typeS (B_1 a))
            (@sigT (_typeS C_1) (fun x : _typeS C_1 => _typeP (@P A B_1 C_1 _ a x)))
            (@total_equiv A B_1 C_1 _ a)) s) ) as [b0 |]; simpl; eauto.
  pose (r := pc_sect (IsConnectionK := pc_isconn (c := DepConnection_ConnectionK _ _ _ _ )) _ b0). simpl in r.
  generalize dependent r. unfold kleisliComp, to_simpl, to_dep, b_to_c, c_to_b,compose.
  Set Printing All. simpl.
  destruct (@pc_fun (sigT_HSet C_2 (fun c0 : _typeS C_2 => @P A B_2 C_2 H2 a c0)) C_2
          (@partial_equiv A B_2 C_2 H2 a)
          (@e_fun (_typeS (B_2 a)) (@sigT (_typeS C_2) (fun x : _typeS C_2 => _typeP (@P A B_2 C_2 H2 a x)))
             (@total_equiv A B_2 C_2 H2 a) b0)) as [c' | ]; simpl; eauto.
  Unset Printing All.
  intro e. inversion e.
  intro e; inversion e.
Defined.

(** ** Argument reordering: *)

(* =HODepEquiv_2_sym= *)
Instance HOConnection_2_sym
   (A A': HSet) (B_1 B_2 B_3: A -> A' -> HSet) {C_1 C_2 C_3: HSet}
  `{ (forall a a', B_2 a a' -> B_1 a a' ⇀ B_3 a a') ≲ (C_2 -> C_1 ⇀ C_3) }:
    (forall a a', B_1 a a' -> B_2 a a' ⇀ B_3 a a') ≲ (C_1 -> C_2 ⇀ C_3)
(* =end= *)
  | 100
  := {| c_fun := Build_Mon (fun ff b_ c_ => c_fun (fun a a' c b => ff a a' b c) c_ b_) _ _;
        c_isconn :=
          {|c_inv := Build_Mon (fun ff a a' b c => (c_inv _ (IsConnection := c_isconn (Connection := H))) (fun c b => ff b c) _ _ c b) _ _ |}|}.
Proof.
  - intros x y H0 b c.
    pose (x' := fun a a' c b => x a a' b c).
    pose (y' := fun a a' c b => y a a' b c).
    assert (e : x' ≼ y'). intros x1 x2 x3 x4. apply H0.
    apply ((c_fun (Connection := H)).(mon) e).
  - intros b c.
    exact ((c_fun (Connection := H)).(p_mon _ _) c b).
  - intros x y H0 a a' b c.
    pose (x' := fun c b => x b c).
    pose (y' := fun c b => y b c).
    assert (e : x' ≼ y'). intros x1 x2. apply H0.
    apply ((c_inv _ (IsConnection := c_isconn (Connection := H))).(mon) e).
  - intros a a' b c.
    exact ((c_inv _ (IsConnection := c_isconn (Connection := H))).(p_mon _ _) a a' c b).
  - intros f a a' b c.
    exact (c_sect _ (IsConnection := c_isconn (Connection := H)) (fun a a' c b => f a a' b c) a a' c b).
  - intros f b c.
    exact (c_retr _ (IsConnection := c_isconn (Connection := H)) (fun c b => f b c) _ _).
  (* - simpl. intros f. apply funext. intro b. *)
  (*   apply funext; intro c. apply is_hprop. *)
Defined.

(** ** Arity 2 types: *)

Hint Extern 1 (IsConnection ?f) => apply (c_isconn (Connection := _)) :
             typeclass_instances.

(* =HOCoercion_2_fun= *)
Definition HOConnection_2_fun
  {A A': HSet} {B_1: A -> HSet} {B_2 B_3: A -> A' -> HSet} {C_1 C_2 C_3: HSet} :
  (B_1 ≈K□ C_1) -> (forall a, ((forall a': A', B_2 a a' ⇀ B_3 a a') ≲ (C_2 ⇀ C_3))) ->
  (forall a a', B_1 a → B_2 a a' ⇀ B_3 a a') -> C_1 -> C_2 ⇀ C_3 :=
  fun _ _ f c_1 c_2 => to_simpl_dom (fun a b_1 => c_fun (fun a' => f a a' b_1) c_2) c_1.
(* =end= *)

(* =to_dep_dom2= *)
Definition HOConnection_2_inv  {A A': HSet} {B_1: A -> HSet} {B_2 B_3: A -> A' -> HSet} {C_1 C_2 C_3: HSet} :
  (B_1 ≈K□ C_1) -> (forall a, ((forall a': A', B_2 a a' ⇀ B_3 a a') ≲ (C_2 ⇀ C_3))) ->
  (C_1 → C_2 ⇀ C_3) -> ∀ a a', B_1 a → B_2 a a' ⇀ B_3 a a' :=
  fun _ H f a a' b_1 b_2 =>
    c_inv (c_fun (Connection := H a)) (fun x => c_1 <- to_simpl b_1; f c_1 x) _ b_2.
(* =end= *)

(* =HODepEquiv2= *)
Instance HOConnection_2
  (A A': HSet) (B_1: A -> HSet) (B_2 B_3: A -> A' -> HSet) (C_1 C_2 C_3: HSet) :
  (B_1 ≲K□ C_1) -> (forall a, ((forall a': A', B_2 a a' ⇀ B_3 a a') ≲ (C_2 ⇀ C_3))) ->
  (forall a a', B_1 a -> B_2 a a' ⇀ B_3 a a') ≲ (C_1 -> C_2 ⇀ C_3).
(* =end= *)
Proof.
    unshelve refine (fun H H' =>
  {| c_fun := Build_Mon (HOConnection_2_fun (DepConnection_DepAnticonnection _ _ _ H) H') _ _ ;
     c_isconn := {| c_inv := Build_Mon (HOConnection_2_inv (DepConnection_DepAnticonnection _ _ _ H) H') _ _ |}|}).
  + intros f g e b c. simpl. unfold HOConnection_2_fun, to_simpl_dom.
    destruct (a_c_to_a b) as [a|] ;simpl; eauto.
    destruct (to_dep a b) ;simpl; eauto.
    refine ((c_fun (Connection := H' a)).(mon) _ _).
    intros x1 x2. apply e.
  + cbn. unfold HOConnection_2_fun, to_simpl_dom. intros b c.
    destruct (a_c_to_a b) as [a|]; simpl; eauto; try apply fail_contr.
    destruct (to_dep a b); simpl; eauto; try apply fail_contr.
    apply (c_fun (Connection := H' a) .(p_mon _ _) c).
  + intros f g e a a' b c. simpl. unfold to_dep_dom2. unfold HOConnection_2_inv.
    refine ((c_inv _ (IsConnection := c_isconn (Connection := H' a))).(mon) _ _ _).
    intros x1. destruct (to_simpl b) as [c'| c']; simpl ; eauto. apply e.
  + cbn. unfold HOConnection_2_inv, to_simpl_dom. intros a a' b c.
    destruct (to_simpl b) as[s | s]; simpl; try apply fail_contr; auto.
    apply (c_inv _ (IsConnection := c_isconn (Connection := H' a)) .(p_mon _ _) a' c).
    assert ((λ _ : C_2, @Fail C_3 _ s) = (λ _ : C_2, @Fail C_3 _ (_with "bot"))).
    apply funext. intro. apply ap. apply is_hprop.
    rewrite H0. apply (c_inv _ (IsConnection := c_isconn (Connection := H' a)) .(p_mon _ _) a' c).
  + intros ff a a' b c.
     unfold compose, HOConnection_2_inv, HOConnection_2_fun, to_simpl_dom in *; simpl in *.
  assert (H'1'1: (a_c_to_a °° (apc_fun (a_partial_equiv a))) (e_fun (a_total_equiv a) b) = Some a)
    by apply a_prop_c_to_a.
  unfold kleisliComp in H'1'1. unfold to_simpl, b_to_c.
  unfold to_dep, to_rich. simpl.
  pose (r := pc_sect (IsConnectionK := pc_isconn (c := DepConnection_ConnectionK _ _ _ _ )) _ b).
  generalize dependent r. unfold kleisliComp, to_simpl. cbn in *.  simpl.
  unfold to_simpl, to_dep, b_to_c,compose.
  revert H'1'1. cbn.
  Set Printing All. simpl.
  destruct (@pc_fun (sigT_HSet C_1 (fun c0 : _typeS C_1 => @P A B_1 C_1 H a c0)) C_1
                 (@partial_equiv A B_1 C_1 H a)
                 (@e_fun (_typeS (B_1 a))
                    (@sigT (_typeS C_1)
                       (fun x : _typeS C_1 => _typeP (@P A B_1 C_1 H a x)))
                    (@total_equiv A B_1 C_1 H a) b)) as [c0 | c0]; simpl; eauto.
  intro e; rewrite e. clear e. simpl in *. unfold to_rich.
  Unset Printing All.
  destruct (pc_inv _ c0); simpl; eauto.
  intro e. inversion e. rewrite <- H1.
  exact (c_sect (IsConnection := c_isconn (Connection := _)) _ (fun a' c => ff a a' b c) a' c).
  intro e; inversion e.
  intro e; inversion e.
  + intros ff b c.
    unfold compose, HOConnection_2_fun, to_simpl_dom, HOConnection_2_inv in *; simpl in *.
    destruct (c_to_a b) as [a|];simpl; [ |eauto].
    unfold to_dep, to_rich.
    pose (r := pc_retr (IsConnectionK := pc_isconn (c := DepConnection_ConnectionK _ _ _ a)) _ b). unfold kleisliComp in *.
  generalize dependent r. cbn in *. unfold to_dep, to_rich, to_simpl,compose. cbn.
  destruct (pc_inv _ b) as [s|]; simpl ; eauto.
  pose (e_retr (IsEquiv := e_isequiv (e := total_equiv a)) _ s).
  pose (r := c_retr (IsConnection := c_isconn (Connection := H' a)) _ (to_dep_dom2 ff a (c_to_b s)) c).
  generalize dependent r.
  unfold to_dep_dom2; cbn. unfold to_simpl. simpl.
  unfold compose, b_to_c, c_to_b in *.
  Set Printing All. simpl in *. rewrite e. clear e. Unset Printing All.
  destruct (pc_fun (partial_equiv a) s) as [c'|i]; simpl; eauto.
  intros e' e. inversion e. rewrite <- H1 in *. clear e H1. revert e'.
  exact (fun x => x).
  intros e _. revert e.
  pose (F := c_fun (c_inv _ (IsConnection := c_isconn (Connection := H' a)) (λ _ : C_2, @Fail C_3 _ i))).
  simpl in *.
  change (F c ≼ @Fail _ info_str i -> F c ≼ ff b c).
  destruct (F c); simpl; eauto.
  intro e; inversion e.
  (* + intro f. apply funext. intro. simpl. apply funext. intro. *)
  (*   apply is_hprop. *)
Defined.

(* This instance must be here because before, it would break some
   type class inferences, I don't understand why ?*)

(* =DepEquivInj= *)
Instance Connection_Inj (A A': HSet)(B: A -> HSet)(C: HSet)
  (f: A' -> A) `{IsInjective _ _ f}
  `{B ≲K□ C}: (fun a => B (f a)) ≲K□ C
(* =end= *)
  := Build_DepConnection A' (fun a => B (f a)) C (fun a c => P (f a) c)
                    (fun a' => total_equiv (f a'))
                    (λ a : A', partial_equiv (f a))
                    (fun c => a <- c_to_a c; f^?-1 a) _.
Proof.
  intros a' b. simpl.
  pose (prop_c_to_a (f a') b). generalize dependent e. unfold kleisliComp, b_to_c.
  Set Printing All. simpl.
  destruct (@pc_fun (sigT_HSet C (fun c : _typeS C => @P A B C H0 (f a') c)) C
                (@partial_equiv A B C H0 (f a'))
                (@e_fun (_typeS (B (f a')))
                   (@sigT (_typeS C) (fun x : _typeS C => _typeP (@P A B C H0 (f a') x)))
                   (@total_equiv A B C H0 (f a')) b)) as [c|]; simpl; intro e;inversion e.
  rewrite e. simpl.
  Unset Printing All.
  apply (i_sect a').
Defined.


(************************************************************
* Lambda-calculus with exceptions                           *
* Definition of an interpreter                              *
*************************************************************)

Set Implicit Arguments.
Require Export LambdaExn_Syntax.
Import AssumeDeterministic.
Import BehaviorsWithErrors.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : beh.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Results *)

(** Grammar of results of the interpreter *)

Inductive res :=
  | res_return : beh -> res
  | res_bottom : res.

Coercion res_return : beh >-> res.
Implicit Types r : res.

(************************************************************)
(* ** Monadic operators *)

(** Bind-style operators *)

Definition if_success (r:res) (k:val->res) : res :=
  match r with
  | res_return (beh_ret v) => k v
  | _ => r
  end.

Definition if_fault (r:res) (k:val->res) : res :=
  match r with
  | res_return (beh_exn v) => k v
  | _ => r
  end.

Definition if_isclo (v:val) (k:var->trm->res) : res :=
  match v with
  | val_clo x t => k x t
  | _ => beh_err
  end.

(************************************************************)
(* ** Interpreter *)

(** Definition of the interpreter *)

Fixpoint run (n:nat) (t:trm) : res :=
  match n with
  | O => res_bottom
  | S m =>
    match t with
    | trm_val v => v
    | trm_abs x t1 => val_clo x t1
    | trm_var x => beh_err
    | trm_app t1 t2 =>
       if_success (run m t1) (fun v1 =>
         if_success (run m t2) (fun v2 =>
            if_isclo v1 (fun x t3 =>
              run m (subst x v2 t3))))
    | trm_try t1 t2 =>
       if_fault (run m t1) (fun v => run m (trm_app t2 v))
    | trm_raise t1 =>
       if_success (run m t1) (fun v1 => beh_exn v1)
    | trm_rand => val_int 0
    end
  end.