From pv Require Import library.
Require Import String ZArith List.
Open Scope Z_scope.

From ReductionEffect Require Import PrintingEffect.

Require Coq.extraction.Extraction.
Extraction Language OCaml.

(* Language *)

Inductive ABinOp :=
    | add
    | sub
    | mul
    | div.

Inductive Aexp : Type :=
    | var : string -> Aexp
    | const : Z -> Aexp
    | opp : Aexp -> Aexp
    | aop : ABinOp -> Aexp -> Aexp -> Aexp.

Inductive BBinOp :=
    | eq
    | lt
    | gt
    | le
    | ge
    | ne.

Inductive Bexp : Type :=
    | tt : Bexp
    | ff : Bexp
    | bop : BBinOp -> Aexp -> Aexp -> Bexp
    | and : Bexp -> Bexp -> Bexp
    | or : Bexp -> Bexp -> Bexp.

Inductive While : Type :=
    | assign : string -> Aexp -> While
    | skip : While
    | sequence : While -> While -> While
    | if_then_else : Bexp -> While -> While -> While
    | while_do : Bexp -> While -> While.

(* Abstract Domain structure *)

Module Type AbstractDomain.

Parameter AbD : Type.
Parameter AbS : Type.
Parameter top_AbS : AbS.
Parameter bot_AbS : AbS.

Parameter ab_update : AbS -> string -> AbD -> AbS.
Parameter ab_lookup : AbS -> string -> AbD.
Parameter alpha_singleton : Z -> AbD.
Parameter ab_opp : AbD -> AbD.
Parameter ab_op : ABinOp -> AbD -> AbD -> AbD.
Parameter A_sharp : Aexp -> AbS -> AbD.

Parameter eq_sem : Aexp -> Aexp -> AbS -> AbS.
Parameter ne_sem : Aexp -> Aexp -> AbS -> AbS.
Parameter lt_sem : Aexp -> Aexp -> AbS -> AbS.
Parameter gt_sem : Aexp -> Aexp -> AbS -> AbS.
Parameter le_sem : Aexp -> Aexp -> AbS -> AbS.
Parameter ge_sem : Aexp -> Aexp -> AbS -> AbS.

Parameter join : AbD -> AbD -> AbD.
Parameter join_state : AbS -> AbS -> AbS.
Parameter ab_le : AbD -> AbD -> bool.
Parameter ab_le_state : AbS -> AbS -> bool.
Parameter widen : AbD -> AbD -> AbD.
Parameter widen_state : AbS -> AbS -> AbS.
Parameter narrow : AbD -> AbD -> AbD.
Parameter narrow_state : AbS -> AbS -> AbS.

End AbstractDomain.

(* Abstract Interpreter function *)

Module AbstractInterpreter (AbDom : AbstractDomain).
Import AbDom.

Fixpoint B_sharp b s_sharp :=
    match b with
    | tt => s_sharp
    | ff => bot_AbS
    | bop op e1 e2 => match op with
                        | eq => eq_sem e1 e2 s_sharp
                        | lt => lt_sem e1 e2 s_sharp
                        | gt => gt_sem e1 e2 s_sharp
                        | le => le_sem e1 e2 s_sharp
                        | ge => ge_sem e1 e2 s_sharp
                        | ne => ne_sem e1 e2 s_sharp
                        end
    | and b1 b2 => B_sharp b2 (B_sharp b1 s_sharp)
    | or b1 b2 => join_state (B_sharp b1 s_sharp) (B_sharp b2 s_sharp)
    end.

Fixpoint neg_sem b :=
    match b with
    | tt => ff
    | ff => tt
    | bop eq e1 e2 => bop ne e1 e2
    | bop lt e1 e2 => bop ge e1 e2
    | bop gt e1 e2 => bop le e1 e2
    | bop le e1 e2 => bop gt e1 e2
    | bop ge e1 e2 => bop lt e1 e2
    | bop ne e1 e2 => bop eq e1 e2
    | and b1 b2 => or (neg_sem b1) (neg_sem b2)
    | or b1 b2 => and (neg_sem b1) (neg_sem b2)
    end.

Definition step (AI_state : AbS -> AbS * list AbS) b s_sharp t_sharp :=
    let (v_sharp, invs) := (AI_state (B_sharp b t_sharp)) in (join_state s_sharp v_sharp, invs).

Definition is_inv AI_state s_sharp t_sharp b := let (u_sharp, _) := step AI_state b s_sharp t_sharp in ab_le_state t_sharp u_sharp.

Unset Guard Checking.

Fixpoint steps AI_state (b : Bexp) s_sharp t_sharp {struct b} :=
    if is_inv AI_state s_sharp t_sharp b
        then (t_sharp, [t_sharp])
    else
        let (u_sharp, invs1) := print_id (step AI_state b s_sharp t_sharp) in let (v_sharp, invs2) := steps AI_state b s_sharp u_sharp in (v_sharp, invs1 ++ invs2).

Fixpoint widening AI_state b s_sharp t_sharp {struct b} :=
    if is_inv AI_state s_sharp t_sharp b
        then t_sharp
    else
        let (u_sharp, _) := print_id (step AI_state b s_sharp t_sharp) in widening AI_state b s_sharp (widen_state t_sharp u_sharp).

Fixpoint narrowing AI_state b s_sharp t_sharp {struct b} :=
    let (u_sharp, _) := print_id (step AI_state b s_sharp t_sharp) in let v_sharp := narrow_state t_sharp u_sharp in
    if is_inv AI_state s_sharp v_sharp b
        then (v_sharp, [v_sharp])
    else
        let (w_sharp, invs1) := print_id (step AI_state b s_sharp v_sharp) in let (z_sharp, invs2) := narrowing AI_state b s_sharp (narrow_state v_sharp w_sharp) in (z_sharp, invs1 ++ invs2).

Set Guard Checking.

Definition ab_lfp AI_state b s_sharp (widen_toggle : bool) :=
    if widen_toggle then let t_sharp := widening AI_state b s_sharp s_sharp in narrowing AI_state b s_sharp t_sharp
    else steps AI_state b s_sharp s_sharp.

Fixpoint AI (P : While) widen_toggle s_sharp :=
    match P with
    | assign x e => ((ab_update s_sharp x (A_sharp e s_sharp)), nil)
    | skip => (s_sharp, nil)
    | sequence S1 S2 => let (t_sharp, invs1) := AI S1 widen_toggle s_sharp in let (u_sharp, invs2) := AI S2 widen_toggle t_sharp in (u_sharp, invs1 ++ invs2)
    | if_then_else b S1 S2 => let (t_sharp, invs1) := AI S1 widen_toggle (B_sharp b s_sharp) in let (u_sharp, invs2) := AI S2 widen_toggle (B_sharp (neg_sem b) s_sharp) in (join_state t_sharp u_sharp, invs1 ++ invs2)
    | while_do b S' => let (t_sharp, invs) := (ab_lfp (AI S' widen_toggle) b s_sharp widen_toggle) in (B_sharp (neg_sem b) t_sharp, invs)
    end.

End AbstractInterpreter.

(* Extended Sign domain *)

Module ExtendedSign <: AbstractDomain.

Inductive extended_sign :=
    | top
    | le0
    | ne0
    | ge0
    | lt0
    | eq0
    | gt0
    | bot.

Definition AbD := extended_sign.

Definition AbS := option (list (string * AbD)).

Definition top_AbS : AbS := Some nil.

Definition bot_AbS : AbS := None.

Fixpoint string_list_update {A} l x (a : A) :=
    match l with
    | nil => (x, a) :: nil
    | (y, a') :: tl => if string_dec x y then (y, a) :: tl else (y, a') :: string_list_update tl x a
    end.

Definition ab_update s_sharp x a : AbS :=
    match s_sharp with
    | Some l => Some (string_list_update l x a)
    | None => Some ((x, a) :: nil)
    end.

Fixpoint string_list_lookup l x :=
    match l with
    | nil => top
    | (y, a) :: tl => if string_dec x y then a else string_list_lookup tl x
    end.

Definition ab_lookup s_sharp x :=
    match s_sharp with
    | Some l => string_list_lookup l x
    | None => bot
    end.

Definition alpha_singleton n :=
    if n =? 0 then eq0
    else if n <? 0 then lt0
    else gt0.

Definition sign_eq_dec : forall (x y : AbD), { x = y } + { x <> y }.
Proof.
    decide equality.
Defined.

Definition ab_opp a :=
    match a with
    | lt0 => gt0
    | gt0 => lt0
    | le0 => ge0
    | ge0 => le0
    | a' => a'
    end.

Definition add_op a1 a2 :=
    match a1, a2 with
    | bot, _ | _, bot => bot
    | eq0, a3 | a3, eq0 => a3
    | lt0, le0 | le0, lt0 => lt0
    | gt0, ge0 | ge0, gt0 => gt0
    | ne0, ne0 => top
    | a3, a4 => if sign_eq_dec a3 a4 then a3 else top
    end.

Definition sub_op a1 a2 :=
    match a1, a2 with
    | bot, _ => bot
    | _, bot => bot
    | eq0, a3 => ab_opp a3
    | a3, eq0 => a3
    | lt0, gt0 | lt0, ge0 | le0, gt0 => lt0
    | gt0, lt0 | gt0, le0 | ge0, lt0 => gt0
    | le0, ge0 => le0
    | ge0, le0 => ge0
    | _, _ => top
    end.

Definition mul_op a1 a2 :=
    match a1, a2 with
    | bot, _ | _, bot => bot
    | eq0, _ | _, eq0 => eq0
    | lt0, a3 | a3, lt0 => ab_opp a3
    | gt0, a3 | a3, gt0 => a3
    | le0, le0 | ge0, ge0 => ge0
    | le0, ge0 | ge0, le0 => le0
    | ne0, ne0 => ne0
    | _, _ => top
    end.

Definition div_op a1 a2 :=
    match a1, a2 with
    | bot, _ | _, bot | _, eq0 => bot
    | eq0, _ => eq0
    | ne0, _ | lt0, ne0 | lt0, top | gt0, ne0 | gt0, top => ne0
    | lt0, lt0 | lt0, le0 | gt0, gt0 | gt0, ge0 => gt0
    | lt0, gt0 | lt0, ge0 | gt0, lt0 | gt0, le0 => lt0
    | le0, lt0 | le0, le0 | ge0, gt0 | ge0, ge0 => ge0
    | le0, gt0 | le0, ge0 | ge0, lt0 | ge0, le0 => le0
    | _, _ => top
    end.

Definition ab_op op a1 a2 :=
    match op with
    | add => add_op a1 a2
    | sub => sub_op a1 a2
    | mul => mul_op a1 a2
    | div => div_op a1 a2
    end.

Fixpoint A_sharp e s_sharp :=
    match e with
    | var x => ab_lookup s_sharp x
    | const n => alpha_singleton n
    | aop op e1 e2 => ab_op op (A_sharp e1 s_sharp) (A_sharp e2 s_sharp)
    | opp e' => ab_opp (A_sharp e' s_sharp)
    end.

Definition eq_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot
                | eq0, lt0 | eq0, gt0 | lt0, eq0 | gt0, eq0 | lt0, gt0 | gt0, lt0
                | lt0, ge0 | ge0, lt0 | eq0, ne0 | ne0, eq0 | gt0, le0 | le0, gt0 => bot_AbS
                | le0, lt0 | ne0, lt0 | ne0, le0 | le0, ne0 => ab_update s_sharp x lt0
                | le0, eq0 | ge0, eq0 | ge0, le0 | le0, ge0 => ab_update s_sharp x eq0
                | ne0, gt0 | ge0, gt0 | ge0, ne0 | ne0, ge0 => ab_update s_sharp x gt0
                | top, a => ab_update s_sharp x a
                | _, _ => s_sharp
                end
    | _ => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot
            | eq0, lt0 | eq0, gt0 | lt0, eq0 | gt0, eq0 | lt0, gt0 | gt0, lt0
            | lt0, ge0 | ge0, lt0 | eq0, ne0 | ne0, eq0 | gt0, le0 | le0, gt0 => bot_AbS
            | _, _ => s_sharp
            end
    end.

Definition ne_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot | eq0, eq0 => bot_AbS
                | le0, eq0 =>  (ab_update s_sharp x lt0)
                | ge0, eq0 =>  (ab_update s_sharp x gt0)
                | top, eq0 =>  (ab_update s_sharp x ne0)
                | _, _ =>  s_sharp
                end
    | _ => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot | eq0, eq0 => bot_AbS
            | _, _ =>  s_sharp
            end
    end.

Definition lt_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot
                | eq0, lt0 | eq0, eq0 | eq0, le0
                | gt0, lt0 | gt0, eq0 | gt0, le0
                | ge0, lt0 | ge0, eq0 | ge0, le0 => bot_AbS
                | le0, lt0 | le0, eq0 | le0, le0
                | ne0, lt0 | ne0, eq0 | ne0, le0
                | top, lt0 | top, eq0 | top, le0 =>  (ab_update s_sharp x lt0)
                | _, _ =>  s_sharp
                end
    | _ => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot
            | eq0, lt0 | eq0, eq0 | eq0, le0
            | gt0, lt0 | gt0, eq0 | gt0, le0
            | ge0, lt0 | ge0, eq0 | ge0, le0 => bot_AbS
            | _, _ =>  s_sharp
            end
    end.

Definition gt_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot
                | eq0, gt0 | eq0, eq0 | eq0, ge0
                | lt0, gt0 | lt0, eq0 | lt0, ge0
                | le0, gt0 | le0, eq0 | le0, ge0 => bot_AbS
                | ge0, gt0 | ge0, eq0 | ge0, ge0
                | ne0, gt0 | ne0, eq0 | ne0, ge0
                | top, gt0 | top, eq0 | top, ge0 =>  (ab_update s_sharp x gt0)
                | _, _ =>  s_sharp
                end
    | _ => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot
            | eq0, gt0 | eq0, eq0 | eq0, ge0
            | lt0, gt0 | lt0, eq0 | lt0, ge0
            | le0, gt0 | le0, eq0 | le0, ge0 => bot_AbS
            | _, _ =>  s_sharp
            end
    end.

Definition le_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot
                | eq0, lt0
                | gt0, lt0 | gt0, eq0 | gt0, le0
                | ge0, lt0 => bot_AbS
                | le0, lt0
                | ne0, lt0 | ne0, eq0 | ne0, le0
                | top, lt0 =>  (ab_update s_sharp x lt0)
                | ge0, eq0 | ge0, le0 =>  (ab_update s_sharp x eq0)
                | top, eq0 | top, le0 =>  (ab_update s_sharp x ge0)
                | _, _ =>  s_sharp
                end
    | _ => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot
            | eq0, lt0
            | gt0, lt0 | gt0, eq0 | gt0, le0
            | ge0, lt0 => bot_AbS
            | _, _ =>  s_sharp
            end
    end.

Definition ge_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot
                | eq0, gt0
                | lt0, gt0 | lt0, eq0 | lt0, ge0
                | le0, gt0 => bot_AbS
                | ge0, gt0
                | ne0, gt0 | ne0, eq0 | ne0, ge0
                | top, gt0 =>  (ab_update s_sharp x gt0)
                | le0, eq0 | le0, ge0 =>  (ab_update s_sharp x eq0)
                | top, eq0 | top, ge0 =>  (ab_update s_sharp x le0)
                | _, _ =>  s_sharp
                end
    | _ => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot
            | eq0, gt0
            | lt0, gt0 | lt0, eq0 | lt0, ge0
            | le0, gt0 => bot_AbS
            | _, _ =>  s_sharp
            end
    end.

Definition join a1 a2 :=
    match a1, a2 with
    | bot,  a3 |  a3,  bot =>  a3
    | eq0,  lt0 |  lt0,  eq0
    | eq0,  le0 |  le0,  eq0
    | lt0,  le0 |  le0,  lt0 =>  le0
    | eq0,  gt0 |  gt0,  eq0
    | eq0,  ge0 |  ge0,  eq0
    | gt0,  ge0 |  ge0,  gt0 =>  ge0
    | lt0,  gt0 |  gt0,  lt0
    | lt0,  ne0 |  ne0,  lt0
    | gt0,  ne0 |  ne0,  gt0 =>  ne0
    | a3, a4 => if sign_eq_dec a3 a4 then a3 else top
    end.

Fixpoint join_state_helper l t_sharp :=
    match l with
    | nil => top_AbS
    | (x, a) :: tl => ab_update (join_state_helper tl t_sharp) x (join a (ab_lookup t_sharp x))
    end.

Definition join_state s_sharp t_sharp :=
    match s_sharp with
    | None => t_sharp
    | Some l => join_state_helper l t_sharp
    end.

Definition ab_le a1 a2 := if sign_eq_dec (join a1 a2) a2 then true else false.

Fixpoint ab_le_state_helper l t_sharp :=
    match l with
    | nil => true
    | (x, a) :: tl => ab_le (ab_lookup t_sharp x) a && ab_le_state_helper tl t_sharp
    end.

Definition ab_le_state s_sharp t_sharp :=
    match s_sharp with
    | None => true
    | Some l => ab_le_state_helper l t_sharp
    end.

Definition widen a1 a2 := join a1 a2.

Definition widen_state s_sharp t_sharp :=
    match s_sharp with
    | None => t_sharp
    | Some l => Some (map (fun c : string * AbD => let (x, a) := c in (x, widen a (ab_lookup t_sharp x))) l)
    end.

Definition narrow (a1 a2 : AbD) :=
    match a1, a2 with
    | top,  a3 |  a3,  top => a3
    | ne0,  lt0 |  lt0,  ne0
    | ne0,  le0 |  le0,  ne0
    | lt0,  le0 |  le0,  lt0 =>  lt0
    | ne0,  gt0 |  gt0,  ne0
    | ne0,  ge0 |  ge0,  ne0
    | gt0,  ge0 |  ge0,  gt0 =>  gt0
    | le0,  ge0 |  ge0,  le0
    | le0,  eq0 |  eq0,  le0
    | ge0,  eq0 |  eq0,  ge0 =>  eq0
    | a3, a4 => if sign_eq_dec a3 a4 then a3 else bot
    end.

Definition narrow_state s_sharp t_sharp :=
    match s_sharp with
    | None => bot_AbS
    | Some l => Some (map (fun c : string * AbD => let (x, a) := c in (x, narrow a (ab_lookup t_sharp x))) l)
    end.

End ExtendedSign.

(* Intervals domain *)

Module Intervals <: AbstractDomain.

Inductive Interval : Type :=
| top : Interval
| left_of : Z -> Interval
| between : Z -> Z -> Interval
| right_of : Z -> Interval
| bot : Interval.

Definition AbD := Interval.

Definition AbS := option (list (string * AbD)).

Definition top_AbS : AbS := Some nil.

Definition bot_AbS : AbS := None.

Fixpoint string_list_update {A} l x (a : A) :=
    match l with
    | nil => (x, a) :: nil
    | (y, a') :: tl => if string_dec x y then (y, a) :: tl else (y, a') :: string_list_update tl x a
    end.

Definition ab_update s_sharp x a : AbS :=
    match s_sharp with
    | Some l => Some (string_list_update l x a)
    | None => Some ((x, a) :: nil)
    end.

Fixpoint string_list_lookup l x :=
    match l with
    | nil => top
    | (y, a) :: tl => if string_dec x y then a else string_list_lookup tl x
    end.

Definition ab_lookup s_sharp x :=
    match s_sharp with
    | Some l => string_list_lookup l x
    | None => bot
    end.

Definition alpha_singleton n := between n n.

Definition ab_opp a :=
    match a with
    | right_of n => left_of (-n)
    | left_of n => right_of (-n)
    | between m n => between (-n) (-m)
    | top => top
    | bot => bot
    end.

Definition add_op a1 a2 :=
    match a1, a2 with
    | bot, _ | _, bot => bot
    | left_of b, left_of d | left_of b, between _ d | between _ b, left_of d => left_of (b + d)
    | between a b, between c d => between (a + c) (b + d)
    | between a _, right_of c | right_of a, right_of c | right_of a, between c _ => right_of (a + c)
    | _, _ => top
    end.

Definition sub_op a1 a2 :=
    match a1, a2 with
    | bot, _ | _, bot => bot
    | left_of b, between c _ | left_of b, right_of c | between _ b, right_of c => left_of (b - c)
    | between a b, between c d => between (a - d) (b - c)
    | between a _, left_of d | right_of a, left_of d | right_of a, between _ d => right_of (a - d)
    | _, _ => top
    end.

Definition mul_op a1 a2 :=
    match a1, a2 with
    | left_of b, left_of d => if (b >? 0) && (d >? 0) then top else right_of (b * d)
    | left_of b, between c d => if ((c <? 0) && (d >? 0)) || ((c >? 0) && (d <? 0)) then top
                                else if (c =? 0) && (d =? 0) then between 0 0
                                else if (c <=? 0) && (d <=? 0) then right_of (Z.min (b * c) (b * d))
                                else left_of (Z.max (b * c) (b * d))
    | left_of b, right_of c => if (b >? 0) && (c <? 0) then top else left_of (b * c)
    | between a b, left_of d => if ((a <? 0) && (b >? 0)) || ((a >? 0) && (b <? 0)) then top
                                else if (a =? 0) && (b =? 0) then between 0 0
                                else if (a <=? 0) && (b <=? 0) then right_of (Z.min (a * d) (b * d))
                                else left_of (Z.max (a * d) (b * d))
    | between a b, between c d => between (Z.min (Z.min (a * c) (a * d)) (Z.min (b * c) (b * d))) (Z.max (Z.max (a * c) (a * d)) (Z.max (b * c) (b * d)))
    | between a b, right_of c => if ((a <? 0) && (b >? 0)) || ((a >? 0) && (b <? 0)) then top
                                 else if (a =? 0) && (b =? 0) then between 0 0
                                 else if (a <=? 0) && (b <=? 0) then right_of (Z.min (a * c) (b * c))
                                 else left_of (Z.max (a * c) (b * c))
    | right_of a, left_of d => if (d >? 0) && (a <? 0) then top else left_of (a * d)
    | right_of a, between c d => if ((c <? 0) && (d >? 0)) || ((c >? 0) && (d <? 0)) then top
                                else if (c =? 0) && (d =? 0) then between 0 0
                                else if (c <=? 0) && (d <=? 0) then left_of (Z.max (a * c) (a * d))
                                else right_of (Z.min (a * c) (a * d))
    | right_of a, right_of c => if (a <? 0) && (c <? 0) then top else left_of (a * c)
    | between a b, top => if (a =? 0) && (b =? 0) then between 0 0 else top
    | top, between c d => if (c =? 0) && (d =? 0) then between 0 0 else top
    | _, _ => top
    end.

Definition join a1 a2 :=
    match a1, a2 with
    | bot, a3 | a3, bot => a3
    | left_of b, left_of d | left_of b, between _ d | between _ b, left_of d => left_of (Z.max b d)
    | right_of a, right_of c | right_of a, between c _ | between a _, right_of c => right_of (Z.min a c)
    | between a b, between c d => between (Z.min a c) (Z.max b d)
    | _, _ => top
    end.

    Unset Guard Checking.

    Fixpoint div_op a1 a2 {struct a1} :=
        match a1, a2 with
        | left_of b, left_of d => if d <? 0 then right_of (Z.min 0 (b / d))
                                  else if d =? 0 then div_op (left_of b) (left_of (-1))
                                  else top
        | left_of b, between c d => if (c =? 0) && (d =? 0) then bot
                                    else if (c >? 0) && (d >=? c) then left_of (Z.max (b / c) (b / d))
                                    else if (c =? 0) && (d >? c) then div_op (left_of b) (between 1 d)
                                    else if (c <=? d) && (d <? 0) then right_of (Z.min (b / c) (b / d))
                                    else if (c <? d) && (d =? 0) then div_op (left_of b) (between c (-1))
                                    else top
        | left_of b, right_of c => if c >? 0 then left_of (Z.max (b / c) 0)
                                    else if c =? 0 then div_op (left_of b) (right_of 1)
                                    else top
        | between a b, left_of d => if d <? 0 then between (Z.min (b / d) 0) (Z.max (a / d) 0)
                                     else if d =? 0 then div_op (between a b) (left_of (-1))
                                     else join (div_op (between a b) (left_of (-1))) (div_op (between a b) (between 1 d))
        | between a b, between c d => if (c =? 0) && (d =? 0) then bot
                                        else if (c =? 0) && (d >? c) then div_op (between a b) (between 1 d)
                                        else if (c <? 0) && (d =? 0) then div_op (between a b) (between c (-1))
                                        else if (c <? 0) && (d >? 0) then join (div_op (between a b) (between c (-1))) (div_op (between a b) (between 1 d))
                                        else between (Z.min (Z.min (a / c) (a / d)) (Z.min (b / c) (b / d))) (Z.max (Z.max (a / c) (a / d)) (Z.max (b / c) (b / d)))
        | between a b, right_of c => if c >? 0 then between (Z.min (a / c) 0) (Z.max (b / c) 0)
                                        else if c =? 0 then div_op (between a b) (right_of 1)
                                        else join (div_op (between a b) (between c (-1))) (div_op (between a b) (right_of 1))
        | between a b, top => join (div_op (between a b) (left_of (-1))) (div_op (between a b) (right_of 1))
        | right_of a, left_of d => if d <? 0 then left_of (Z.max 0 (a / d))
                                   else if d =? 0 then div_op (right_of a) (left_of (-1))
                                   else top
        | right_of a, between c d => if (c =? 0) && (d =? 0) then bot
                                        else if (c >? 0) && (d >=? c) then right_of (Z.min (a / c) (a / d))
                                        else if (c =? 0) && (d >? c) then div_op (right_of a) (between 1 d)
                                        else if (c <=? d) && (d <? 0) then left_of (Z.max (a / c) (a / d))
                                        else if (c <? d) && (d =? 0) then div_op (right_of a) (between c (-1))
                                        else top
        | right_of a, right_of c => if c >? 0 then right_of (Z.min (a / c) 0)
                                    else if c =? 0 then div_op (right_of a) (right_of 1)
                                    else top
        | top, between c d => if (c =? 0) && (d =? 0) then bot else top
        | _, _ => top
        end.

Set Guard Checking.

Definition ab_op op a1 a2 :=
    match op with
    | add => add_op a1 a2
    | sub => sub_op a1 a2
    | mul => mul_op a1 a2
    | div => div_op a1 a2
    end.

    Fixpoint A_sharp e s_sharp :=
        match e with
        | var x => ab_lookup s_sharp x
        | const n => alpha_singleton n
        | aop op e1 e2 => ab_op op (A_sharp e1 s_sharp) (A_sharp e2 s_sharp)
        | opp e' => ab_opp (A_sharp e' s_sharp)
        end.

Definition eq_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot => bot_AbS
                | left_of b, left_of d => if b <=? d then  s_sharp
                                          else  (ab_update s_sharp x (left_of d))
                | left_of b, between c d => if b <? c then bot_AbS
                                            else if (c <=? b) && (b <=? d) then  (ab_update s_sharp x (between c b))
                                            else  (ab_update s_sharp x (between c d))
                | left_of b, right_of c => if b <? c then bot_AbS
                                           else  (ab_update s_sharp x (between c b))
                | between a b, left_of d => if a >? d then bot_AbS
                                            else if (a <=? d) && (b >? d) then  (ab_update s_sharp x (between a d))
                                            else  s_sharp
                | between a b, between c d => if (b <? c) || (a >? d) then bot_AbS
                                              else if (b >? d) && (a <? c) then  (ab_update s_sharp x (between c d))
                                              else if (b >? d) && (a >=? c) then  (ab_update s_sharp x (between a d))
                                              else if (c <=? b) && (b <=? d) && (a <? c) then  (ab_update s_sharp x (between c b))
                                              else  s_sharp
                | between a b, right_of c => if b <? c then bot_AbS
                                             else if (b >=? c) && (a <? c) then  (ab_update s_sharp x (between c b))
                                             else  s_sharp
                | right_of a, left_of d => if a >? d then bot_AbS else  (ab_update s_sharp x (between a d))
                | right_of a, between c d => if a >? d then bot_AbS
                                             else if a <? c then  (ab_update s_sharp x (between c d))
                                             else  (ab_update s_sharp x (between a d))
                | right_of a, right_of c => if a <? c then  (ab_update s_sharp x (right_of c)) else  s_sharp
                | top, left_of d =>  (ab_update s_sharp x (left_of d))
                | top, between c d =>  (ab_update s_sharp x (between c d))
                | top, right_of c =>  (ab_update s_sharp x (right_of c))
                | _, _ =>  s_sharp
                end
    | _ =>  match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot => bot_AbS
            | left_of b, between c _ | left_of b, right_of c | between _ b, right_of c => if b <? c then bot_AbS else  s_sharp
            | right_of a, between _ d | right_of a, left_of d | between a _, left_of d => if a >? d then bot_AbS else  s_sharp
            | between a b, between c d => if (b <? c) || (a >? d) then bot_AbS else  s_sharp
            | _, _ =>  s_sharp
            end
    end.

Definition ne_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot => bot_AbS
                | left_of b, between c d => if (b =? c) && (c =? d) then  (ab_update s_sharp x (left_of (b - 1)))
                                            else  s_sharp
                | between a b, between c d => if (a =? b) && (b =? c) && (c =? d) then bot_AbS
                                              else if (negb (a =? b)) && (a =? c) && (c =? d) then  (ab_update s_sharp x (between (a + 1) b))
                                              else if (negb (a =? b)) && (b =? c) && (c =? d) then  (ab_update s_sharp x (between a (b - 1)))
                                              else  s_sharp
                | right_of a, between c d => if (a =? c) && (c =? d) then  (ab_update s_sharp x (right_of (a + 1)))
                                             else  s_sharp
                | _, _ =>  s_sharp
                end
    | _ =>  match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot => bot_AbS
            | between a b, between c d => if (a =? b) && (b =? c) && (c =? d) then bot_AbS
                                            else  s_sharp
            | _, _ =>  s_sharp
            end
    end.

Definition lt_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot => bot_AbS
                | left_of b, left_of d | left_of b, between _ d => if b >=? d then  (ab_update s_sharp x (left_of (d - 1)))
                                                                   else  s_sharp
                | between a b, between _ d | between a b, left_of d => if a >=? d then bot_AbS
                                                                       else if b >=? d then  (ab_update s_sharp x (between a (d - 1)))
                                                                       else  s_sharp
                | right_of a, between _ d | right_of a, left_of d => if a >=? d then bot_AbS else  (ab_update s_sharp x (between a (d - 1)))
                | top, left_of d | top, between _ d =>  (ab_update s_sharp x (left_of (d - 1)))
                | _, _ =>  s_sharp
                end
    | _ =>  match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot => bot_AbS
            | between a _, between _ d | between a _, left_of d
            | right_of a, between _ d | right_of a, left_of d => if a >=? d then bot_AbS else  s_sharp
            | _, _ =>  s_sharp
            end
    end.

Definition gt_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot => bot_AbS
                | between a b, between c _ | between a b, right_of c => if b <=? c then bot_AbS else
                                                                         if a <=? c then  (ab_update s_sharp x (between (c + 1) b))
                                                                         else  s_sharp
                | left_of b, between c _ | left_of b, right_of c => if b <=? c then bot_AbS else  (ab_update s_sharp x (between (c + 1) b))
                | right_of a, between c _ | right_of a, right_of c => if a <=? c then  (ab_update s_sharp x (right_of (c + 1))) else  s_sharp
                | top, between c _ | top, right_of c =>  (ab_update s_sharp x (right_of (c + 1)))
                | _, _ =>  s_sharp
                end
    | _ =>  match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot => bot_AbS
            | between _ b, between c _ | between _ b, right_of c
            | left_of b, between c _ | left_of b, right_of c  => if b <=? c then bot_AbS else  s_sharp
            | _, _ =>  s_sharp
            end
    end.

Definition le_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot => bot_AbS
                | left_of b, left_of d | left_of b, between _ d => if b >? d then  (ab_update s_sharp x (left_of d))
                                                                   else  s_sharp
                | between a b, between _ d | between a b, left_of d => if a >? d then bot_AbS
                                                                       else if b >? d then  (ab_update s_sharp x (between a d))
                                                                       else  s_sharp
                | right_of a, between _ d | right_of a, left_of d => if a >? d then bot_AbS else  (ab_update s_sharp x (between a d))
                | top, left_of d | top, between _ d =>  (ab_update s_sharp x (left_of d))
                | _, _ =>  s_sharp
                end
    | _ =>  match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot => bot_AbS
            | between a _, between _ d | between a _, left_of d
            | right_of a, between _ d | right_of a, left_of d => if a >? d then bot_AbS else  s_sharp
            | _, _ =>  s_sharp
            end
    end.

Definition ge_sem e1 e2 s_sharp :=
    match e1 with
    | var x => match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
                | bot, _ | _, bot => bot_AbS
                | between a b, between c _ | between a b, right_of c => if b <? c then bot_AbS else
                                                                         if a <? c then  (ab_update s_sharp x (between c b))
                                                                         else  s_sharp
                | left_of b, between c _ | left_of b, right_of c => if b <? c then bot_AbS else  (ab_update s_sharp x (between c b))
                | right_of a, between c _ | right_of a, right_of c => if a <? c then  (ab_update s_sharp x (right_of c)) else  s_sharp
                | top, between c _ | top, right_of c =>  (ab_update s_sharp x (right_of c))
                | _, _ =>  s_sharp
                end
    | _ =>  match A_sharp e1 s_sharp, A_sharp e2 s_sharp with
            | bot, _ | _, bot => bot_AbS
            | between _ b, between c _ | between _ b, right_of c
            | left_of b, between c _ | left_of b, right_of c  => if b <? c then bot_AbS else  s_sharp
            | _, _ =>  s_sharp
            end
    end.

    Fixpoint join_state_helper l t_sharp :=
        match l with
        | nil => top_AbS
        | (x, a) :: tl => ab_update (join_state_helper tl t_sharp) x (join a (ab_lookup t_sharp x))
        end.

    Definition join_state s1_sharp s2_sharp :=
        match s1_sharp with
        | None => s2_sharp
        | Some l => join_state_helper l s2_sharp
        end.

Definition ab_le a1 a2 :=
    match a1, a2 with
    | bot, _ | _, top => true
    | between a b, between c d => (c <=? a) && (b <=? d)
    | between a _, right_of c => c <=? a
    | between _ a, left_of c => a <=? c
    | right_of a, right_of c => c <=? a
    | left_of a, left_of c => a <=? c
    | _, _ => false
    end.

    Fixpoint ab_le_state_helper l t_sharp :=
        match l with
        | nil => true
        | (x, a) :: tl => ab_le (ab_lookup t_sharp x) a && ab_le_state_helper tl t_sharp
        end.

    Definition ab_le_state s_sharp t_sharp :=
        match s_sharp with
        | None => true
        | Some l => ab_le_state_helper l t_sharp
        end.

Definition widen a1 a2 :=
    match a1, a2 with
    | bot, a3 | a3, bot => a3
    | right_of a, right_of c | right_of a, between c _ | between a _, right_of c => if a <=? c then right_of a else top
    | between a b, between c d => if a <=? c then
                                    if d <=? b then
                                        between a b
                                    else
                                        right_of a
                                  else
                                    if d <=? b then
                                        left_of b
                                    else
                                        top
    | between _ b, left_of d | left_of b, between _ d | left_of b, left_of d => if d <=? b then left_of b else top
    | _, _ => top
    end.

    Definition widen_state s_sharp t_sharp :=
        match s_sharp with
        | None => t_sharp
        | Some l => Some (map (fun c : string * AbD => let (x, a) := c in (x, widen a (ab_lookup t_sharp x))) l)
        end.

Definition narrow a1 a2 :=
    match a1, a2 with
    | bot, _ | _, bot => bot
    | top, a3 | a3, top => a3
    | right_of a, right_of _ => right_of a
    | right_of a, between _ d | right_of a, left_of d => between a d
    | between a b, _ => between a b
    | left_of b, right_of c | left_of b, between c _ => between c b
    | left_of b, left_of _ => left_of b
    end.

    Definition narrow_state s_sharp t_sharp :=
        match s_sharp with
        | None => bot_AbS
        | Some l => Some (map (fun c : string * AbD => let (x, a) := c in (x, narrow a (ab_lookup t_sharp x))) l)
        end.

End Intervals.

(* Extended Sign examples *)

Module B := AbstractInterpreter ExtendedSign.
Import ExtendedSign.
Import B.

(**
    Example 1

    while x != 0 do
        x := x + 1
*)

Definition example1_expr :=
    while_do (bop ne (var "x") (const 0)) (assign "x" (aop add (var "x") (const 1))).

Definition example1_1_state := Some [("x", lt0)].

Definition example1_2_state := Some [("x", eq0)].

Definition example1_3_state := Some [("x", gt0)].

Eval compute in (AI example1_expr false example1_1_state).

Eval compute in (AI example1_expr false example1_2_state).

Eval compute in (AI example1_expr false example1_3_state).

(**
    Example 2

    x := x + y
    y := y + 1
*)

Definition example2_expr :=
    (sequence (assign "x" (aop add (var "x") (var "y"))) (assign "y" (aop add (var "y") (const 1)))).

Definition example2_state := Some [("x", le0); ("y", lt0)].

Eval compute in (AI example2_expr false example2_state).

(**
    Example 3

    x := 40
    while x != 0 do
        x := x - 1
*)

Definition example3_expr :=
    sequence (assign "x" (const 40)) (while_do (bop ne (var "x") (const 0)) (assign "x" (aop sub (var "x") (const 1)))).

Eval compute in (AI example3_expr false top_AbS).

(* Intervals examples *)

Module C := AbstractInterpreter Intervals.
Import Intervals.
Import C.

(**
    Example 3

    x := 40
    while x != 0 do
        x := x - 1
*)

Eval compute in (AI example3_expr false top_AbS).
Eval compute in (AI example3_expr true top_AbS).

(**
    Example 4

    while x >= 0 do
        x := x - 1
        y := y + 1
*)

Definition example4_expr :=
    while_do (bop ge (var "x") (const 0)) (sequence (assign "x" (aop sub (var "x") (const 1))) (assign "y" (aop add (var "y") (const 1)))).

Definition example4_state := Some [("x", between 10 10); ("y", between 0 0)].

(* Eval compute in (AI example4_expr false example4_state). *)
Eval compute in (AI example4_expr true example4_state).

(**
    Example 5

    while x < 10 do
        x := x + 1
*)

Definition example5_expr :=
    while_do (bop lt (var "x") (const 10)) (assign "x" (aop add (var "x") (const 1))).

Definition example5_state := Some [("x", between 0 0)].

Eval compute in (AI example5_expr false example5_state).
Eval compute in (AI example5_expr true example5_state).

(**
    Example 6

    while x <= 100 do
        x := x + 1
*)

Definition example6_expr :=
    while_do (bop le (var "x") (const 100)) (assign "x" (aop add (var "x") (const 1))).

Definition example6_state := Some [("x", between 1 1)].

Eval compute in (AI example6_expr false example6_state).
Eval compute in (AI example6_expr true example6_state).

(**
    Example 7

    x := 0
    while x < 40 do
        x := x + 1
*)

Definition example7_expr :=
    sequence (assign "x" (const 0)) (while_do (bop lt (var "x") (const 40)) (assign "x" (aop add (var "x") (const 1)))).

Eval compute in (AI example7_expr false top_AbS).
Eval compute in (AI example7_expr true top_AbS).

(**
    Example 8

    x := 0
    while 1 = 1 do
        if y = 0 then
            x := x + 1
            if x < 40 then
                x := 0
*)

Definition example8_expr :=
    sequence (assign "x" (const 0))
             (while_do (bop eq (const 1) (const 1))
                (if_then_else (bop eq (var "y") (const 0))
                    (sequence (assign "x" (aop add (var "x") (const 1)))
                              (if_then_else (bop gt (var "x") (const 40))
                                    (assign "x" (const 0))
                                    skip))
                    skip)).

Definition example8_state := Some [("y", between 0 1)].

Eval compute in (AI example8_expr false top_AbS).
Eval compute in (AI example8_expr true top_AbS).

(**
    Example 9

    i := 1
    while i <= 3 do
        j := 1
        while j <= i do
            j := j + 1
        i := i + 1
*)

Definition example9_expr :=
    sequence (assign "i" (const 1))
             (while_do (bop le (var "i") (const 3))
                (sequence (sequence (assign "j" (const 1))
                                    (while_do (bop le (var "j") (var "i"))
                                        (assign "j" (aop add (var "j") (const 1)))))
                          (assign "i" (aop add (var "i") (const 1))))).

Eval compute in (AI example9_expr false top_AbS).
Eval compute in (AI example9_expr true top_AbS).

(**
    Example 10

    i := 1
    while i <= 4 do
        j := 0
        while j <= 3 do
            k := 0
            while k <= 5 do
                z := i * j * k
                k := k + 1
            j := j + 1
        i := i + 1
*)

Definition example10_expr :=
    sequence (assign "i" (const 1))
             (while_do (bop le (var "i") (const 4))
                (sequence (sequence (assign "j" (const 0))
                                    (while_do (bop le (var "j") (const 3))
                                        (sequence (sequence (assign "k" (const 0))
                                                            (while_do (bop le (var "k") (const 5))
                                                                (sequence (assign "z" (aop mul (aop mul (var "i") (var "j")) (var "k")))
                                                                            (assign "k" (aop add (var "k") (const 1))))))
                                                  (assign "j" (aop add (var "j") (const 1))))))
                          (assign "i" (aop add (var "i") (const 1))))).

Eval compute in (AI example10_expr false top_AbS).
Eval compute in (AI example10_expr true top_AbS).

(**
    Example 11

    x := 1 / 0;
    while x <= 5 do
*)

Definition example11_expr :=
    sequence (assign "x" (aop div (const 1) (const 0))) (while_do (bop le (var "x") (const 5)) skip).

Eval compute in (AI example11_expr false top_AbS).

(**
    Example 12

    while (1 / 0) < 1 do
*)

Definition example12_expr :=
    (while_do (bop lt (aop div (const 1) (const 0)) (const 1)) skip).

Eval compute in (AI example12_expr false top_AbS).


Require Import Arith.
Set Implicit Arguments.

CoInductive LList (A:Set) : Set :=
  | LNil : LList A
  | LCons : A -> LList A -> LList A.

Implicit Arguments LNil [A].

Inductive BugInfinite (A:Set) : LList A -> Prop :=
    BugInfinite_intro :
      forall a (l:LList A),
        BugInfinite l -> BugInfinite (LCons a l).

Theorem bug_infinite_empty :
  forall (A:Set) (l:LList A), BugInfinite l -> False.
Proof.
  induction 1.
  auto.
Qed.


(** This file is essentially a bunch of testcases. *)
Require Import Reals Psatz.
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import adequacy.
From iris.heap_lang Require Import proofmode notation.
From discprob.basic Require Import monad.
From discprob.idxval Require Import pival
     pival_dist ival_dist irrel_equiv idist_pidist_pair extrema.
Set Default Proof Using "Type".

Module tests.
Section tests.
  Context `{heapG Σ} `{probG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.

  Definition heap_e2 : expr :=
    let: "x" := flip #1 #2 in
    let: "y" := flip #1 #2 in
    "x" = "y".

  Program Definition flip_half := pidist_plus (1/2)%R _ (mret true) (mret false).
  Next Obligation.
    nra.
  Qed.

  Lemma heap_e2_spec E :
    ownProb (flip_half) ⊢
            WP heap_e2 @ E {{ v, ∃ v', ownProb (mret v') ∗
                           ⌜ v = LitV $ LitBool v' ⌝ }}%I.
  Proof.
    iIntros "Hprob". rewrite /heap_e2.
    rewrite /flip_half.
    setoid_rewrite <-(pidist_left_id tt (λ x, flip_half)).
    unshelve (wp_flip (mret tt) (λ x y, True) b b' HR); first by abstract (nra).
    { apply irrel_coupling_trivial. }
    wp_let.
    setoid_rewrite <-(pidist_right_id) at 1.
    unshelve (wp_flip flip_half (λ x y, match b, x with
                                               | true, true => y = true
                                               | false, false => y = true
                                               | _, _ => y = false
                                               end) c c' HRc); first by abstract (nra).
    { apply ip_irrel_coupling.
      destruct b.
      * eapply ip_coupling_plus; first (by reflexivity);
        apply ip_coupling_mret; auto.
      * assert (0 <= 1 - (IZR 1 /IZR 2) <= 1)%R by nra.
        eapply (ip_coupling_proper (ivdplus _ H0 (mret false) (mret true))).
        { symmetry. eapply ivdplus_comm. }
        { reflexivity.  }
        assert (1 - (IZR 1 / IZR 2) = IZR 1 / IZR 2)%R as Heq.
        { nra.  }
        generalize H0.
        rewrite Heq => ?.
        eapply ip_coupling_plus; first (by reflexivity);
          apply ip_coupling_mret; auto.
    }
    wp_let.
    subst.
    wp_op.
    iExists c'.
    iFrame.
    iPureIntro.
    destruct b, c; subst => //=.
  Qed.
End tests.

Section ClosedProofs.

  Let Σ : gFunctors := #[ heapΣ ].

  Variable (sch : @scheduler heap_ectxi_lang).
  Variable (σ : state).
  Variable (n : nat).

  Definition heap_e2_ival := ivdist_tpool_stepN sch [heap_e2] σ n.

  Lemma test_adequate_1 (Hterm: terminates sch [([heap_e2], σ)] n):
    irrel_couplingP (heap_e2_ival)
                    flip_half
                    (prob_adequacy.coupling_post (λ x y, x = LitV $ LitBool y)).
  Proof.
    intros.
    eapply (heap_prob_adequacy Σ flip_half
                              (heap_e2) σ (λ x y, x = LitV $ LitBool y) sch n); eauto.
    intros. iIntros "Hown". iPoseProof (heap_e2_spec with "Hown") as "H"; auto.
  Qed.

  Local Open Scope R.
  Import Rbar.

  Lemma test_Ex_min_false (Hterm: terminates sch [([heap_e2], σ)] n):
    Rbar_le (Ex_min (λ x : bool, if x then 0 else 1) flip_half)
            (Ex_ival (λ x,
                      match fst x with
                      | [] => 0
                      | e :: _ => match prob_language.to_val e with
                                  | Some (LitV (LitBool false)) => 1
                                  | _ => 0
                                  end
                      end) heap_e2_ival).
  Proof.
    apply irrel_coupling_eq_Ex_min; last first.
    { exists 1. intros []; rewrite Rabs_right; nra. }
    eapply irrel_coupling_conseq; last first.
    { eapply irrel_coupling_proper; last eapply test_adequate_1.
      - reflexivity.
      - reflexivity.
      - eauto.
    }
    intros x b.
    destruct x as ([| v ?]&?) => //=.
    destruct (to_val v) => //=.
    destruct v0 => //=. destruct l0 => //=.
    destruct b0, b => //=.
  Qed.

  Lemma test_Ex_min_true (Hterm: terminates sch [([heap_e2], σ)] n):
    Rbar_le (Ex_min (λ x : bool, if x then 1 else 0) flip_half)
            (Ex_ival (λ x,
                      match fst x with
                      | [] => 0
                      | e :: _ => match prob_language.to_val e with
                                  | Some (LitV (LitBool true)) => 1
                                  | _ => 0
                                  end
                      end) heap_e2_ival).
  Proof.
    apply irrel_coupling_eq_Ex_min; last first.
    { exists 1. intros []; rewrite Rabs_right; nra. }
    eapply irrel_coupling_conseq; last first.
    { eapply irrel_coupling_proper; last eapply test_adequate_1.
      - reflexivity.
      - reflexivity.
      - auto.
    }
    intros x b.
    destruct x as ([| v ?]&?) => //=.
    destruct (to_val v) => //=.
    destruct v0 => //=. destruct l0 => //=.
    destruct b0, b => //=.
  Qed.

  Print Assumptions test_Ex_min_true.
End ClosedProofs.

End tests.


Require Export Fiat.Common Fiat.Computation Fiat.ADT.ADTSig Fiat.ADT.
Require Import Coq.Sets.Ensembles.

Generalizable All Variables.
Set Implicit Arguments.

(** Definition of a fully deterministic ADT *)

(** Type of a deterministic constructor. *)
Fixpoint cConstructorType (rep : Type) (dom : list Type)
  :=
    match dom with
    | nil =>
      rep (* Freshly constructed model *)
    | cons d dom' =>
      d -> cConstructorType rep dom' (* Initialization arguments *)
    end.

(** Type of a deterministic method. *)
Fixpoint cMethodType' (rep : Type)
         (dom : list Type)
         (cod : option Type)
  : Type :=
  match dom with
  | nil =>
    match cod with
    | Some cod' =>  (prod rep cod') (* Final model and return value *)
    | None => rep
    end
  | cons d dom' =>
    d -> cMethodType' rep dom' cod (* Method arguments *)
  end.
Definition cMethodType (rep : Type)
           (dom : list Type)
           (cod : option Type) : Type :=
  rep -> cMethodType' rep dom cod.

(** Interface of a ADT implementation *)
Record pcADT (Sig : ADTSig)
       (* Representation Type of the ADT is a parameter to get around
        Universe problems. *)
       (cRep : Type)
: Type :=
  {
    (** Constructor implementations *)
    pcConstructors :
      forall idx : ConstructorIndex Sig,
        cConstructorType cRep (ConstructorDom Sig idx);

    (** Method implementations *)
    pcMethods :
      forall idx : MethodIndex Sig,
        cMethodType cRep (fst (MethodDomCod Sig idx))
                                (snd (MethodDomCod Sig idx))
  }.

(* Definition of of an ADT implementation *)
Definition cADT (Sig : ADTSig) := sigT (pcADT Sig).
Definition cRep {Sig : ADTSig} (c : cADT Sig) : Type := projT1 c.
Definition cConstructors {Sig : ADTSig} (c : cADT Sig)
           (idx : ConstructorIndex Sig)
: cConstructorType (cRep c) (ConstructorDom Sig idx)
  := pcConstructors (projT2 c) idx.
Definition cMethods {Sig : ADTSig} (c : cADT Sig)
           (idx : MethodIndex Sig) :
  cMethodType (cRep c) (fst (MethodDomCod Sig idx))
              (snd (MethodDomCod Sig idx))
  := pcMethods (projT2 c) idx.

(* Lifting a deterministic ADT to computation-land. *)
Fixpoint LiftcConstructor
         (rep : Type) (dom : list Type)
  : cConstructorType rep dom
    -> constructorType rep dom :=
  match dom return
        cConstructorType rep dom
        -> constructorType rep dom
  with
  | nil => fun cConstructor => ret cConstructor
  | cons d dom' => fun cConstructor t =>
                   LiftcConstructor rep dom' (cConstructor t)
  end.

Fixpoint LiftcMethod'
         (rep : Type)
         (dom : list Type)
         (cod : option Type)
  : cMethodType' rep dom cod
    -> methodType' rep dom cod :=
  match dom return
        cMethodType' rep dom cod
        -> methodType' rep dom cod
  with
  | nil =>
    match cod with
    | Some cod' => fun cMethod => ret cMethod
    | None => fun cMethod => ret cMethod
    end
  | cons d dom' => fun cMethod t =>
                     LiftcMethod' rep dom' cod (cMethod t)
  end.

Definition LiftcMethod
           (rep : Type) (dom : list Type) (cod : option Type)
           (cMethod : cMethodType rep dom cod)
  : methodType rep dom cod
  := fun r => LiftcMethod' rep dom cod (cMethod r).

Definition LiftcADT (Sig : ADTSig) (A : cADT Sig) : ADT Sig :=
  {| Rep                := cRep A;
     Constructors idx :=  LiftcConstructor _ _ (cConstructors A idx);
     Methods idx    := LiftcMethod (cMethods A idx) |}.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
Require Import Reals.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import boolp classical_sets.
From mathcomp Require Import finmap.
From infotheo Require Import Reals_ext classical_sets_ext Rbigop ssrR ssr_ext.
From infotheo Require Import fdist fsdist convex necset.
Require Import monae_lib.
From HB Require Import structures.
Require Import category.

(******************************************************************************)
(*             Construction of the geometrically convex monad                 *)
(*                                                                            *)
(* This file defines the functor P_delta and shows that it is a monad.        *)
(* The proof uses the adjointness relations depicted as follows:              *)
(*                                                                            *)
(* Functors:  |       FC            F0           F1                           *)
(*            |     ---->          ---->        ---->                         *)
(* Categories:| Type     choiceType     convType     semiCompSemiLattConvType *)
(*            |             (CC)          (CV)                (CS)            *)
(*            |     <----          <----        <----                         *)
(* Forgetful  |       UC             U0           U1                          *)
(* Functors:  |                                                               *)
(*                                                                            *)
(* FC -| UC:                                                                  *)
(*                  CC := [the category of choiceType]                        *)
(*     free_choiceType := [the {functor CT -> CC} of choice_of_Type]          *)
(*                        (notation FC)                                       *)
(*   forget_choiceType := [the {functor CC -> CT} of idfun]                   *)
(*                        (notation UC)                                       *)
(*                epsC == counit FC \O UC ~> 1                                *)
(*                etaC == unit 1 ~> UC \O FC                                  *)
(* F0 -| U0:                                                                  *)
(*                  CV := [the category of convType]                          *)
(*                        (morphisms are affine functions)                    *)
(*       free_convType := [the {functor CC -> CV} of                          *)
(*                         (fun a : CC => [the convType of {dist a}])]        *)
(*                        (notation F0)                                       *)
(*     forget_convType := [the {functor CV -> CC} of idfun]                   *)
(*                eps0 == counit F0 \O U0 ~> 1                                *)
(*                eta0 == unit 1 ~> U0 \O F0                                  *)
(*        triL0, triR0 == triangular laws                                     *)
(* F1 -| U1:                                                                  *)
(*                  CS := [the category of semiCompSemiLattConvType]          *)
(*                        the category of semi-complete semi-lattice convex   *)
(*                        spaces, morphisms are biglubmorph and affine        *)
(* free_semiCompSemiLattConvType := [the {functor CV -> CS} of                *)
(*                        (fun a : CV => {necset a})]]                        *)
(*                        (notation F1)                                       *)
(* forget_semiCompSemiLattConvType := [the {functor CS -> CV} of idfun]       *)
(*                        (notation U1)                                       *)
(*                eps1 == counit F1 \O U1 ~> FId                              *)
(*                eta1 == unit FId ~> U1 \O F1                                *)
(*        triL1, triR1 == triangular laws                                     *)
(*                                                                            *)
(*               join1 == eps1 : necset (necset C) -> necset C where C is a   *)
(*                        convType                                            *)
(*                        | F1                                                *)
(*        P_delta_left == | F0                                                *)
(*                        | FC                                                *)
(*                        | UC                                                *)
(*       P_delta_right == | U0                                                *)
(*                        | U1                                                *)
(*             P_delta == functor CT CT, P_delta_right \O P_delta_left.       *)
(*                 eps == P_delta_left \O P_delta_right ~> FId                *)
(*                 ret == FId ~> P_delta                                      *)
(*                join == P_delta \O P_delta ~> P_delta                       *)
(*                 gcm == geometrically convex monad in the context of        *)
(*                        monad.v                                             *)
(******************************************************************************)

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

Local Open Scope proba_scope.
Local Open Scope category_scope.

Section choiceType_as_a_category.

HB.instance Definition _ :=
  isCategory.Build choiceType (fun x : choiceType => Choice.sort x)
    (fun _ _ _ => True) (fun=> I) (fun _ _ _ _ _ _ _ => I).

Definition hom_choiceType
           (a b : [the category of choiceType]) (f : a -> b) : {hom a, b} :=
  Hom.Pack (Hom.Class (isHom.Axioms_ a b f I)).

End choiceType_as_a_category.
Notation CC := [the category of choiceType].

Section free_choiceType_functor.
Local Notation m := choice_of_Type.

Definition free_choiceType_mor (T U : CT) (f : {hom T, U}) :
  {hom m T, m U} := hom_choiceType (f : m T -> m U).

Let free_choiceType_mor_id : FunctorLaws.id free_choiceType_mor.
Proof. by move=> a; rewrite hom_ext. Qed.

Let free_choiceType_mor_comp : FunctorLaws.comp free_choiceType_mor.
Proof. by move=> a b c g h; rewrite hom_ext. Qed.

HB.instance Definition _ := isFunctor.Build CT CC _
  free_choiceType_mor_id free_choiceType_mor_comp.

Definition free_choiceType := [the {functor CT -> CC} of m].

Lemma free_choiceType_mor_comp_fun (a b c : Type) (g : {hom b, c})
      (h : {hom a, b}):
  free_choiceType_mor [hom g \o h] =
  (free_choiceType_mor g) \o (free_choiceType_mor h) :> (_ -> _).
Proof. by rewrite free_choiceType_mor_comp. Qed.

End free_choiceType_functor.

Section forget_choiceType_functor.

Let m : CC -> CT := idfun.

Let h (a b : CC) (f : {hom a, b}) : {hom CT; m a, m b} :=
  Hom.Pack (Hom.Class (isHom.Axioms_ (a : CT) (b : _) (FId # f) I)).

Lemma h_id : FunctorLaws.id h. Proof. by move=> *; apply hom_ext. Qed.

Lemma h_comp : FunctorLaws.comp h. Proof. by move=> *; apply hom_ext. Qed.

HB.instance Definition _ := isFunctor.Build _ _ _ h_id h_comp.

Definition forget_choiceType := [the {functor CC -> CT} of m].

Lemma forget_choiceTypeE : (forall a : CC, forget_choiceType a = a) /\
  (forall (a b : CC) (f : {hom CC; a , b}), forget_choiceType # f = f :> (a -> b)).
Proof. by []. Qed.

End forget_choiceType_functor.

Section epsC_etaC.
Local Notation FC := free_choiceType.
Local Notation UC := forget_choiceType.

Let epsC' : FC \O UC ~~> FId := fun A : CC => Hom.Pack (Hom.Class
  (isHom.Axioms_ ((FC \O UC) A) (FId A) idfun I)).

Lemma epsC'_natural : naturality _ _ epsC'. Proof. by []. Qed.

HB.instance Definition _ := isNatural.Build _ _ _ _ _ epsC'_natural.

Definition epsC := locked [the _ ~> _ of epsC'].

Lemma epsCE (T : choiceType) : epsC T = idfun :> (_ -> _).
Proof. by rewrite /epsC; unlock. Qed.

Let etaC' : FId ~~> UC \O FC :=
      fun (_ : CT) => Hom.Pack (Hom.Class (isHom.Axioms_ (FId _) ((UC \O FC) _) idfun I)).

Lemma etaC'_natural : naturality _ _ etaC'.
Proof. by []. Qed.

HB.instance Definition _ := isNatural.Build _ _ _ _ _ etaC'_natural.

Definition etaC := locked [the _ ~> _ of etaC'].

Lemma etaCE (T : Type) : etaC T = idfun :> (_ -> _).
Proof. by rewrite /etaC; unlock. Qed.

Import comps_notation.

Lemma triLC : TriangularLaws.left etaC epsC.
Proof. by move=> c; rewrite etaCE epsCE. Qed.

Lemma triRC : TriangularLaws.right etaC epsC.
Proof. by move=> c; rewrite etaCE epsCE. Qed.

End epsC_etaC.

Section convType_as_a_category.
Local Obligation Tactic := idtac.

Let affine_idfun' (U : convType) : affine (@idfun U). Proof. by []. Qed.

Let affine_comp' (a b c : convType) (f : a -> b) (g : b -> c) :
  affine f -> affine g -> affine (g \o f).
Proof. by move=> hf hg ? ? ? /=; rewrite hf hg. Qed.

HB.instance Definition _ := isCategory.Build convType (fun A : convType => A)
  _ affine_idfun' affine_comp'.

End convType_as_a_category.
Notation CV := [the category of convType].

Section conv_hom_is_affine.

Fact conv_hom_is_affine (a b : CV) (f : {hom a, b}) : affine f.
Proof. by case: f=> ? [] []. Qed.

HB.instance Definition _ (A B : convType) (f : {hom A, B}) :=
  isAffine.Build _ _ _ (conv_hom_is_affine f).

End conv_hom_is_affine.

Section free_convType_functor.
Let acto (a : CC) : CV := [the convType of {dist a}].

Definition free_convType_mor (A B : CC) (f : {hom A, B})
    : {hom acto A, acto B} :=
  Hom.Pack (Hom.Class (isHom.Axioms_ (acto A) (acto B)
                                     (fsdistmap f) (fsdistmap_affine f))).

Lemma mem_finsupp_free_convType_mor (A B : CC) (f : A -> B)
    (d : {dist A}) (x : finsupp d) :
  f (fsval x) \in finsupp (free_convType_mor (hom_choiceType f) d).
Proof.
by rewrite /= supp_fsdistmap; apply/imfsetP => /=; exists (fsval x).
Qed.

(* free_convType_mor induces maps between supports *)
Definition free_convType_mor_supp
  (A B : CC) (f : A -> B(*{hom A , B}*)) (d : {dist A}) (x : finsupp d)
  : [finType of finsupp ((free_convType_mor (hom_choiceType f)) d)] :=
  FSetSub (mem_finsupp_free_convType_mor f x).
Global Arguments free_convType_mor_supp [A B] f d.

Lemma fsval_free_convType_mor_supp (A B : choiceType) (f : {hom A , B}) d i :
  fsval (free_convType_mor_supp f d i) = f (fsval i).
Proof. by case: i. Qed.

Let free_convType_mor_id : FunctorLaws.id free_convType_mor.
Proof.
by move=> a; rewrite hom_ext funeqE=> x /=; rewrite fsdistmap_id.
Qed.

Let free_convType_mor_comp : FunctorLaws.comp free_convType_mor.
Proof. by move=> a b c g h; apply/hom_ext; exact: fsdistmap_comp. Qed.

HB.instance Definition _ :=
  isFunctor.Build CC CV acto free_convType_mor_id free_convType_mor_comp.

Definition free_convType := [the {functor CC -> CV} of acto].

Lemma free_convType_mor_comp_fun (A B C : CC) (g : {hom B, C}) (h : {hom A, B}) :
  free_convType_mor [hom g \o h] =
  (free_convType_mor g) \o (free_convType_mor h) :> (_ -> _).
Proof. by rewrite free_convType_mor_comp. Qed.

End free_convType_functor.

Section forget_convType_functor.

Let m1 : CV -> CC := idfun.

Let h1 := fun (a b : CV) (f : {hom CV; a, b}) =>
  Hom.Pack (Hom.Class (isHom.Axioms_ (m1 a) (m1 b) f I)).

Let h1_id : FunctorLaws.id h1. Proof. by move=> *; apply hom_ext. Qed.

Let h1_comp : FunctorLaws.comp h1. Proof. by move=> *; apply hom_ext. Qed.

HB.instance Definition _ := isFunctor.Build _ _ _ h1_id h1_comp.

Definition forget_convType := [the {functor CV -> CC} of m1].

Lemma forget_convTypeE : (forall a : CV, forget_convType a = a) /\
  (forall (a b : CV) (f : {hom CV; a , b}), forget_convType # f = f :> (a -> b)).
Proof. by []. Qed.

End forget_convType_functor.

(*
  eps0 is the counit of the adjunction (free_convType -| forget_convType), and
  it is essentially Convn (p.164).
*)
Section eps0_eta0.
Local Open Scope fset_scope.
Local Open Scope R_scope.
Local Open Scope convex_scope.
Local Notation F0 := free_convType.
Local Notation U0 := forget_convType.

Let eps0' : F0 \O U0 ~~> FId := fun a =>
  Hom.Pack (Hom.Class (isHom.Axioms_ ((F0 \O U0) a) (FId a)
    (@Convn_of_fsdist a) (@Convn_of_fsdist_affine (FId a)))).

Let eps0'_natural : naturality _ _ eps0'.
Proof.
move=> C D f; rewrite FCompE /= /id_f; apply funext => d /=.
by rewrite Convn_of_fsdistmap.
Qed.

HB.instance Definition _ := isNatural.Build _ _ _ _ _ eps0'_natural.
Definition eps0 := locked [the _ ~> _ of eps0'].

Lemma eps0E (C : convType) : eps0 C = @Convn_of_fsdist C :> (_ -> _).
Proof. by rewrite /eps0; unlock. Qed.

Let eta0' : FId ~~> U0 \O F0 := fun T =>
  Hom.Pack (Hom.Class (isHom.Axioms_ (FId T) ((U0 \O F0) T) (@fsdist1 _) I)).

Lemma eta0'_natural : naturality _ _ eta0'.
Proof.
by move=> a b h; rewrite funeqE=> x; rewrite FIdf /eta0' /= fsdistmap1.
Qed.

HB.instance Definition _ := isNatural.Build _ _ _ _ _ eta0'_natural.
Definition eta0 := locked [the _ ~> _ of eta0'].

Lemma eta0E (T : choiceType) : eta0 T = @fsdist1 _ :> (_ -> _).
Proof. by rewrite /eta0; unlock. Qed.

Import comps_notation.
Local Open Scope fset_scope.
Local Open Scope R_scope.

Lemma triL0 : TriangularLaws.left eta0 eps0.
Proof.
by move=> c; apply funext=> x /=; rewrite eps0E eta0E triangular_laws_left0.
Qed.

Lemma triR0 : TriangularLaws.right eta0 eps0.
Proof.
by move=> c; rewrite eps0E eta0E funeqE => a /=; rewrite Convn_of_fsdist1.
Qed.

End eps0_eta0.

(* the join operator for Dist is ((coercion) \o eps0) *)
Section eps0_correct.
Import category.
Local Open Scope R_scope.
Local Open Scope convex_scope.
Variables (A : choiceType) (D : {dist {dist A}}).

Lemma eps0_correct : eps0 _ D = fsdistjoin D.
Proof. by rewrite eps0E Convn_of_fsdistjoin. Qed.

End eps0_correct.

Section semiCompSemiLattConvType_as_a_category.
Import category.
Local Obligation Tactic := idtac.

Definition biglub_affine (a b : semiCompSemiLattConvType) (f : a -> b) :=
  biglubmorph f /\ affine f.

Let comp_is_biglub_affine (a b c : semiCompSemiLattConvType)
    (f : a -> b) (g : b -> c) :
  biglub_affine f -> biglub_affine g -> biglub_affine (g \o f).
Proof.
move=> [bf af] [bg ag]; split => x/=.
  rewrite bf bg/=;congr (biglub _).
  by apply/neset_ext => /=; rewrite image_comp.
by move=> ? ? /=; rewrite af ag.
Qed.

Let idfun_is_biglub_affine (a : semiCompSemiLattConvType) :
  biglub_affine (@idfun a).
Proof. by split => //; exact: biglub_morph. Qed.

HB.instance Definition _ := isCategory.Build semiCompSemiLattConvType
  (fun U : semiCompSemiLattConvType => U) biglub_affine idfun_is_biglub_affine
  comp_is_biglub_affine.

End semiCompSemiLattConvType_as_a_category.
Notation CS := [the category of semiCompSemiLattConvType].

Local Open Scope classical_set_scope.
Local Open Scope latt_scope.

Section scsl_hom_is_biglub_affine.
Import category.
Local Open Scope convex_scope.
Variables (K L : CS) (f : {hom K , L}).

Fact scsl_hom_is_biglub_affine : biglub_affine f.
Proof. by split; move=> ?; case: f=> ? [] [] []. Qed.

(* TODO: The following three lemmas should be inferred from the above one. *)
(* NB: HB.instance? *)
(* Canonical SCSL_hom_biglub_affine (A B : CS)
  (f : {hom A, B}) := BiglubAffine (scsl_hom_is_biglub_affine f). *)
Fact scsl_hom_is_affine : affine f.
Proof. by case: scsl_hom_is_biglub_affine. Qed.

HB.instance Definition SCSL_hom_affine :=
  isAffine.Build _ _ _ scsl_hom_is_affine.
(* Canonical SCSL_hom_affine (K L : CS) (f : {hom K , L}) :=
  Affine (scsl_hom_is_affine f). *)

Fact scsl_hom_is_biglubmorph : biglubmorph f.
Proof. by case: scsl_hom_is_biglub_affine. Qed.

HB.instance Definition SCSL_hom_biglubmorph :=
  isBiglubMorph.Build _ _ _ scsl_hom_is_biglubmorph.
(* Canonical SCSL_hom_biglubmorph (K L : CS)
  (f : {hom K, L}) := BiglubMorph (scsl_hom_is_biglubmorph f). *)

Fact scsl_hom_is_lubmorph : lub_morph f. Proof. exact: biglub_lub_morph. Qed.

End scsl_hom_is_biglub_affine.

Section free_semiCompSemiLattConvType_functor.
Import category.
Local Open Scope convex_scope.

Let acto (a : CV) : CS := {necset a}.

(* the morphism part of necset *)
Section free_semiCompSemiLattConvType_mor.
Variables (A B : convType) (f : {hom A , B}).

Definition free_semiCompSemiLattConvType_mor' (X : acto A) : acto B :=
  NECSet.Pack (NECSet.Class
    (CSet.Mixin (is_convex_set_image
      (Affine.Pack (Affine.Class (isAffine.Axioms_ _ _ (conv_hom_is_affine f))))
      X))
    (NESet.Mixin (neset_image_neq0 _ _))).

(* the results of free_semiCompSemiLattConvType_mor are
   semiLattConvType-morphisms, i.e., are
   affine and preserve semilatt operations *)
Lemma free_semiCompSemiLattConvType_mor'_affine :
  affine free_semiCompSemiLattConvType_mor'.
Proof.
move=> p a0 a1; apply necset_ext => /=; rewrite predeqE => b0; split.
- rewrite !necset_convType.convE.
  case=> a [] a0' a0a0'; rewrite conv_pt_setE=> -[] a1' a1a1' <- <- /=.
  by rewrite affine_conv /=; exact: conv_in_conv_set.
- rewrite !necset_convType.convE.
  move=> /conv_in_conv_set' [] x [] y [] [] a0' a0a0' <- [] [] a1' a1a1' <- ->.
  rewrite affine_image_conv_set /=.
  by apply conv_in_conv_set; apply imageP.
Qed.

Lemma bigsetU_affine (X : neset (necset A)) : (f @` (\bigcup_(x in X) x) =
  \bigcup_(x in free_semiCompSemiLattConvType_mor' @` X) x)%classic.
Proof.
rewrite funeqE => b; rewrite propeqE; split.
- case => a [x Xx xa] <-{b}.
  exists (NECSet.Pack (NECSet.Class
    (CSet.Mixin (is_convex_set_image
      (Affine.Pack (Affine.Class (isAffine.Axioms_ _ _ (conv_hom_is_affine f))))
      x))
    (NESet.Mixin (neset_image_neq0 f x)))) => /=; last by exists a.
  by exists x => //=; exact/necset_ext.
- by case => b0 [a0 Xa0 <-{b0}] [a a0a <-{b}]; exists a => //; exists a0.
Qed.

Lemma free_semiCompSemiLattConvType_mor'_biglub_morph :
  biglubmorph free_semiCompSemiLattConvType_mor'.
Proof.
move=> /= X; apply necset_ext => /=; rewrite funeqE => b.
by rewrite image_preserves_convex_hull bigsetU_affine.
Qed.

Definition free_semiCompSemiLattConvType_mor : {hom acto A, acto B} :=
  locked (Hom.Pack (Hom.Class (isHom.Axioms_
    (acto A) (acto B)
    free_semiCompSemiLattConvType_mor'
    (conj free_semiCompSemiLattConvType_mor'_biglub_morph
          free_semiCompSemiLattConvType_mor'_affine)))).

Lemma free_semiCompSemiLattConvType_morE (X : acto A) :
  NECSet.mixinType (free_semiCompSemiLattConvType_mor X) = image_neset f X.
Proof.
by rewrite /free_semiCompSemiLattConvType_mor; unlock; apply neset_ext.
Qed.

Lemma free_semiCompSemiLattConvType_morE' (X : acto A) :
  NESet.car (NECSet.mixinType (free_semiCompSemiLattConvType_mor X)) =
  image_neset f X.
Proof. by rewrite /free_semiCompSemiLattConvType_mor; unlock. Qed.

End free_semiCompSemiLattConvType_mor.

Lemma free_semiCompSemiLattConvType_mor_id :
  FunctorLaws.id free_semiCompSemiLattConvType_mor.
Proof.
move=> a; rewrite hom_ext funeqE=> /= x /=; apply necset_ext => /=.
by rewrite free_semiCompSemiLattConvType_morE' /= image_id.
Qed.

Lemma free_semiCompSemiLattConvType_mor_comp :
  FunctorLaws.comp free_semiCompSemiLattConvType_mor.
Proof.
move=> a b c [] g affine_g [] h affine_h; rewrite hom_ext funeqE => /= x /=.
apply necset_ext => /=.
rewrite 2!free_semiCompSemiLattConvType_morE' /= -image_comp.
by rewrite free_semiCompSemiLattConvType_morE'.
Qed.

HB.instance Definition _ := isFunctor.Build _ _ acto
  free_semiCompSemiLattConvType_mor_id free_semiCompSemiLattConvType_mor_comp.

(* F1 *)
Definition free_semiCompSemiLattConvType := [the {functor CV -> CS} of acto].

End free_semiCompSemiLattConvType_functor.

Section forget_semiCompSemiLattConvType_functor.

Let m2 : CS -> CV := idfun.

Let h2 := fun (a b : CS) (f : {hom CS; a, b}) => Hom.Pack (Hom.Class
  (isHom.Axioms_ (m2 a) (m2 b) f (scsl_hom_is_affine f))).

Let h2_id : FunctorLaws.id h2. Proof. by move=> *; apply hom_ext. Qed.

Let h2_comp : FunctorLaws.comp h2. Proof. by move=> *; apply hom_ext. Qed.

HB.instance Definition _ := isFunctor.Build _ _ m2 h2_id h2_comp.

Definition forget_semiCompSemiLattConvType := [the {functor CS -> CV} of m2].

Local Notation U1 := forget_semiCompSemiLattConvType.

(* TODO: document the removal of forget_semiCompSemiLattConvTypeE *)
(*
Lemma forget_semiCompSemiLattConvTypeE : (forall a : CS, forget_convType a = a)
  /\ (forall (a b : CS) (f : {hom CS; a , b}), U1 # f = f :> (a -> b)).
Proof. by []. Qed.
*)
End forget_semiCompSemiLattConvType_functor.

Section eps1_eta1.
Import category.
Local Open Scope classical_set_scope.
Local Open Scope convex_scope.
Local Notation F1 := free_semiCompSemiLattConvType.
Local Notation U1 := forget_semiCompSemiLattConvType.
Implicit Types L : semiCompSemiLattConvType.

Let eps1'' L := (fun X : {necset L} => |_| X).

Lemma eps1''_biglubmorph L : biglubmorph (@eps1'' L).
Proof.
move=> F.
transitivity (|_| (biglub @` ((fun X : {necset L} => (X : neset _)) @` F))%:ne).
  transitivity (|_| (hull (\bigcup_(x in F) x))%:ne).
    by congr (|_| _); apply neset_ext.
  by rewrite biglub_hull biglub_bigcup.
congr (|_| _).
apply/neset_ext; rewrite eqEsubset; split => x [] x0 Fx0 <-.
+ by case: Fx0 => x1 Fx1 <-; exists x1.
+ by exists x0 => // ; exists x0.
Qed.

Lemma eps1''_affine L : affine (@eps1'' L).
Proof.
move=> p X Y; rewrite -biglub_conv_setD.
congr (|_| _%:ne); apply/neset_ext => /=.
by rewrite necset_convType.convE.
Qed.

Let eps1' : F1 \O U1 ~~> FId := fun L => Hom.Pack (Hom.Class (isHom.Axioms_
  ((F1 \O U1) L) (FId L) (@eps1'' L)
  (conj (@eps1''_biglubmorph L) (@eps1''_affine L)))).

Lemma eps1'_natural : naturality _ _ eps1'.
Proof.
move=> K L f /=; rewrite funeqE => X /=.
rewrite biglub_morph; congr (|_| _).
by rewrite free_semiCompSemiLattConvType_morE.
Qed.

HB.instance Definition _ := isNatural.Build _ _ _ _ _ eps1'_natural.

Definition eps1 := locked [the _ ~> _ of eps1'].

Lemma eps1E (L : semiCompSemiLattConvType) :
  eps1 L = (fun X => |_| X) :> (_ -> _).
Proof. by rewrite /eps1; unlock. Qed.

Lemma necset1_affine (C : convType) : affine (@necset1 C).
Proof.
move=> p a b /=; apply/necset_ext; rewrite eqEsubset; split=> x /=.
- move->; rewrite necset_convType.convE.
  by apply conv_in_conv_set.
- rewrite necset_convType.convE /necset1 /=.
  by case/conv_in_conv_set'=> a0 [] b0 [] -> [] -> ->.
Qed.

Let eta1' : FId ~~> U1 \O F1 := fun C => Hom.Pack (Hom.Class
  (isHom.Axioms_ (FId C) ((U1 \O F1) C) (@necset1 C) (@necset1_affine C))).

Lemma eta1'_natural : naturality _ _ eta1'.
Proof.
move=> a b h; rewrite funeqE => x; apply necset_ext => /=.
by rewrite free_semiCompSemiLattConvType_morE' /= image_set1.
Qed.

HB.instance Definition _ := isNatural.Build _ _ _ _ _ eta1'_natural.

Definition eta1 := locked [the _ ~> _ of eta1'].

Lemma eta1E (C : convType) : eta1 C = @necset1 _ :> (_ -> _).
Proof. by rewrite /eta1; unlock. Qed.

Import comps_notation.

Lemma necset1E (T : convType) (t : T) : necset1 t = [set t] :> set T.
Proof. by []. Qed.

Lemma triL1 : TriangularLaws.left eta1 eps1.
Proof.
move=> c; apply funext => x /=; apply/necset_ext => /=.
rewrite eps1E /= free_semiCompSemiLattConvType_morE' /=.
rewrite -[in RHS](hull_cset x); congr hull.
rewrite eqEsubset eta1E; split=> a.
- by case=> y [] b xb <-; rewrite necset1E => ->.
- by move=> xa; exists (necset1 a); [exists a | rewrite necset1E].
Qed.

Lemma triR1 : TriangularLaws.right eta1 eps1.
Proof. by move=> c; apply funext=> /= x; rewrite eps1E eta1E /= biglub1. Qed.

End eps1_eta1.

Section join1.
Import category.
Local Open Scope convex_scope.
Local Open Scope classical_set_scope.
Variable C : convType.

Definition join1' (s : necset {necset C}) : {convex_set C} :=
  CSet.Pack (CSet.Mixin
    (hull_is_convex (\bigcup_(x in s) if x \in s then x : set _ else cset0 _))).

Lemma join1'_neq0 (s : necset {necset C}) : join1' s != set0 :> set _.
Proof.
rewrite hull_eq0 set0P.
case/set0P: (neset_neq0 s) => y.
case/set0P: (neset_neq0 y) => x yx sy.
by exists x; exists y => //; move: sy; rewrite -in_setE => ->.
Qed.

Definition join1 (s : necset {necset C}) : necset C :=
  NECSet.Pack (NECSet.Class (CSet.Mixin (hull_is_convex _))
                            (NESet.Mixin (join1'_neq0 s))).

Lemma eps1_correct (s : necset {necset C}) : @eps1 _ s = join1 s.
Proof.
rewrite eps1E; apply/necset_ext => /=; congr (hull _).
rewrite /bigcup; rewrite funeqE => c; rewrite propeqE; split.
- by case=> X sX Xc; exists X => //; rewrite -in_setE in sX; rewrite sX.
- case=> X sX; rewrite -in_setE in sX; rewrite sX => Xc; exists X => //.
  by rewrite -in_setE.
Qed.

End join1.

Section P_delta_functor.
Import category.

Definition P_delta_left :=
  free_semiCompSemiLattConvType \O free_convType \O free_choiceType.

Definition P_delta_right :=
  forget_choiceType \O forget_convType \O forget_semiCompSemiLattConvType.

(* action on objects *)
Definition P_delta_acto (T : Type) : Type := P_delta_left T.

Definition P_delta : {functor CT -> CT} := P_delta_right \O P_delta_left.

Lemma P_deltaE (A B : Type) (f : {hom A, B}) :
  P_delta # f = P_delta_left # f :> (_ -> _).
Proof. exact: funext. Qed.

Lemma eps0_Dist1 (A : Type) (d : P_delta_acto A) : eps0 _ (fsdist1 d) = d.
Proof. by rewrite eps0E Convn_of_fsdist1. Qed.

End P_delta_functor.

(* TODO: move? *)
Require monad_lib.
Require Import hierarchy.

Section P_delta_category_monad.
Import category.
Definition AC := AdjointFunctors.mk triLC triRC.
Definition A0 := AdjointFunctors.mk triL0 triR0.
Definition A1 := AdjointFunctors.mk triL1 triR1.
Definition Aprob := adj_comp AC A0.
Definition Agcm := adj_comp Aprob A1.
Definition Mgcm := Monad_of_adjoint_functors Agcm.
Definition gcm :=
  [the hierarchy.Monad.Exports.monad of Monad_of_category_monad.acto Mgcm].

Section gcm_opsE.
Import hierarchy.

Lemma gcm_retE (T : Type) (x : choice_of_Type T) :
  Ret x = necset1 (fsdist1 x) :> gcm T.
Proof.
rewrite /= /ret_ /Monad_of_category_monad.ret /=.
rewrite !HCompId !HIdComp /=.
rewrite /id_f /= /etaC.
unlock => /=.
by rewrite eta0E eta1E.
Qed.

Local Notation F1 := free_semiCompSemiLattConvType.
Local Notation F0 := free_convType.
Local Notation FC := free_choiceType.
Local Notation UC := forget_choiceType.
Local Notation U0 := forget_convType.
Local Notation U1 := forget_semiCompSemiLattConvType.

Variables (T : Type) (X : gcm (gcm T)).

Import category.
Local Open Scope convex_scope.

Lemma gcm_joinE : Join X = necset_join X.
Proof.
apply/necset_ext.
rewrite /= /join_ /= /Monad_of_category_monad.join /= !HCompId !HIdComp eps1E.
rewrite functor_o NEqE functor_id compfid.
rewrite 2!VCompE_nat HCompId HIdComp.
set E := epsC _; have->: E = [hom idfun] by apply/hom_ext; rewrite epsCE.
rewrite functor_id_hom.
rewrite !functor_o functor_id !compfid.
set F1J := F1 # _.
have-> : F1J = @necset_join.F1join0 _ :> (_ -> _).
- apply funext=> x; apply necset_ext=> /=.
  rewrite /F1J /= /necset_join.F1join0' /=.
  cbn.
  rewrite /free_semiCompSemiLattConvType_mor; unlock=> /=.
  by rewrite eps0E.
congr hull; apply: classical_sets.eq_bigcup; first by rewrite -eqEsubset.
by move=> x nXx; case: ifPn => // /negP; rewrite in_setE.
Qed.

End gcm_opsE.
End P_delta_category_monad.

Require proba_monad_model.

Section probMonad_out_of_F0U0.
Import category.
(* probability monad built directly *)
Definition M := proba_monad_model.MonadProbModel.t.
(* probability monad built using adjunctions *)
Definition N := [the hierarchy.Monad.Exports.monad of
  Monad_of_category_monad.acto (Monad_of_adjoint_functors Aprob)].

Lemma actmE T : N T = M T. Proof. by []. Qed.

Import comps_notation hierarchy.
Local Open Scope monae_scope.

Lemma JoinE T : (Join : (N \o N) T -> N T) = (Join : (M \o M) T -> M T).
Proof.
apply funext => t /=.
rewrite /join_.
rewrite [in LHS]/= HCompId HIdComp [X in _ (X t)]/=.
rewrite /actm [in LHS]/=.
rewrite epsCE.
rewrite eps0_correct.
rewrite /fsdistjoin /fsdistmap /= fsdistbindA /=.
congr fsdistbind.
by apply funext => x; rewrite fsdist1bind.
Qed.

Lemma RetE T : (Ret : FId T -> N T) = (Ret : FId T -> M T).
Proof.
apply funext => t /=.
rewrite /ret_.
rewrite [in LHS]/=.
by rewrite HCompId HIdComp [X in _ (X t)]/= eta0E etaCE.
Qed.

End probMonad_out_of_F0U0.


Require Export Iron.Language.SystemF2Effect.Type.Exp.Base.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivT.

(********************************************************************)
(* Type subsumptinon.
   The interesting cases all concern sums. *)
Inductive SubsT : kienv -> stprops -> ty -> ty -> ki -> Prop :=
 | SbEquiv
   :  forall  ke sp t1 t2 k
   ,  EquivT  ke sp t1 t2 k
   -> SubsT   ke sp t1 t2 k

 | SbTrans
   :  forall  ke sp t1 t2 t3 k
   ,  SubsT   ke sp t1 t2 k -> SubsT  ke sp t2 t3 k
   -> SubsT   ke sp t1 t3 k

 | SbBot
   :  forall  ke sp t k
   ,  SumKind k
   -> KindT   ke sp t k
   -> SubsT   ke sp t (TBot k) k

 | SbSumAbove
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 t2 k -> SubsT  ke sp t1 t3 k
   -> SubsT   ke sp t1 (TSum t2 t3) k

 | SbSumBelow
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> KindT   ke sp t3 k
   -> SubsT   ke sp t1 t2 k
   -> SubsT   ke sp (TSum t1 t3) t2 k

 | SbSumAboveLeft
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 (TSum t2 t3) k
   -> SubsT   ke sp t1 t2 k

 | SbSumAboveRight
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 (TSum t2 t3) k
   -> SubsT   ke sp t1 t3 k.

Hint Constructors SubsT.

(********************************************************************)
(* Kind projection *)
Lemma subsT_kind_left
 :  forall ke sp t1 t2 k
 ,  SubsT  ke sp t1 t2 k
 -> KindT  ke sp t1 k.
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve subsT_kind_left.

Lemma subsT_kind_right
 :  forall ke sp t1 t2 k
 ,  SubsT  ke sp t1 t2 k
 -> KindT  ke sp t2 k.
Proof.
 intros.
 induction H; eauto.
  inverts IHSubsT. eauto.
  inverts IHSubsT. eauto.
Qed.
Hint Resolve subsT_kind_right.

(* Sumkind projection *)
Lemma subsT_sumkind_left
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp (TSum t1 t2) t3 k
 -> SumKind k.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve subsT_sumkind_left.

Lemma subsT_sumkind_right
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp t1 (TSum t2 t3) k
 -> SumKind k.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve subsT_sumkind_right.

(* Subs/Equiv *)
Lemma subsT_equiv_above
 :  forall ke sp t1 t1' t2 k
 ,  EquivT ke sp t1  t1' k
 -> SubsT  ke sp t1  t2  k
 -> SubsT  ke sp t1' t2  k.
Proof.
 intros.
 eapply SbTrans with (t2 := t1); eauto.
Qed.
Hint Resolve subsT_equiv_above.

Lemma subsT_equiv_below
 :  forall ke sp t1 t2 t2' k
 ,  EquivT ke sp t2 t2' k
 -> SubsT  ke sp t1 t2  k
 -> SubsT  ke sp t1 t2' k.
Proof.
 intros.
 eapply SbTrans with (t1 := t1); eauto.
Qed.
Hint Resolve subsT_equiv_below.

(* Subs sum lemmas *)
Lemma subsT_sum_comm_below
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp t1 (TSum t2 t3) k
 -> SubsT  ke sp t1 (TSum t3 t2) k.
Proof.
 intros.
 eapply subsT_equiv_below with (t2 := TSum t2 t3).
  have HK: (KindT ke sp (TSum t2 t3) k). inverts HK.
  eapply EqSumComm; eauto.
  auto.
Qed.
Hint Resolve subsT_sum_comm_below.

Lemma subsT_sum_comm_above
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp (TSum t1 t2) t3 k
 -> SubsT  ke sp (TSum t2 t1) t3 k.
Proof.
 intros.
 eapply subsT_equiv_above with (t1 := TSum t1 t2).
  have HK: (KindT ke sp (TSum t1 t2) k). inverts HK.
  eapply EqSumComm; eauto.
  auto.
Qed.
Hint Resolve subsT_sum_comm_above.

Lemma subsT_sum_left
 : forall ke sp t1 t1' t2 k
 ,  SumKind k
 -> KindT  ke sp t2 k
 -> SubsT  ke sp t1 t1' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1' t2) k.
Proof.
 intros.
 eapply SbSumAbove; eauto.
Qed.
Hint Resolve subsT_sum_left.

Lemma subsT_sum_right
 :  forall ke sp t1 t2 t2' k
 ,  SumKind k
 -> KindT   ke sp t1 k
 -> SubsT  ke sp t2 t2' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1 t2') k.
Proof.
 intros.
 eapply SbSumAbove; eauto.
Qed.
Hint Resolve subsT_sum_right.

Lemma subsT_sum_merge
 :  forall ke sp t1 t1' t2 t2' k
 ,  SumKind k
 -> SubsT  ke sp t1 t1' k
 -> SubsT  ke sp t2 t2' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1' t2') k.
Proof.
 intros.
 eapply SbTrans with (t2 := TSum t1' t2); eauto.
Qed.
Hint Resolve subsT_sum_merge.

Lemma subsT_stprops_snoc
 :  forall ke sp p t1 t2 k
 ,  SubsT  ke sp        t1 t2 k
 -> SubsT  ke (p <: sp) t1 t2 k.
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve subsT_stprops_snoc.

Lemma subsT_stprops_app
 :  forall ke sp sp' t1 t2 k
 ,  SubsT ke sp          t1 t2 k
 -> SubsT ke (sp' >< sp) t1 t2 k.
Proof.
 intros. gen ke sp k.
 induction sp'; intros; snorm; auto.
 - rrwrite ((sp' :> a) >< sp = sp' >< (a <: sp)).
   snorm.
Qed.
Hint Resolve subsT_stprops_app.

Lemma subsT_stprops_extends
 :  forall ke sp sp' e1 e2 k
 ,  extends sp' sp
 -> SubsT ke sp  e1 e2 k
 -> SubsT ke sp' e1 e2 k.
Proof.
 intros.
 unfold extends in *.
 destruct H. subst.
 snorm.
Qed.

Lemma subsT_closed_kenv_cons
 :  forall sp t1 t2 k1 k2
 ,  SubsT nil sp t1 t2 k1
 -> SubsT (nil :> k2) sp t1 t2 k1.
Proof.
 intros.
 remember nil as KE.
 induction H; subst; eauto 4.

 - Case "SbBot".
   eapply SbBot; auto.
   have (ClosedT t).
   eapply kind_kienv_weaken in H0.
   rrwrite (liftTT 1 0 t = t).
   eauto.

 - Case "SbSumAbove".
   eapply SbSumBelow; auto.
   have (ClosedT t3).
   eapply kind_kienv_weaken in H0.
   rrwrite (liftTT 1 0 t3 = t3).
   eauto.
Qed.
Hint Resolve subsT_closed_kenv_cons.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.ChoiceFacts.
Require Import Coq.Logic.ClassicalChoice.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relations.
Require Export Coq.Classes.Morphisms.
Require Export Logic.lib.Relation_ext.
Require Export Logic.lib.RelationPairs_ext.

Module KI.

Class Relation (worlds: Type): Type :=
  Krelation: worlds -> Ensemble worlds (* <= *).

End KI.

Export KI.

Module KripkeModelNotation_Intuitionistic.

Infix "<=" := Krelation: kripke_model.

End KripkeModelNotation_Intuitionistic.

Import KripkeModelNotation_Intuitionistic.

Local Open Scope kripke_model.

Definition upwards_closed_Kdenote {worlds: Type} {R: Relation worlds} (d: Ensemble worlds): Prop :=
  forall n m, n <= m -> d n -> d m.

Definition Krelation_stable_Kdenote {worlds: Type} {R: Relation worlds} (d: Ensemble worlds): Prop :=
  forall w1 w2, w1 <= w2 -> (d w1 <-> d w2).

Definition MonoEnsemble (A: Type) {R: Relation A}: Type := @sig (_ -> Prop) (@upwards_closed_Kdenote A R).

Class IdentityKripkeIntuitionisticModel (worlds: Type) {R: Relation worlds} : Prop := {
  Korder_identity: forall m n: worlds, m <= n -> m = n
}.

Class NoBranchKripkeIntuitionisticModel (worlds: Type) {R: Relation worlds} : Prop := {
  Korder_no_branch: forall m1 m2 n: worlds, n <= m1 -> n <= m2 -> m1 <= m2 \/ m2 <= m1
}.

Class BranchJoinKripkeIntuitionisticModel (worlds: Type) {R: Relation worlds} : Prop := {
  Korder_branch_join: forall m1 m2 n: worlds, n <= m1 -> n <= m2 -> exists m, m1 <= m /\ m2 <= m
}.

Instance prod_BranchJoinKripkeIntuitionisticModel (A B: Type) {RA: Relation A} {RB: Relation B} {bkiMA: BranchJoinKripkeIntuitionisticModel A} {bkiMB: BranchJoinKripkeIntuitionisticModel B}: @BranchJoinKripkeIntuitionisticModel (A * B) (RelProd RA RB).
Proof.
  constructor.
  intros [m11 m12] [m21 m22] [n1 n2] [? ?] [? ?].
  hnf in H, H0, H1, H2; simpl in *.
  destruct (@Korder_branch_join _ _ bkiMA m11 m21 n1 H H1) as [m1 [? ?]].
  destruct (@Korder_branch_join _ _ bkiMB m12 m22 n2 H0 H2) as [m2 [? ?]].
  exists (m1, m2); split; split; auto.
Qed.

Instance fun_BranchJoinKripkeIntuitionisticModel (A B: Type) {RB: Relation B} {bkiMB: BranchJoinKripkeIntuitionisticModel B}: @BranchJoinKripkeIntuitionisticModel (A -> B) (pointwise_relation A RB).
Proof.
  constructor.
  intros.
  destruct (choice (fun x fx => m1 x <= fx /\ m2 x <= fx)) as [m ?].
  + intros.
    specialize (H x).
    specialize (H0 x).
    destruct (Korder_branch_join _ _ _ H H0) as [y [? ?]].
    exists y; auto.
  + exists m.
    split; intros x; specialize (H1 x); tauto.
Qed.

Instance option00_BranchJoinKripkeIntuitionisticModel (A: Type) {R: Relation A} {bkiM: BranchJoinKripkeIntuitionisticModel A}: @BranchJoinKripkeIntuitionisticModel (option A) (option00_relation R).
Proof.
  constructor.
  intros.
  inversion H; inversion H0; try congruence; subst.
  + exists None; split; auto.
  + inversion H5; subst.
    clear H0 H H5.
    destruct (Korder_branch_join _ _ _ H1 H4) as [b' [? ?]].
    exists (Some b').
    split; constructor; auto.
Qed.

Instance NoBranch2BranchJoin (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {nkiM: NoBranchKripkeIntuitionisticModel A}: BranchJoinKripkeIntuitionisticModel A.
Proof.
  constructor.
  intros.
  pose proof Korder_no_branch _ _ _ H H0.
  destruct H1.
  + exists m2; split; auto.
    reflexivity.
  + exists m1; split; auto.
    reflexivity.
Qed.

Instance eq_ikiM {worlds: Type}: @IdentityKripkeIntuitionisticModel worlds eq.
Proof.
  constructor.
  intros; auto.
Qed.


Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
Require Import syntax_ott.
Require Import syntaxb_ott.

Inductive eexp : Set :=  (*r eexpressions *)
 | ee_var_b (_:nat) (*r variables *)
 | ee_var_f (x:var) (*r variables *)
 | ee_lit (i5:i) (*r lit *)
 | ee_abs (e:eexp) (p:var) (b:bool) (*r abstractions *)
 | ee_app (e1:eexp) (p:var) (b:bool) (e2:eexp) (*r applications *)
 | ee_anno (e:eexp) (p:var) (b:bool) (A:typ) (*r annotation *)
 | ee_add : eexp (*r addition *)
 | ee_addl (i5:i) (*r addl *).

 Inductive dirflag2 : Set :=  (*r checking direction *)
 | Inf2 : dirflag2
 | Chk2 (p:var) (b:bool) (A:typ): dirflag2.

 Fixpoint open_eexp_wrt_eexp_rec (k:nat) (e_5:eexp) (e__6:eexp) {struct e__6}: eexp :=
  match e__6 with
  | (ee_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => ee_var_b nat
        | inleft (right _) => e_5
        | inright _ => ee_var_b (nat - 1)
      end
  | (ee_var_f x) => ee_var_f x
  | (ee_lit i5) => ee_lit i5
  | (ee_abs e l b) => ee_abs (open_eexp_wrt_eexp_rec (S k) e_5 e) l b
  | (ee_app e1 p b e2) => ee_app (open_eexp_wrt_eexp_rec k e_5 e1) p b (open_eexp_wrt_eexp_rec k e_5 e2)
  | (ee_anno e p b A) => ee_anno (open_eexp_wrt_eexp_rec k e_5 e) p b A
  | ee_add => ee_add
  | (ee_addl i5) => ee_addl i5
end.

Definition open_eexp_wrt_eexp e_5 e__6 := open_eexp_wrt_eexp_rec 0 e__6 e_5.

Inductive lc_eexp : eexp -> Prop :=    (* defn lc_eexp *)
 | lc_ee_var_f : forall (x:var),
     (lc_eexp (ee_var_f x))
 | lc_ee_lit : forall (i5:i),
     (lc_eexp (ee_lit i5))
 | lc_ee_abs : forall (e:eexp) l b,
      ( forall x , lc_eexp  ( open_eexp_wrt_eexp e (ee_var_f x) )  )  ->
     (lc_eexp (ee_abs e l b))
 | lc_ee_app : forall (e1 e2:eexp) p b ,
     (lc_eexp e1) ->
     (lc_eexp e2) ->
     (lc_eexp (ee_app e1 p b e2))
 | lc_ee_anno : forall (e:eexp)  (p:var) (A:typ) b,
     (lc_eexp e) ->
     (lc_eexp (ee_anno e p b A))
 | lc_ee_add :
     (lc_eexp ee_add)
 | lc_ee_addl : forall (i5:i),
     (lc_eexp (ee_addl i5)).

(** free variables *)
Fixpoint fv_eexp (e_5:eexp) : vars :=
  match e_5 with
  | (ee_var_b nat) => {}
  | (ee_var_f x) => {{x}}
  | (ee_lit i5) => {}
  | (ee_abs e l b) => (fv_eexp e)
  | (ee_app e1 p b e2) => (fv_eexp e1) \u (fv_eexp e2)
  | (ee_anno e p b A) => (fv_eexp e)
  | ee_add => {}
  | (ee_addl i5) => {}
end.

(** substitutions *)
Fixpoint subst_eexp (ee_5:eexp) (x5:var) (e__6:eexp) {struct e__6} : eexp :=
  match e__6 with
  | (ee_var_b nat) => ee_var_b nat
  | (ee_var_f x) => (if eq_var x x5 then ee_5 else (ee_var_f x))
  | (ee_lit i5) => ee_lit i5
  | (ee_abs e l b) => ee_abs (subst_eexp ee_5 x5 e) l b
  | (ee_app e1 p b e2) => ee_app (subst_eexp ee_5 x5 e1) p b (subst_eexp ee_5 x5 e2)
  | (ee_anno e p b A) => ee_anno (subst_eexp ee_5 x5 e) p b A
  | ee_add => ee_add
  | (ee_addl i5) => (ee_addl i5)
end.

Fixpoint erase (e:eexp) : exp :=
  match e with
  | (ee_var_b nat) => e_var_b nat
  | (ee_var_f x) => (e_var_f x)
  | (ee_lit i5) => (e_lit i5)
  | (ee_anno e p b A) => (e_anno (erase e) A)
  | (ee_abs e l b ) => (e_abs (erase e))
  | (ee_add) => e_add
  | (ee_app e1 p b e2) => e_app (erase e1) (erase e2)
  | (ee_addl i5) => e_addl i5
  end.

Inductive nnlam : eexp -> Prop :=
  | nnl_var_b : forall nat,
    nnlam (ee_var_b nat)
 | nnl_var_nat : forall (x:var),
     nnlam (ee_var_f x)
 | nnl_var_f : forall (x:var),
     nnlam (ee_var_f x)
 | nnl_lit : forall (i5:i),
     nnlam (ee_lit i5)
 | nnl_app : forall (e1 e2:eexp) l b ,
     nnlam (ee_app e1 l b e2)
 | nnl_anno : forall (e:eexp) (A:typ) l b ,
     nnlam (ee_anno e l b A)
 | nnl_add :
     nnlam (ee_add)
 | nnl_addl : forall i,
     nnlam (ee_addl i).

Inductive TTyping : ctx -> eexp -> dirflag -> typ -> Prop :=    (* defn TTyping *)
 | TTyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     TTyping G (ee_lit i5) Inf t_int
 | TTyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     TTyping G (ee_var_f x) Inf A
 | TTyp_abs : forall (L:vars) (G:ctx) (A:typ) (e:eexp) (B:typ) l b,
      ( forall x , x \notin  L  -> TTyping  (cons ( x , A )  G )   ( open_eexp_wrt_eexp e (ee_var_f x) )  Chk B )  ->
     TTyping G (ee_abs e l b ) Chk (t_arrow A B)
 | TTyp_absd : forall (L:vars) (G:ctx) (e:eexp) l b,
     ( forall x , x \notin  L  -> TTyping  (cons ( x , t_dyn )  G )   ( open_eexp_wrt_eexp e (ee_var_f x) )  Chk t_dyn )  ->
    TTyping G (ee_abs e l b ) Chk t_dyn
 | TTyp_sugar : forall (L:vars) (G:ctx) (e:eexp) l b,
    ( forall x , x \notin  L  -> TTyping  (cons ( x , t_dyn )  G )   ( open_eexp_wrt_eexp e (ee_var_f x) )  Chk t_dyn )  ->
   TTyping G (ee_abs e l b) Inf (t_arrow t_dyn t_dyn)
 | TTyp_app : forall (G:ctx) (e1 e2:eexp) (A1 A2 A:typ) l b,
     pattern A (t_arrow A1 A2) ->
     TTyping G e1 Inf A ->
     TTyping G e2 Chk A1 ->
     TTyping G (ee_app e1 l b e2) Inf A2
 | TTyp_anno : forall (G:ctx) (e:eexp) (p:var) b (A:typ),
     TTyping G e Chk A ->
     TTyping G  ( (ee_anno e p b A) )  Inf A
 | TTyp_sim : forall (G:ctx) (e:eexp) (B A:typ),
     TTyping G e Inf A ->
     sim A B ->
     nnlam e ->
     TTyping G e Chk B
 | TTyp_add : forall (G:ctx),
     uniq  G  ->
     TTyping G ee_add Inf (t_arrow t_int  (t_arrow t_int t_int) )
 | TTyp_addl : forall (G:ctx) (i1:i),
     uniq  G  ->
     TTyping G (ee_addl i1) Inf (t_arrow t_int t_int).

Inductive rres : Type :=
     | ee_exp  : eexp -> rres
     | ee_blame : var -> bool -> rres.

Fixpoint eraser (r:rres) : res :=
  match r with
  | (ee_exp e) => e_exp (erase e)
  | ee_blame l b => e_blame
  end.

Inductive cctx_item : Type :=
     | eappCtxL : eexp -> var -> bool -> cctx_item
     | eappCtxR : eexp -> var -> bool -> cctx_item
     | eannoCtx : var -> bool -> typ -> cctx_item.

Fixpoint pprincipal_type (v:eexp) : typ :=
  match v with
  | (ee_lit i5) => t_int
  | (ee_anno e p b A) => A
  | (ee_abs e l b ) => (t_arrow t_dyn t_dyn)
  | (ee_add) => (t_arrow t_int (t_arrow t_int t_int))
  | (ee_addl i5) => (t_arrow t_int t_int)
  | _ => t_dyn
  end.

(* defns Values *)
Inductive evalue : eexp -> Prop :=    (* defn value *)
 | evalue_lit : forall (i5:i),
     evalue (ee_lit i5)
 | evalue_abs : forall e l b,
     lc_eexp (ee_abs e l b) ->
     evalue (ee_abs e l b)
 | evalue_fanno : forall (v:eexp) (A B C D:typ) (p:var) b,
     evalue v ->
      (t_arrow C D)  =   (pprincipal_type   ( v )  )   ->
     evalue (ee_anno v p b (t_arrow A B))
 | evalue_dyn : forall (v:eexp) (p:var) b,
     Ground   (pprincipal_type  v )   ->
     evalue v ->
     evalue  ( (ee_anno v p b t_dyn) )
 | evalue_add :
     evalue ee_add
 | evalue_addl : forall (i5:i),
     evalue  ( (ee_addl i5) ).

Inductive wwellformed : cctx_item -> Prop :=
     | wwf_appCtxL : forall (e : eexp) p b,
                   lc_eexp e ->
                    wwellformed (eappCtxL e p b )
     | wf_appCtxR : forall (v : eexp) p b A B,
                    pprincipal_type v = (t_arrow A B) ->
                    evalue v ->
                    wwellformed (eappCtxR v p b)
     | wf_annoCtx : forall (A : typ)  (p:var) b,
                    wwellformed (eannoCtx p b A).

Definition ffill (E : cctx_item) (e : eexp) : eexp :=
     match E with
     | eappCtxL e2 p b  => ee_app e p b e2
     | eappCtxR v1 p b => ee_app v1 p b e
     | eannoCtx p b A => ee_anno e p b A
     end.

Inductive TTypedReduce : eexp -> var -> bool -> typ -> rres -> Prop :=    (* defn TTypedReduce *)
 | TTReduce_abs: forall v A B C D p b,
   sim (t_arrow C D) (t_arrow A B) ->
   pprincipal_type v = (t_arrow C D) ->
   TTypedReduce v p b (t_arrow A B) (ee_exp (ee_anno v p b (t_arrow A B)))
  | TTReduce_v : forall (v:eexp)  (p:var) b,
   Ground(pprincipal_type v) ->
   TTypedReduce v p b t_dyn (ee_exp (ee_anno v p b t_dyn))
 | TTReduce_lit : forall (i5:i) b (p:var),
     TTypedReduce (ee_lit i5) p b t_int (ee_exp (ee_lit i5))
 | TTReduce_dd : forall (v:eexp) (p:var) (q:var) b1 b2,
     lc_eexp v ->
     TTypedReduce  ( (ee_anno v q b1 t_dyn) ) p b2 t_dyn  (ee_exp  (ee_anno v q b1 t_dyn) )
 | TTReduce_anyd : forall (v:eexp) (p:var) b,
      FLike (pprincipal_type  v )  ->
     TTypedReduce v p b t_dyn  (ee_exp (ee_anno  ( (ee_anno v p b (t_arrow t_dyn t_dyn)) ) p b t_dyn) )
 | TTReduce_adyn : forall e (A:typ) l1 b1 l2 b2 l0 b0,
     FLike A ->
     TTypedReduce  ( (ee_anno (ee_abs e l0 b0) l1 b1 t_dyn) ) l2 b2 A  (ee_exp (ee_anno (ee_anno (ee_abs e l0 b0) l1 b1 (t_arrow t_dyn t_dyn)) l2 b2 A))
 | TTReduce_absd : forall e l1 b1 l2 b2 l0 b0,
     TTypedReduce  ( (ee_anno (ee_abs e l0 b0) l1 b1 t_dyn) )  l2 b2 (t_arrow t_dyn t_dyn)  (ee_exp (ee_anno (ee_abs e l0 b0) l1 b1 (t_arrow t_dyn t_dyn)))
 | TTReduce_dyna : forall (v:eexp) (A:typ) (p:var) b1 b2 (q:var),
      FLike A ->
     sim (pprincipal_type v) A ->
     nnlam v ->
    TTypedReduce  ( (ee_anno v q b1 t_dyn) ) p b2 A  (ee_exp (ee_anno v p b2 A) )
 | TTReduce_vany : forall (v:eexp) (p:var)  (q:var) b1 b2,
    nnlam v ->
   TTypedReduce (ee_anno v q b1 t_dyn) p b2 (pprincipal_type  v) (ee_exp v)
 | TTReduce_blame : forall (v:eexp) (A:typ) (p:var) b1 b2 (q:var),
      not (sim A (pprincipal_type  v ))  ->
     TTypedReduce (ee_anno v q b1 t_dyn) p b2 A (ee_blame p b2).

Inductive waluee : eexp -> Prop :=    (* defn value *)
 | waluee_lit : forall (i5:i),
     waluee (ee_lit i5)
 | waluee_absd : forall e l b l0 b0,
     lc_eexp (ee_abs e l0 b0) ->
     waluee (ee_anno (ee_abs e l0 b0) l b t_dyn)
 | walueee_absa : forall e l b t1 t2 l0 b0,
     lc_eexp (ee_abs e l0 b0) ->
     waluee (ee_anno (ee_abs e l0 b0) l b (t_arrow t1 t2))
 | walueee_fanno : forall (v:eexp) (A B C D:typ) l b,
     waluee v ->
      (t_arrow C D)  =   (pprincipal_type   ( v )  )   ->
     waluee (ee_anno v l b (t_arrow A B))
 | walueee_dyn : forall (v:eexp) l b,
     Ground   (pprincipal_type  v )   ->
     waluee v ->
     waluee  ( (ee_anno v l b t_dyn) )
 | walueee_add :
     waluee ee_add
 | walueee_addl : forall (i5:i),
     waluee  ( (ee_addl i5) ) .

Inductive sstep : eexp -> rres -> Prop :=    (* defn step *)
  | sdo_step E e1 e2 :
       wwellformed E ->
       sstep e1 (ee_exp e2 ) ->
      sstep (ffill E e1) (ee_exp (ffill E e2))
  | sblame_step E e1 l b:
      wwellformed E ->
      sstep e1 (ee_blame l b) ->
      sstep (ffill E e1) (ee_blame l b)
 | sStep_beta : forall (A:typ) (e:eexp) (B:typ) (v : eexp) l1 b1 l2 b2 v' l0 b0,
    lc_eexp (ee_abs e l0 b0) ->
    evalue v ->
    TTypedReduce v l2 b2 A (ee_exp v') ->
    sstep (ee_app (ee_anno (ee_abs e l0 b0) l1 b1 (t_arrow A B)) l2 b2 v)  (ee_exp (ee_anno  (  (open_eexp_wrt_eexp  e v' )  )  l1 b1 B) )
 | sStep_betap : forall (A:typ) (e:eexp) (B:typ) v1 v2  l b l1 b1,
    evalue  ( (ee_anno v1 l b (t_arrow A B)) )  ->
    evalue v2 ->
    pprincipal_type (v1) = (t_arrow A B) ->
    TTypedReduce v2 l1 b1 A (ee_blame l1 b1) ->
    sstep (ee_app (ee_anno v1 l b (t_arrow A B)) l1 b1 v2)  (ee_blame l1 b1)
 | sStep_annov : forall (v:eexp) (A:typ) (v':rres) (l:var) b,
     evalue v ->
     TTypedReduce v l b A v' ->
     not (evalue (ee_anno v l b A)) ->
     sstep (ee_anno v l b A) v'
 | sStep_abeta : forall (v1:eexp) (A B:typ) (v2 :eexp) l1 b1 C D v2' l b l0 b0,
     evalue  ( (ee_anno v1 l0 b0 (t_arrow C D)) )  ->
     evalue v1 ->
     evalue v2 ->
     TTypedReduce v2 l b A (ee_exp v2') ->
     sstep (ee_app (ee_anno (ee_anno v1 l0 b0 (t_arrow C D)) l1 b1 (t_arrow A B)) l b v2) (ee_exp (ee_anno (ee_app (ee_anno v1 l0 b0 (t_arrow C D)) l1 (negb b1) v2' ) l1 b1 B))
 | sStep_betad : forall (v1:eexp) (v2:eexp) l1 b1 l2 b2 ,
    evalue  ( (ee_anno v1 l1 b1 t_dyn) )  ->
    lc_eexp v2 ->
    sstep (ee_app (ee_anno v1 l1 b1 t_dyn) l2 b2 v2) (ee_exp (ee_app (ee_anno (ee_anno v1 l1 b1 t_dyn) l2 b2 (t_arrow t_dyn t_dyn)) l2 b2 v2))
 | sStep_nbeta : forall (e:eexp) (v : eexp) l b v' l0 b0,
    lc_eexp (ee_abs e l0 b0) ->
    evalue v ->
    TTypedReduce v l b t_dyn (ee_exp v') ->
    sstep (ee_app (ee_abs e l0 b0) l b v)  (ee_exp (ee_anno (open_eexp_wrt_eexp  e v') l0 b0 t_dyn) ).

Hint Constructors sstep nnlam wwellformed evalue TTyping lc_eexp TTypedReduce waluee: core.