Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__5b.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__equalanglesflip.
Require Export lemma__equalangleshelper.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelflip.
Require Export lemma__parallelsymmetric.
Require Export lemma__ray4.
Require Export lemma__ray5.
Require Export lemma__samesidesymmetric.
Require Export logic.
Require Export proposition__28A.
Require Export proposition__29.
Definition proposition__30B : forall A B C D E F G H K, (euclidean__defs.Par A B E F) -> ((euclidean__defs.Par C D E F) -> ((euclidean__axioms.BetS G K H) -> ((euclidean__axioms.BetS A G B) -> ((euclidean__axioms.BetS E H F) -> ((euclidean__axioms.BetS C K D) -> ((euclidean__axioms.TS A G H F) -> ((euclidean__axioms.TS C K H F) -> (euclidean__defs.Par A B C D)))))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro G.
intro H.
intro K.
intro H0.
intro H1.
intro H2.
intro H3.
intro H4.
intro H5.
intro H6.
intro H7.
assert (* Cut *) (euclidean__axioms.neq G H) as H8.
- assert (* Cut *) ((euclidean__axioms.neq K H) /\ ((euclidean__axioms.neq G K) /\ (euclidean__axioms.neq G H))) as H8.
-- apply (@lemma__betweennotequal.lemma__betweennotequal G K H H2).
-- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
exact H12.
- assert (* Cut *) (euclidean__axioms.neq H G) as H9.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric G H H8).
-- assert (* Cut *) (euclidean__axioms.neq K H) as H10.
--- assert (* Cut *) ((euclidean__axioms.neq K H) /\ ((euclidean__axioms.neq G K) /\ (euclidean__axioms.neq G H))) as H10.
---- apply (@lemma__betweennotequal.lemma__betweennotequal G K H H2).
---- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H11.
--- assert (* Cut *) (euclidean__axioms.neq H K) as H11.
---- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric K H H10).
---- assert (* Cut *) (exists P, (euclidean__axioms.BetS H G P) /\ (euclidean__axioms.Cong G P G H)) as H12.
----- apply (@lemma__extension.lemma__extension H G G H H9 H8).
----- destruct H12 as [P H13].
destruct H13 as [H14 H15].
assert (* Cut *) (euclidean__axioms.BetS P G H) as H16.
------ apply (@euclidean__axioms.axiom__betweennesssymmetry H G P H14).
------ assert (* Cut *) (euclidean__defs.CongA A G H G H F) as H17.
------- assert (* Cut *) ((euclidean__defs.Par A B E F) -> ((euclidean__axioms.BetS A G B) -> ((euclidean__axioms.BetS E H F) -> ((euclidean__axioms.BetS P G H) -> ((euclidean__axioms.TS A G H F) -> (euclidean__defs.CongA A G H G H F)))))) as H17.
-------- intro __.
intro __0.
intro __1.
intro __2.
intro __3.
assert (* AndElim *) ((euclidean__defs.CongA A G H G H F) /\ ((euclidean__defs.CongA P G B G H F) /\ (euclidean__defs.RT B G H G H F))) as __4.
--------- apply (@proposition__29.proposition__29 A B E F P G H __ __0 __1 __2 __3).
--------- destruct __4 as [__4 __5].
exact __4.
-------- apply (@H17 H0 H3 H4 H16 H6).
------- assert (* Cut *) (euclidean__axioms.BetS P K H) as H18.
-------- apply (@lemma__3__5b.lemma__3__5b P G K H H16 H2).
-------- assert (* Cut *) (euclidean__defs.CongA C K H K H F) as H19.
--------- assert (* Cut *) (forall G0 H19, (euclidean__defs.Par C D E F) -> ((euclidean__axioms.BetS C G0 D) -> ((euclidean__axioms.BetS E H19 F) -> ((euclidean__axioms.BetS P G0 H19) -> ((euclidean__axioms.TS C G0 H19 F) -> (euclidean__defs.CongA C G0 H19 G0 H19 F)))))) as H19.
---------- intro G0.
intro H19.
intro __.
intro __0.
intro __1.
intro __2.
intro __3.
assert (* AndElim *) ((euclidean__defs.CongA C G0 H19 G0 H19 F) /\ ((euclidean__defs.CongA P G0 D G0 H19 F) /\ (euclidean__defs.RT D G0 H19 G0 H19 F))) as __4.
----------- apply (@proposition__29.proposition__29 C D E F P G0 H19 __ __0 __1 __2 __3).
----------- destruct __4 as [__4 __5].
exact __4.
---------- apply (@H19 K H H1 H5 H4 H18 H7).
--------- assert (* Cut *) (euclidean__axioms.BetS H K G) as H20.
---------- apply (@euclidean__axioms.axiom__betweennesssymmetry G K H H2).
---------- assert (* Cut *) (euclidean__defs.Out H K G) as H21.
----------- apply (@lemma__ray4.lemma__ray4 H K G).
------------right.
right.
exact H20.

------------ exact H11.
----------- assert (* Cut *) (euclidean__defs.Out H G K) as H22.
------------ apply (@lemma__ray5.lemma__ray5 H K G H21).
------------ assert (* Cut *) (F = F) as H23.
------------- apply (@logic.eq__refl Point F).
------------- assert (* Cut *) (euclidean__axioms.neq H F) as H24.
-------------- assert (* Cut *) ((euclidean__axioms.neq H F) /\ ((euclidean__axioms.neq E H) /\ (euclidean__axioms.neq E F))) as H24.
--------------- apply (@lemma__betweennotequal.lemma__betweennotequal E H F H4).
--------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H25.
-------------- assert (* Cut *) (euclidean__defs.Out H F F) as H25.
--------------- apply (@lemma__ray4.lemma__ray4 H F F).
----------------right.
left.
exact H23.

---------------- exact H24.
--------------- assert (* Cut *) (euclidean__defs.CongA A G H K H F) as H26.
---------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper A G H G H F K F H17 H22 H25).
---------------- assert (* Cut *) (euclidean__defs.CongA K H F A G H) as H27.
----------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A G H K H F H26).
----------------- assert (* Cut *) (euclidean__defs.CongA C K H A G H) as H28.
------------------ apply (@lemma__equalanglestransitive.lemma__equalanglestransitive C K H K H F A G H H19 H27).
------------------ assert (* Cut *) (euclidean__axioms.neq G H) as H29.
------------------- assert (* Cut *) ((euclidean__axioms.neq K G) /\ ((euclidean__axioms.neq H K) /\ (euclidean__axioms.neq H G))) as H29.
-------------------- apply (@lemma__betweennotequal.lemma__betweennotequal H K G H20).
-------------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H8.
------------------- assert (* Cut *) (euclidean__defs.Out G H K) as H30.
-------------------- apply (@lemma__ray4.lemma__ray4 G H K).
---------------------left.
exact H2.

--------------------- exact H29.
-------------------- assert (* Cut *) (euclidean__axioms.neq A G) as H31.
--------------------- assert (* Cut *) ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq A G) /\ (euclidean__axioms.neq A B))) as H31.
---------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A G B H3).
---------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H34.
--------------------- assert (* Cut *) (euclidean__axioms.neq G A) as H32.
---------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A G H31).
---------------------- assert (* Cut *) (A = A) as H33.
----------------------- apply (@logic.eq__refl Point A).
----------------------- assert (* Cut *) (euclidean__defs.Out G A A) as H34.
------------------------ apply (@lemma__ray4.lemma__ray4 G A A).
-------------------------right.
left.
exact H33.

------------------------- exact H32.
------------------------ assert (* Cut *) (euclidean__defs.CongA C K H A G K) as H35.
------------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper C K H A G H A K H28 H34 H30).
------------------------- assert (* Cut *) (euclidean__defs.CongA H K C K G A) as H36.
-------------------------- apply (@lemma__equalanglesflip.lemma__equalanglesflip C K H A G K H35).
-------------------------- assert (exists M, (euclidean__axioms.BetS A M F) /\ ((euclidean__axioms.Col G H M) /\ (euclidean__axioms.nCol G H A))) as H37 by exact H6.
destruct H37 as [M H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
assert (exists m, (euclidean__axioms.BetS C m F) /\ ((euclidean__axioms.Col K H m) /\ (euclidean__axioms.nCol K H C))) as H43 by exact H7.
destruct H43 as [m H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
assert (* Cut *) (euclidean__axioms.Col G K H) as H49.
--------------------------- right.
right.
right.
right.
left.
exact H2.
--------------------------- assert (* Cut *) (euclidean__axioms.Col H G K) as H50.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col K G H) /\ ((euclidean__axioms.Col K H G) /\ ((euclidean__axioms.Col H G K) /\ ((euclidean__axioms.Col G H K) /\ (euclidean__axioms.Col H K G))))) as H50.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder G K H H49).
----------------------------- destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
exact H55.
---------------------------- assert (* Cut *) (euclidean__axioms.Col H G M) as H51.
----------------------------- assert (* Cut *) ((euclidean__axioms.Col H G M) /\ ((euclidean__axioms.Col H M G) /\ ((euclidean__axioms.Col M G H) /\ ((euclidean__axioms.Col G M H) /\ (euclidean__axioms.Col M H G))))) as H51.
------------------------------ apply (@lemma__collinearorder.lemma__collinearorder G H M H41).
------------------------------ destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H52.
----------------------------- assert (* Cut *) (euclidean__axioms.neq H G) as H52.
------------------------------ assert (* Cut *) ((euclidean__axioms.neq m F) /\ ((euclidean__axioms.neq C m) /\ (euclidean__axioms.neq C F))) as H52.
------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C m F H45).
------------------------------- destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H9.
------------------------------ assert (* Cut *) (euclidean__axioms.Col G K M) as H53.
------------------------------- apply (@euclidean__tactics.not__nCol__Col G K M).
--------------------------------intro H53.
apply (@euclidean__tactics.Col__nCol__False G K M H53).
---------------------------------apply (@lemma__collinear4.lemma__collinear4 H G K M H50 H51 H52).

------------------------------- assert (* Cut *) (euclidean__axioms.Col K G M) as H54.
-------------------------------- assert (* Cut *) ((euclidean__axioms.Col K G M) /\ ((euclidean__axioms.Col K M G) /\ ((euclidean__axioms.Col M G K) /\ ((euclidean__axioms.Col G M K) /\ (euclidean__axioms.Col M K G))))) as H54.
--------------------------------- apply (@lemma__collinearorder.lemma__collinearorder G K M H53).
--------------------------------- destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
exact H55.
-------------------------------- assert (* Cut *) (euclidean__axioms.Col H K m) as H55.
--------------------------------- assert (* Cut *) ((euclidean__axioms.Col H K m) /\ ((euclidean__axioms.Col H m K) /\ ((euclidean__axioms.Col m K H) /\ ((euclidean__axioms.Col K m H) /\ (euclidean__axioms.Col m H K))))) as H55.
---------------------------------- apply (@lemma__collinearorder.lemma__collinearorder K H m H47).
---------------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H56.
--------------------------------- assert (* Cut *) (euclidean__axioms.Col H K G) as H56.
---------------------------------- assert (* Cut *) ((euclidean__axioms.Col G H K) /\ ((euclidean__axioms.Col G K H) /\ ((euclidean__axioms.Col K H G) /\ ((euclidean__axioms.Col H K G) /\ (euclidean__axioms.Col K G H))))) as H56.
----------------------------------- apply (@lemma__collinearorder.lemma__collinearorder H G K H50).
----------------------------------- destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
exact H63.
---------------------------------- assert (* Cut *) (euclidean__axioms.neq H K) as H57.
----------------------------------- assert (* Cut *) ((euclidean__axioms.neq m F) /\ ((euclidean__axioms.neq C m) /\ (euclidean__axioms.neq C F))) as H57.
------------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal C m F H45).
------------------------------------ destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
exact H11.
----------------------------------- assert (* Cut *) (euclidean__axioms.Col K m G) as H58.
------------------------------------ apply (@euclidean__tactics.not__nCol__Col K m G).
-------------------------------------intro H58.
apply (@euclidean__tactics.Col__nCol__False K m G H58).
--------------------------------------apply (@lemma__collinear4.lemma__collinear4 H K m G H55 H56 H57).

------------------------------------ assert (* Cut *) (euclidean__axioms.Col K G m) as H59.
------------------------------------- assert (* Cut *) ((euclidean__axioms.Col m K G) /\ ((euclidean__axioms.Col m G K) /\ ((euclidean__axioms.Col G K m) /\ ((euclidean__axioms.Col K G m) /\ (euclidean__axioms.Col G m K))))) as H59.
-------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder K m G H58).
-------------------------------------- destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
exact H66.
------------------------------------- assert (* Cut *) (euclidean__axioms.Col G H K) as H60.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.Col K H G) /\ ((euclidean__axioms.Col K G H) /\ ((euclidean__axioms.Col G H K) /\ ((euclidean__axioms.Col H G K) /\ (euclidean__axioms.Col G K H))))) as H60.
--------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder H K G H56).
--------------------------------------- destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
exact H65.
-------------------------------------- assert (* Cut *) (G = G) as H61.
--------------------------------------- apply (@logic.eq__refl Point G).
--------------------------------------- assert (* Cut *) (euclidean__axioms.Col G H G) as H62.
---------------------------------------- right.
left.
exact H61.
---------------------------------------- assert (* Cut *) (euclidean__axioms.neq G K) as H63.
----------------------------------------- assert (* Cut *) ((euclidean__axioms.neq K H) /\ ((euclidean__axioms.neq G K) /\ (euclidean__axioms.neq G H))) as H63.
------------------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal G K H H2).
------------------------------------------ destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
exact H66.
----------------------------------------- assert (* Cut *) (euclidean__axioms.nCol G K A) as H64.
------------------------------------------ apply (@euclidean__tactics.nCol__notCol G K A).
-------------------------------------------apply (@euclidean__tactics.nCol__not__Col G K A).
--------------------------------------------apply (@lemma__NChelper.lemma__NChelper G H A G K H42 H62 H60 H63).

------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol K G A) as H65.
------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol K G A) /\ ((euclidean__axioms.nCol K A G) /\ ((euclidean__axioms.nCol A G K) /\ ((euclidean__axioms.nCol G A K) /\ (euclidean__axioms.nCol A K G))))) as H65.
-------------------------------------------- apply (@lemma__NCorder.lemma__NCorder G K A H64).
-------------------------------------------- destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H66.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col K H G) as H66.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col H G K) /\ ((euclidean__axioms.Col H K G) /\ ((euclidean__axioms.Col K G H) /\ ((euclidean__axioms.Col G K H) /\ (euclidean__axioms.Col K H G))))) as H66.
--------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder G H K H60).
--------------------------------------------- destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H74.
-------------------------------------------- assert (* Cut *) (K = K) as H67.
--------------------------------------------- apply (@logic.eq__refl Point K).
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col K H K) as H68.
---------------------------------------------- right.
left.
exact H67.
---------------------------------------------- assert (* Cut *) (euclidean__axioms.neq G K) as H69.
----------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq m F) /\ ((euclidean__axioms.neq C m) /\ (euclidean__axioms.neq C F))) as H69.
------------------------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal C m F H45).
------------------------------------------------ destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H63.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.neq K G) as H70.
------------------------------------------------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric G K H69).
------------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol K G C) as H71.
------------------------------------------------- apply (@euclidean__tactics.nCol__notCol K G C).
--------------------------------------------------apply (@euclidean__tactics.nCol__not__Col K G C).
---------------------------------------------------apply (@lemma__NChelper.lemma__NChelper K H C K G H48 H68 H66 H70).

------------------------------------------------- assert (* Cut *) (euclidean__defs.OS A C K G) as H72.
-------------------------------------------------- exists F.
exists M.
exists m.
split.
--------------------------------------------------- exact H54.
--------------------------------------------------- split.
---------------------------------------------------- exact H59.
---------------------------------------------------- split.
----------------------------------------------------- exact H39.
----------------------------------------------------- split.
------------------------------------------------------ exact H45.
------------------------------------------------------ split.
------------------------------------------------------- exact H65.
------------------------------------------------------- exact H71.
-------------------------------------------------- assert (* Cut *) (euclidean__defs.OS C A K G) as H73.
--------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS C A K G) /\ ((euclidean__defs.OS A C G K) /\ (euclidean__defs.OS C A G K))) as H73.
---------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric K G A C H72).
---------------------------------------------------- destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
exact H74.
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS D K C) as H74.
---------------------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry C K D H5).
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS B G A) as H75.
----------------------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry A G B H3).
----------------------------------------------------- assert (* Cut *) (euclidean__defs.Par D C B A) as H76.
------------------------------------------------------ apply (@proposition__28A.proposition__28A D C B A H K G H74 H75 H20 H36 H73).
------------------------------------------------------ assert (* Cut *) (euclidean__defs.Par C D A B) as H77.
------------------------------------------------------- assert (* Cut *) ((euclidean__defs.Par C D B A) /\ ((euclidean__defs.Par D C A B) /\ (euclidean__defs.Par C D A B))) as H77.
-------------------------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip D C B A H76).
-------------------------------------------------------- destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
exact H81.
------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par A B C D) as H78.
-------------------------------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric C D A B H77).
-------------------------------------------------------- exact H78.
Qed.


Require Import VST.progs64.io_mem.
Require Import VST.progs64.io_mem_specs.
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.

Local Open Scope itree_scope.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition putchars_spec := DECLARE _putchars putchars_spec.
Definition getchars_spec := DECLARE _getchars getchars_spec.

Lemma div_10_dec : forall n, 0 < n ->
  (Z.to_nat (n / 10) < Z.to_nat n)%nat.
Proof.
  intros.
  change 10 with (Z.of_nat 10).
  rewrite <- (Z2Nat.id n) by lia.
  rewrite <- Nat2Z.inj_div by discriminate.
  rewrite !Nat2Z.id.
  apply Nat2Z.inj_lt.
  rewrite Nat2Z.inj_div, Z2Nat.id by lia; simpl.
  apply Z.div_lt; auto; lia.
Qed.

Program Fixpoint chars_of_Z (n : Z) { measure (Z.to_nat n) } : list byte :=
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Next Obligation.
Proof.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous.
  eapply Z.lt_le_trans, Z_mult_div_ge with (b := 10); lia.
Defined.

(* The function computed by print_intr *)
Program Fixpoint intr n { measure (Z.to_nat n) } : list byte :=
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous; lia.
Defined.

Definition replace_list {X} i (l : list X) (l' : list X) :=
  sublist 0 i l ++ l' ++ sublist (i + Zlength l') (Zlength l) l.

Definition print_intr_spec :=
 DECLARE _print_intr
  WITH sh : share, i : Z, buf : val, contents : list val
  PRE [ tuint, tptr tuchar ]
    PROP (writable_share sh; 0 <= i <= Int.max_unsigned; Zlength (intr i) <= Zlength contents <= Int.max_signed)
    PARAMS (Vint (Int.repr i); buf)
    GLOBALS ()
    SEP (data_at sh (tarray tuchar (Zlength contents)) contents buf)
  POST [ tint ]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (Zlength (intr i)))))
    SEP (data_at sh (tarray tuchar (Zlength contents)) (replace_list 0 contents (map Vubyte (intr i))) buf).

Definition print_int_spec :=
 DECLARE _print_int
  WITH gv : globals, i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i < 10000)
    PARAMS (Vint (Int.repr i))
    GLOBALS (gv)
    SEP (mem_mgr gv; ITREE (write_list stdout (chars_of_Z i ++ [Byte.repr newline]) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv; ITREE tr).

Definition for_loop {file_id} i z (body : Z -> itree (@IO_event file_id) bool) :=
  ITree.iter (fun '(b, j) => if (b : bool) then Ret (inr true) else if j <? z then b <- body j ;; Ret (inl (b, j + 1)) else Ret (inr false)) (false, i).

Definition sum_Z l := fold_right Z.add 0 l.

Definition read_sum_inner n nums j :=
  if orb (10 <=? Znth j nums) (Znth j nums <? 0) then Ret true
  else write_list stdout (chars_of_Z (n + sum_Z (sublist 0 (j + 1) nums)) ++ [Byte.repr newline]);; Ret false.

Definition read_sum n lc : IO_itree :=
  ITree.iter (fun '(b, n, lc) => if (b : bool) then Ret (inr tt) else
  if zlt n 1000 then
    let nums := map (fun c => Byte.unsigned c - char0) lc in
    b <- for_loop 0 4 (read_sum_inner n nums) ;; if (b : bool) then Ret (inl (true, n, lc)) else
    lc' <- read_list stdin 4;; Ret (inl (false, n + sum_Z nums, lc'))
  else Ret (inr tt)) (false, n, lc).

Definition main_itree := lc <- read_list stdin 4;; read_sum 0 lc.

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog main_itree gv
  POST [ tint ] PROP () LOCAL () SEP (mem_mgr gv; ITREE (Ret tt : @IO_itree (@IO_event nat))).

Definition Gprog : funspecs := ltac:(with_library prog [putchars_spec; getchars_spec;
  print_intr_spec; print_int_spec; main_spec]).

Lemma divu_repr : forall x y,
  0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
  Int.divu (Int.repr x) (Int.repr y) = Int.repr (x / y).
Proof.
  intros; unfold Int.divu.
  rewrite !Int.unsigned_repr; auto.
Qed.

(*Opaque bind.

Opaque Nat.div Nat.modulo.*)

Lemma intr_eq : forall n, intr n =
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Proof.
  intros.
  unfold intr at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold intr.
  destruct n; reflexivity.
Qed.

(* missing from standard library *)
Lemma Zdiv_le_compat_r : forall m n p, p > 0 -> m <= n -> m / p <= n / p.
Proof.
  intros; unfold Z.div.
  pose proof (Z_div_mod m _ H) as Hm.
  pose proof (Z_div_mod n _ H) as Hn.
  destruct (Z.div_eucl m p), (Z.div_eucl n p).
  destruct Hm, Hn; subst.
  destruct (zle z z1); auto.
  assert (p * z1 + p <= p * z); try lia.
  rewrite <- Z.mul_succ_r.
  apply Zmult_le_compat_l; lia.
Qed.

Lemma intr_lt : forall n, 0 < n -> Zlength (intr (n / 10)) = Zlength (intr n) - 1.
Proof.
  intros.
  rewrite (intr_eq n).
  destruct (n <=? 0) eqn: Hn.
  { apply Zle_bool_imp_le in Hn; lia. }
  rewrite Zlength_app, Zlength_cons, Zlength_nil; lia.
Qed.

Lemma replace_list_nil : forall {X} i (l : list X), 0 <= i <= Zlength l -> replace_list i l [] = l.
Proof.
  intros; unfold replace_list.
  rewrite Zlength_nil, Z.add_0_r; simpl.
  rewrite sublist_rejoin, sublist_same by lia; auto.
Qed.

Lemma replace_list_upd_snoc : forall {X} i (l l' : list X) x, 0 <= i -> i + Zlength l' < Zlength l ->
  upd_Znth (i + Zlength l') (replace_list i l l') x = replace_list i l (l' ++ [x]).
Proof.
  intros; unfold replace_list.
  rewrite upd_Znth_app2; rewrite ?Zlength_sublist; try rep_lia.
  f_equal.
  rewrite Z.sub_0_r, Z.add_simpl_l, upd_Znth_app2; rewrite ?Zlength_sublist; try rep_lia.
  rewrite Zminus_diag, Zlength_app, Zlength_cons, Zlength_nil, upd_Znth0_old, <- app_assoc; simpl; f_equal; f_equal.
  rewrite Zlength_sublist by rep_lia.
  rewrite sublist_sublist by rep_lia.
  f_equal; lia.
  { rewrite Zlength_sublist; rep_lia. }
  { rewrite Zlength_app, Zlength_sublist; rep_lia. }
Qed.

Lemma body_print_intr: semax_body Vprog Gprog f_print_intr print_intr_spec.
Proof.
  start_function.
  forward.
  forward_if (PROP ()
    LOCAL (temp _k (Vint (Int.repr (Zlength (intr i) - 1))))
    SEP (data_at sh (tarray tuchar (Zlength contents)) (replace_list 0 contents (map Vubyte (intr i))) buf)).
  - forward.
    rewrite divu_repr by rep_lia.
    forward.
    forward_call (sh, i / 10, buf, contents).
    { rewrite intr_lt by lia; split; auto; try lia.
      assert (i / 10 < i).
      { apply Z.div_lt; lia. }
       split.
      apply Z.div_pos; lia.
      rep_lia.
    }
    rewrite modu_repr by (lia || computable).
    assert (repable_signed (Zlength (intr (i / 10)))).
    { split; try rep_lia.
      rewrite intr_lt; try lia. }
    forward.
    { entailer!.
      split; try rep_lia.
      rewrite intr_lt; try lia. }
    entailer!.
    { rewrite intr_lt by lia; auto. }
    rewrite (intr_eq i).
    destruct (i <=? 0) eqn: Hi; [apply Zle_bool_imp_le in Hi; lia|].
    pose proof (Z_mod_lt i 10).
    rewrite <- (Zlength_map _ _ Vubyte), <- (Z.add_0_l (Zlength (map _ _))), replace_list_upd_snoc.
    rewrite (zero_ext_inrange 8 (Int.repr (i mod 10))), add_repr.
    rewrite zero_ext_inrange, map_app.
    unfold Vubyte at 3; simpl.
    rewrite Byte.unsigned_repr by (unfold char0; rep_lia); apply derives_refl.
    { rewrite Int.unsigned_repr; simpl; rep_lia. }
    { rewrite Int.unsigned_repr; simpl; rep_lia. }
    { lia. }
    { rewrite Zlength_map, intr_lt; rep_lia. }
  - forward.
    entailer!.
    rewrite replace_list_nil by rep_lia; auto.
  - forward.
    rewrite Z.sub_simpl_r; entailer!.
Qed.

Lemma chars_of_Z_eq : forall n, chars_of_Z n =
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Proof.
  intros.
  unfold chars_of_Z at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold chars_of_Z.
  destruct (_ <=? _); reflexivity.
Qed.

Lemma chars_of_Z_intr : forall n,
  chars_of_Z n = if n <=? 0 then [Byte.repr (n + char0)] else intr n.
Proof.
  intros.
  destruct (Z.leb_spec n 0).
  { rewrite chars_of_Z_eq; simpl.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
    apply Zdiv_le_compat_r with (p := 10) in H; try lia.
    rewrite Zdiv_0_l in H.
    destruct (Z.leb_spec (n / 10) 0); auto; lia. }
  induction n as [? IH] using (well_founded_induction (Zwf.Zwf_well_founded 0)).
  rewrite chars_of_Z_eq, intr_eq.
  destruct (n <=? 0) eqn: Hn; [apply Zle_bool_imp_le in Hn; lia|].
  simpl.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  destruct (n / 10 <=? 0) eqn: Hdiv.
  - apply Zle_bool_imp_le in Hdiv.
    assert (0 <= n / 10).
    { apply Z.div_pos; lia. }
    assert (n / 10 = 0) as Hz by lia.
    rewrite Hz; simpl.
    apply Z.div_small_iff in Hz as [|]; try lia.
    rewrite Zmod_small; auto.
  - apply Z.leb_nle in Hdiv.
    rewrite IH; auto; try lia.
    split; try lia.
    apply Z.div_lt; auto; lia.
Qed.

Lemma intr_length : forall n a, 0 <= a -> n < Z.pow 10 a -> Zlength (intr n) <= a.
Proof.
  induction n using (well_founded_induction (Zwf.Zwf_well_founded 0)); intros.
  rewrite intr_eq.
  destruct (Z.leb_spec n 0); [rewrite Zlength_nil; lia|].
  rewrite Zlength_app.
  assert (Zlength (intr (n / 10)) <= a - 1); [|rewrite Zlength_cons, Zlength_nil; lia].
  assert (0 <= a - 1).
  { destruct (Z.eq_dec a 0); subst; simpl in *; lia. }
  apply H; auto.
  - split; try lia.
    apply Z.div_lt; auto; lia.
  - apply Zmult_lt_reg_r with 10; try lia.
    rewrite (Z.mul_comm (10 ^ _)), <- Z.pow_succ_r by auto.
    unfold Z.succ; rewrite Z.sub_simpl_r.
    eapply Z.le_lt_trans; eauto.
    rewrite Z.mul_comm; apply Z.mul_div_le; lia.
Qed.

Lemma chars_of_Z_length : forall n a, 0 < a -> n < Z.pow 10 a -> Zlength (chars_of_Z n) <= a.
Proof.
  intros.
  rewrite chars_of_Z_intr.
  destruct (Z.leb_spec n 0); [|apply intr_length; lia].
  rewrite Zlength_cons, Zlength_nil; lia.
Qed.

Lemma body_print_int: semax_body Vprog Gprog f_print_int print_int_spec.
Proof.
  start_function.
  forward_call (tarray tuchar 5, gv).
  { split; auto; simpl; computable. }
  Intro buf.
  forward_if (buf <> nullval).
  { if_tac; entailer!. }
  { forward_call 1; contradiction. }
  { forward.
    entailer!. }
  Intros; rewrite if_false by auto.
  forward_if (PROP ()
    LOCAL (temp _buf buf; gvars gv; temp _i (Vint (Int.repr i));
                 temp _k (Vint (Int.repr (Zlength (chars_of_Z i ++ [Byte.repr newline])))))
    SEP (mem_mgr gv; malloc_token Ews (tarray tuchar 5) buf;
            data_at Ews (tarray tuchar 5) (map Vubyte (chars_of_Z i) ++ Vubyte (Byte.repr newline) ::
              repeat Vundef (Z.to_nat (4 - Zlength (chars_of_Z i)))) buf;
            ITREE (write_list stdout (chars_of_Z i ++ [Byte.repr newline]);; tr))).
  - Intros.
    forward.
    forward.
    forward.
    entailer!.
  - Intros.
    sep_apply data_at__data_at.
    unfold default_val; simpl.
    assert (Zlength (intr i) <= 4).
    { apply intr_length; try lia. }
    forward_call (Ews, i, buf, [Vundef; Vundef; Vundef; Vundef; Vundef]).
    { rewrite !Zlength_cons, Zlength_nil.
      simpl; repeat (split; auto); rep_lia. }
    forward.
    { entailer!.
      rewrite !Zlength_cons, Zlength_nil; rep_lia. }
    forward.
    entailer!.
    { rewrite Zlength_app, Zlength_cons, Zlength_nil, chars_of_Z_intr.
      destruct (Z.leb_spec i 0); auto; lia. }
    unfold replace_list; simpl.
    rewrite (sublist_repeat _ _ 5 Vundef).
    rewrite !Zlength_cons, Zlength_nil, Zlength_map; simpl.
    rewrite upd_Znth_app2.
    rewrite Zlength_map, Zminus_diag, upd_Znth0_old, sublist_repeat; try lia.
    apply derives_refl'.
    f_equal.
    rewrite chars_of_Z_intr.
    destruct (Z.leb_spec i 0); try lia.
    rewrite zero_ext_inrange.
    f_equal; f_equal; f_equal; f_equal.
    rewrite Zlength_repeat; try lia.
    { simpl; rewrite Int.unsigned_repr; rep_lia. }
    { rewrite Zlength_repeat; lia. }
    { rewrite Zlength_repeat; lia. }
    { rewrite Zlength_map, Zlength_repeat; lia. }
    { rewrite Zlength_map; rep_lia. }
    { rewrite !Zlength_cons, Zlength_nil, Zlength_map; lia. }
  - forward_call (Ews, buf, chars_of_Z i ++ [Byte.repr newline],
      5, repeat Vundef (Z.to_nat (4 - Zlength (chars_of_Z i))), tr).
    { rewrite map_app, <- app_assoc; simpl; cancel. }
    forward_call (tarray tuchar 5, buf, gv).
    { rewrite if_false by auto; cancel. }
    forward.
Qed.

Lemma read_sum_eq : forall n lc, read_sum n lc ≈
  if zlt n 1000 then
    let nums := map (fun c => Byte.unsigned c - char0) lc in
    b <- for_loop 0 4 (read_sum_inner n nums) ;; if (b : bool) then Ret tt else
    lc' <- read_list stdin 4;; read_sum (n + sum_Z nums) lc'
  else Ret tt.
Proof.
  intros.
  unfold read_sum.
  rewrite unfold_iter.
  if_tac; [|rewrite bind_ret_l; reflexivity].
  rewrite bind_bind.
  apply eqit_bind; [reflexivity|].
  intros [].
  - rewrite bind_ret_l, tau_eutt.
    rewrite unfold_iter.
    rewrite bind_ret_l; reflexivity.
  - rewrite bind_bind.
    apply eqit_bind; [reflexivity|].
    intro.
    rewrite bind_ret_l, tau_eutt; reflexivity.
Qed.

Lemma for_loop_eq : forall {file_id} i z body,
  @for_loop file_id i z body ≈ if i <? z then b <- body i ;; if (b : bool) then Ret true else for_loop (i + 1) z body else Ret false.
Proof.
  intros.
  unfold for_loop.
  rewrite unfold_iter.
  simple_if_tac; [|rewrite bind_ret_l; reflexivity].
  rewrite bind_bind.
  apply eqit_bind; [reflexivity|].
  intros [].
  - rewrite bind_ret_l, tau_eutt, unfold_iter.
    rewrite bind_ret_l; reflexivity.
  - rewrite bind_ret_l, tau_eutt; reflexivity.
Qed.

Lemma sum_Z_app : forall l1 l2, sum_Z (l1 ++ l2) = sum_Z l1 + sum_Z l2.
Proof.
  induction l1; auto; simpl; intros.
  rewrite IHl1; lia.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  sep_apply (has_ext_ITREE(E := @IO_event nat)).
  rewrite <- (emp_sepcon (ITREE _)); Intros.
  replace_SEP 0 (mem_mgr gv) by (go_lower; apply create_mem_mgr).
  forward.
  forward_call (tarray tuchar 4, gv).
  { simpl; repeat (split; auto); rep_lia. }
  Intro buf.
  forward_if (buf <> nullval).
  { if_tac; entailer!. }
  { forward_call 1; contradiction. }
  { forward.
    entailer!. }
  Intros; rewrite if_false by auto.
  unfold main_itree.
  forward_call (Ews, buf, 4, fun lc => read_sum 0 lc).
  { simpl; cancel. }
  Intros lc.
  set (Inv := EX n : Z, EX lc : list byte,
    PROP (0 <= n < 1040)
    LOCAL (temp _i (Vint (Int.repr 4)); temp _buf buf; temp _n (Vint (Int.repr n)); gvars gv)
    SEP (ITREE (read_sum n lc); data_at Ews (tarray tuchar 4) (map Vubyte lc) buf;
      mem_mgr gv; malloc_token Ews (tarray tuchar 4) buf)).
  forward_while Inv.
  { Exists 0 lc; entailer!. }
  { entailer!. }
  - clear dependent lc; rename lc0 into lc.
    rewrite read_sum_eq.
    rewrite if_true by auto; simpl ITREE.
    set (nums := map (fun i => Byte.unsigned i - char0) lc).
    assert_PROP (Zlength lc = 4).
    { entailer!.
      rewrite Zlength_map in *; auto. }
    assert (Zlength nums = 4) by (subst nums; rewrite Zlength_map; auto).
    forward_for_simple_bound 4 (EX j : Z, PROP (0 <= n + sum_Z (sublist 0 j nums) < 1000 + 10 * j)
     LOCAL (temp _i (Vint (Int.repr 4)); temp _buf buf; temp _n (Vint (Int.repr (n + sum_Z (sublist 0 j nums)))); gvars gv)
     SEP (ITREE (b <- for_loop j 4
         (read_sum_inner n nums) ;; if (b : bool) then Ret tt else lc' <- read_list stdin 4 ;; read_sum (n + sum_Z nums) lc');
             data_at Ews (tarray tuchar 4) (map Vubyte lc) buf; mem_mgr gv; malloc_token Ews (tarray tuchar 4) buf)).
    + entailer!.
      { lia. }
    + simpl.
      forward.
      { entailer!.
        unfold Vubyte; simpl.
        rewrite Int.unsigned_repr; rep_lia. }
      forward.
      rewrite Znth_map by lia; simpl.
      rewrite zero_ext_inrange.
      forward.
      unfold Int.sub.
      rewrite !Int.unsigned_repr by rep_lia.
      forward_if (0 <= Byte.unsigned (Znth i lc) - char0 < 10).
      { forward_call (tarray tuchar 4, buf, gv).
        { rewrite if_false by auto; cancel. }
        forward.
        entailer!.
        rewrite for_loop_eq.
        destruct (Z.ltb_spec i 4); try lia.
        unfold read_sum_inner at 1.
        replace (_ || _)%bool with true.
        rewrite !bind_ret_l; auto.
        { symmetry; rewrite orb_true_iff.
          subst nums; rewrite Znth_map by lia.
          destruct (Z.ltb_spec (Byte.unsigned (Znth i lc) - char0) 0); auto.
          rewrite Int.unsigned_repr in * by (unfold char0 in *; rep_lia).
          left; apply Z.leb_le; unfold char0 in *; lia. } }
      { forward.
        entailer!.
        rewrite Int.unsigned_repr_eq in *.
        destruct (zlt (Byte.unsigned (Znth i lc)) char0).
        { unfold char0 in *; rewrite <- Z_mod_plus_full with (b := 1), Zmod_small in *; rep_lia. }
        unfold char0 in *; rewrite Zmod_small in *; rep_lia. }
      forward.
      rewrite add_repr.
      rewrite for_loop_eq.
      destruct (Z.ltb_spec i 4); try lia.
      unfold read_sum_inner at 1.
      unfold nums; rewrite Znth_map by lia.
      assert (((10 <=? Byte.unsigned (Znth i lc) - char0) || (Byte.unsigned (Znth i lc) - char0 <? 0))%bool = false) as Hin.
      { rewrite orb_false_iff.
        split; [apply Z.leb_nle | apply Z.ltb_nlt]; lia. }
      rewrite Hin.
      assert (sublist 0 (i + 1) nums = sublist 0 i nums ++ [Byte.unsigned (Znth i lc) - char0]) as Hi.
      { rewrite (sublist_split _ i (i + 1)), (sublist_one i (i + 1)) by lia.
        f_equal; subst nums.
        rewrite Znth_map by lia; auto. }
      forward_call (gv, n + sum_Z (sublist 0 (i + 1) nums),
        b <- for_loop (i + 1) 4 (read_sum_inner n nums) ;; if (b : bool) then Ret tt else lc' <- read_list stdin 4 ;; read_sum (n + sum_Z nums) lc').
      { entailer!.
        rewrite Hi, sum_Z_app; simpl.
        rewrite Z.add_assoc, Z.add_0_r; auto. }
      { rewrite sepcon_assoc; apply sepcon_derives; cancel.
        rewrite !bind_bind.
        apply ITREE_impl.
        apply eqit_bind; [reflexivity|].
        intros [].
        rewrite bind_ret_l; reflexivity. }
      { rewrite Hi, sum_Z_app; simpl; lia. }
      entailer!.
      { rewrite Hi, sum_Z_app; simpl.
        rewrite Z.add_0_r, Z.add_assoc; split; auto; lia. }
      { rewrite Int.unsigned_repr by rep_lia.
        pose proof (Byte.unsigned_range (Znth i lc)) as [_ Hmax].
        unfold Byte.modulus, two_power_nat in Hmax; simpl in *; lia. }
    + rewrite for_loop_eq.
      destruct (Z.ltb_spec 4 4); try lia.
      forward_call (Ews, buf, 4, fun lc' => read_sum (n + sum_Z nums) lc').
      { rewrite sepcon_assoc; apply sepcon_derives; cancel.
        simpl; rewrite bind_ret_l; auto. }
      Intros lc'.
      forward.
      rewrite sublist_same in * by auto.
      Exists (n + sum_Z nums, lc'); entailer!.
      apply derives_refl.
  - subst Inv.
    forward_call (tarray tuchar 4, buf, gv).
    { rewrite if_false by auto; cancel. }
    forward.
    cancel.
    rewrite read_sum_eq.
    rewrite if_false; [auto | lia].
Qed.

Definition ext_link := ext_link_prog prog.

#[export] Instance Espec : OracleKind := IO_Espec ext_link.

Lemma prog_correct:
  semax_prog prog main_itree Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_exit.
semax_func_cons body_free.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
semax_func_cons_ext.
{ simpl; Intro msg.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons_ext.
semax_func_cons body_print_intr.
semax_func_cons body_print_int.
semax_func_cons body_main.
Qed.

Require Import VST.veric.SequentialClight.
Require Import VST.progs64.io_mem_dry.

Definition init_mem_exists : { m | Genv.init_mem prog = Some m }.
Proof.
  unfold Genv.init_mem; simpl.
Ltac alloc_block m n := match n with
  | O => idtac
  | S ?n' => let m' := fresh "m" in let Hm' := fresh "Hm" in
    destruct (dry_mem_lemmas.drop_alloc m) as [m' Hm']; alloc_block m' n'
  end.
try first [
  (* This version works in Coq 8.15, CompCert 3.10 *)
  alloc_block Mem.empty 63%nat;
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end;
  reflexivity
 |
  (* This version worked in Coq 8.13, CompCert 3.9 *)
  alloc_block Mem.empty 61%nat;
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end;
  reflexivity
].
Qed.

Definition init_mem := proj1_sig init_mem_exists.

Definition main_block_exists : {b | Genv.find_symbol (Genv.globalenv prog) (AST.prog_main prog) = Some b}.
Proof.
  eexists; simpl.
  unfold Genv.find_symbol; simpl; reflexivity.
Qed.

Definition main_block := proj1_sig main_block_exists.

Axiom (Jsub: forall ef se lv m t v m' (EFI : ef_inline ef = true) m1
       (EFC : Events.external_call ef se lv m t v m'), juicy_mem.mem_sub m m1 ->
       exists m1' (EFC1 : Events.external_call ef se lv m1 t v m1'),
         juicy_mem.mem_sub m' m1' /\ proj1_sig (Clight_core.inline_external_call_mem_events _ _ _ _ _ _ _ EFI EFC1) =
         proj1_sig (Clight_core.inline_external_call_mem_events _ _ _ _ _ _ _ EFI EFC)).

Theorem prog_toplevel : exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
  forall n, @step_lemmas.dry_safeN _ _ _ _ semax.genv_symb_injective (Clight_core.cl_core_sem (globalenv prog))
             (io_dry_spec ext_link) {| genv_genv := Genv.globalenv prog; genv_cenv := prog_comp_env prog |} n
            main_itree q init_mem.
Proof.
  edestruct whole_program_sequential_safety_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - repeat intro; simpl. apply I.
  - apply Jsub.
  - apply add_funspecs_frame.
  - apply juicy_dry_specs.
  - apply dry_spec_mem.
  - intros; apply I.
  - apply CSHL_Sound.semax_prog_sound, prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    auto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XRanalysis1.
Require Import XRtopology.
Local Open Scope XR_scope.

(* The Mean Value Theorem *)
Theorem MVT :
  forall (f g:R -> R) (a b:R) (pr1:forall c:R, a < c < b -> derivable_pt f c)
    (pr2:forall c:R, a < c < b -> derivable_pt g c),
    a < b ->
    (forall c:R, a <= c <= b -> continuity_pt f c) ->
    (forall c:R, a <= c <= b -> continuity_pt g c) ->
    exists c : R,
      (exists P : a < c < b,
        (g b - g a) * derive_pt f c (pr1 c P) =
        (f b - f a) * derive_pt g c (pr2 c P)).
Proof.
  intros; assert (H2 := Rlt_le _ _ H).
  set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y).
  cut (forall c:R, a < c < b -> derivable_pt h c).
  intro X; cut (forall c:R, a <= c <= b -> continuity_pt h c).
  intro; assert (H4 := continuity_ab_maj h a b H2 H3).
  assert (H5 := continuity_ab_min h a b H2 H3).
  elim H4; intros Mx H6.
  elim H5; intros mx H7.
  cut (h a = h b).
  intro; set (M := h Mx); set (m := h mx).
  cut
    (forall (c:R) (P:a < c < b),
      derive_pt h c (X c P) =
      (g b - g a) * derive_pt f c (pr1 c P) -
      (f b - f a) * derive_pt g c (pr2 c P)).
  intro; case (Req_dec (h a) M); intro.
  case (Req_dec (h a) m); intro.
  cut (forall c:R, a <= c <= b -> h c = M).
  intro; cut (a < (a + b) / R2 < b).
(*** h constant ***)
  intro; exists ((a + b) / R2).
  exists H13.
  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_constant2 with a b.
  elim H13; intros; assumption.
  elim H13; intros; assumption.
  intros; rewrite (H12 ((a + b) / R2)).
  apply H12; split; left; assumption.
  elim H13; intros; split; left; assumption.
  split.
  apply Rmult_lt_reg_l with R2.
  exact Rlt_0_2.
  unfold Rdiv; rewrite <- (Rmult_comm (/ R2)); rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H.
  exact Neq_2_0.
  apply Rmult_lt_reg_l with R2.
  exact Rlt_0_2.
  unfold Rdiv; rewrite <- (Rmult_comm (/ R2)); rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite Rplus_comm; rewrite double;
    apply Rplus_lt_compat_l; apply H.
  exact Neq_2_0.
  intros; elim H6; intros H13 _.
  elim H7; intros H14 _.
  apply Rle_antisym.
  apply H13; apply H12.
  rewrite H10 in H11; rewrite H11; apply H14; apply H12.
  cut (a < mx < b).
(*** h admet un minimum global sur [a,b] ***)
  intro; exists mx.
  exists H12.
  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_minimum with a b.
  elim H12; intros; assumption.
  elim H12; intros; assumption.
  intros; elim H7; intros.
  apply H15; split; left; assumption.
  elim H7; intros _ H12; elim H12; intros; split.
  inversion H13.
  apply H15.
  rewrite H15 in H11; elim H11; reflexivity.
  inversion H14.
  apply H15.
  rewrite H8 in H11; rewrite <- H15 in H11; elim H11; reflexivity.
  cut (a < Mx < b).
(*** h admet un maximum global sur [a,b] ***)
  intro; exists Mx.
  exists H11.
  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_maximum with a b.
  elim H11; intros; assumption.
  elim H11; intros; assumption.
  intros; elim H6; intros; apply H14.
  split; left; assumption.
  elim H6; intros _ H11; elim H11; intros; split.
  inversion H12.
  apply H14.
  rewrite H14 in H10; elim H10; reflexivity.
  inversion H13.
  apply H14.
  rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity.
  intros; unfold h;
    replace
    (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P))
    with
      (derive_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) c
        (derivable_pt_minus _ _ _
          (derivable_pt_mult _ _ _ (derivable_pt_const (g b - g a) c) (pr1 c P))
          (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P))));
      [ idtac | apply pr_nu ].
  rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
    do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l;
      do 2 rewrite Rplus_0_l; reflexivity.
  unfold h.
{
  unfold Rminus.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite Ropp_plus_distr.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_involutive.
  symmetry.
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_comm.
  repeat rewrite Rplus_assoc.
  rewrite Rmult_comm.
  apply Rplus_eq_compat_l.
  rewrite Rmult_comm.
  rewrite Rplus_comm.
  rewrite Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_r.
  symmetry.
  rewrite Rplus_comm.
  rewrite Rplus_assoc.
  rewrite (Rmult_comm (f a)).
  rewrite Rplus_opp_r, Rplus_0_r.
  rewrite Rmult_comm.
  reflexivity.
}
  intros; unfold h;
    change
      (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
        c).
  apply continuity_pt_minus; apply continuity_pt_mult.
  apply derivable_continuous_pt; apply derivable_const.
  apply H0; apply H3.
  apply derivable_continuous_pt; apply derivable_const.
  apply H1; apply H3.
  intros;
    change
      (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
        c).
  apply derivable_pt_minus; apply derivable_pt_mult.
  apply derivable_pt_const.
  apply (pr1 _ H3).
  apply derivable_pt_const.
  apply (pr2 _ H3).
Qed.

(* Corollaries ... *)
Lemma MVT_cor1 :
  forall (f:R -> R) (a b:R) (pr:derivable f),
    a < b ->
    exists c : R, f b - f a = derive_pt f c (pr c) * (b - a) /\ a < c < b.
Proof.
  intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c);
    [ intro X | intros; apply pr ].
  cut (forall c:R, a < c < b -> derivable_pt id c);
    [ intro X0 | intros; apply derivable_pt_id ].
  cut (forall c:R, a <= c <= b -> continuity_pt f c);
    [ intro | intros; apply derivable_continuous_pt; apply pr ].
  cut (forall c:R, a <= c <= b -> continuity_pt id c);
    [ intro | intros; apply derivable_continuous_pt; apply derivable_id ].
  assert (H2 := MVT f id a b X X0 H H0 H1).
  destruct H2 as (c & P & H4).
  exists c; split.
  cut (derive_pt id c (X0 c P) = derive_pt id c (derivable_pt_id c));
    [ intro H5 | apply pr_nu ].
  rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4;
    rewrite <- H4; replace (derive_pt f c (X c P)) with (derive_pt f c (pr c));
      [ idtac | apply pr_nu ]; apply Rmult_comm.
  apply P.
Qed.

Theorem MVT_cor2 :
  forall (f f':R -> R) (a b:R),
    a < b ->
    (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
    exists c : R, f b - f a = f' c * (b - a) /\ a < c < b.
Proof.
  intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c).
  intro X; cut (forall c:R, a < c < b -> derivable_pt f c).
  intro X0; cut (forall c:R, a <= c <= b -> continuity_pt f c).
  intro; cut (forall c:R, a <= c <= b -> derivable_pt id c).
  intro X1; cut (forall c:R, a < c < b -> derivable_pt id c).
  intro X2; cut (forall c:R, a <= c <= b -> continuity_pt id c).
  intro; elim (MVT f id a b X0 X2 H H1 H2); intros x (P,H3).
  exists x; split.
  cut (derive_pt id x (X2 x P) = R1).
  cut (derive_pt f x (X0 x P) = f' x).
  intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry ;
      assumption.
  apply derive_pt_eq_0; apply H0; elim P; intros; split; left; assumption.
  apply derive_pt_eq_0; apply derivable_pt_lim_id.
  assumption.
  intros; apply derivable_continuous_pt; apply X1; assumption.
  intros; apply derivable_pt_id.
  intros; apply derivable_pt_id.
  intros; apply derivable_continuous_pt; apply X; assumption.
  intros; elim H1; intros; apply X; split; left; assumption.
  intros; unfold derivable_pt; exists (f' c); apply H0;
    apply H1.
Qed.

Lemma MVT_cor3 :
  forall (f f':R -> R) (a b:R),
    a < b ->
    (forall x:R, a <= x -> x <= b -> derivable_pt_lim f x (f' x)) ->
    exists c : R, a <= c /\ c <= b /\ f b = f a + f' c * (b - a).
Proof.
  intros f f' a b H H0;
    assert (H1 :  exists c : R, f b - f a = f' c * (b - a) /\ a < c < b);
      [ apply MVT_cor2; [ apply H | intros; elim H1; intros; apply (H0 _ H2 H3) ]
        | elim H1; intros; exists x; elim H2; intros; elim H4; intros; split;
          [ left; assumption | split; [ left; assumption | rewrite <- H3 ] ] ].
unfold Rminus.
rewrite Rplus_comm.
rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
reflexivity.
Qed.

Lemma Rolle :
  forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
    (forall x:R, a <= x <= b -> continuity_pt f x) ->
    a < b ->
    f a = f b ->
    exists c : R, (exists P : a < c < b, derive_pt f c (pr c P) = R0).
Proof.
  intros; assert (H2 : forall x:R, a < x < b -> derivable_pt id x).
  intros; apply derivable_pt_id.
  assert (H3 := MVT f id a b pr H2 H0 H);
    assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x).
  intros; apply derivable_continuous; apply derivable_id.
  destruct (H3 H4) as (c & P & H6). exists c; exists P; rewrite H1 in H6.
  unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6.
  rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
    [ rewrite Rmult_0_r; apply H6
      | apply Rminus_eq_contra; red; intro H7; rewrite H7 in H0;
        elim (Rlt_irrefl _ H0) ].
Qed.

(**********)
Lemma nonneg_derivative_1 :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, R0 <= derive_pt f x (pr x)) -> increasing f.
Proof.
  intros.
  unfold increasing.
  intros.
  destruct (total_order_T x y) as [[H1| ->]|H1].
  apply Rplus_le_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  pose proof (MVT_cor1 f _ _ pr H1) as (c & H3 & H4).
  unfold Rminus in H3.
  rewrite H3.
  apply Rmult_le_pos.
  apply H.
  apply Rplus_le_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | idtac ].
  rewrite Rplus_comm.
  rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r. reflexivity.
  right; reflexivity.
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 H1)).
Qed.

(**********)
Lemma nonpos_derivative_0 :
  forall (f:R -> R) (pr:derivable f),
    decreasing f -> forall x:R, derive_pt f x (pr x) <= R0.
Proof.
  intros f pr H x; assert (H0 := H); unfold decreasing in H0;
    generalize (derivable_derive f x (pr x)); intro; elim H1;
      intros l H2.
  rewrite H2; case (Rtotal_order l R0); intro.
  left; assumption.
  elim H3; intro.
  right; assumption.
  generalize (derive_pt_eq_1 f x l (pr x) H2); intros; cut (R0 < l / R2).
  intro; elim (H5 (l / R2) H6); intros delta H7;
    cut (delta / R2 <> R0 /\ R0 < delta / R2 /\ Rabs (delta / R2) < delta).
  intro; decompose [and] H8; intros; generalize (H7 (delta / R2) H9 H12);
    cut ((f (x + delta / R2) - f x) / (delta / R2) <= R0).
  intro; cut (R0 < - ((f (x + delta / R2) - f x) / (delta / R2) - l)).
  intro; unfold Rabs;
    case (Rcase_abs ((f (x + delta / R2) - f x) / (delta / R2) - l)) as [Hlt|Hge].
  intros;
    generalize
      (Rplus_lt_compat_r (- l) (- ((f (x + delta / R2) - f x) / (delta / R2) - l))
        (l / R2) H14); unfold Rminus.
  replace (l / R2 + - l) with (- (l / R2)).
  replace (- ((f (x + delta / R2) + - f x) / (delta / R2) + - l) + - l) with
  (- ((f (x + delta / R2) + - f x) / (delta / R2))).
  intro.
  generalize
    (Ropp_lt_gt_contravar (- ((f (x + delta / R2) + - f x) / (delta / R2)))
      (- (l / R2)) H15).
  repeat rewrite Ropp_involutive.
  intro.
  generalize
    (Rlt_trans R0 (l / R2) ((f (x + delta / R2) - f x) / (delta / R2)) H6 H16);
    intro.
  elim
    (Rlt_irrefl R0
      (Rlt_le_trans R0 ((f (x + delta / R2) - f x) / (delta / R2)) R0 H17 H10)).
{
unfold Rminus, Rdiv.
repeat rewrite Ropp_plus_distr.
symmetry.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l, Rplus_0_r.
reflexivity.
}
  pattern l at 3; rewrite double_var.
{
change (IZR 2) with R2.
rewrite Ropp_plus_distr.
rewrite <- Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_l.
reflexivity.
}
  intros.
  generalize
    (Ropp_ge_le_contravar ((f (x + delta / R2) - f x) / (delta / R2) - l) _ Hge).
  rewrite Ropp_0.
  intro.
  elim
    (Rlt_irrefl R0
      (Rlt_le_trans R0 (- ((f (x + delta / R2) - f x) / (delta / R2) - l)) R0 H13
        H15)).
  replace (- ((f (x + delta / R2) - f x) / (delta / R2) - l)) with
  ((f x - f (x + delta / R2)) / (delta / R2) + l).
  unfold Rminus.
  apply Rplus_le_lt_0_compat.
  unfold Rdiv; apply Rmult_le_pos.
  cut (x <= x + delta * / R2).
  intro; generalize (H0 x (x + delta * / R2) H13); intro;
    generalize
      (Rplus_le_compat_l (- f (x + delta / R2)) (f (x + delta / R2)) (f x) H14);
      rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
    left; assumption.
  left; apply Rinv_0_lt_compat; assumption.
  assumption.
  rewrite Ropp_minus_distr.
  unfold Rminus.
  rewrite (Rplus_comm l).
  unfold Rdiv.
  rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  rewrite (Rplus_comm (f x)).
  reflexivity.
  replace ((f (x + delta / R2) - f x) / (delta / R2)) with
  (- ((f x - f (x + delta / R2)) / (delta / R2))).
  rewrite <- Ropp_0.
  apply Ropp_ge_le_contravar.
  apply Rle_ge.
  unfold Rdiv; apply Rmult_le_pos.
  cut (x <= x + delta * / R2).
  intro; generalize (H0 x (x + delta * / R2) H10); intro.
  generalize
    (Rplus_le_compat_l (- f (x + delta / R2)) (f (x + delta / R2)) (f x) H13);
    rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
    left; assumption.
  left; apply Rinv_0_lt_compat; assumption.
  unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Ropp_minus_distr.
  reflexivity.
  split.
  unfold Rdiv; apply prod_neq_R0.
  generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H8;
    elim (Rlt_irrefl R0 H8).
  apply Rinv_neq_0_compat; exact Neq_2_0.
  split.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; exact Rlt_0_2 ].
  rewrite Rabs_right.
  unfold Rdiv; apply Rmult_lt_reg_l with R2.
  exact Rlt_0_2.
  rewrite <- (Rmult_comm (/ R2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1;
    rewrite <- Rplus_0_r.
  apply Rplus_lt_compat_l; apply (cond_pos delta).
  exact Neq_2_0.
  apply Rle_ge; unfold Rdiv; left; apply Rmult_lt_0_compat.
  apply (cond_pos delta).
  apply Rinv_0_lt_compat; exact Rlt_0_2.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ apply H4 | apply Rinv_0_lt_compat; exact Rlt_0_2 ].
Qed.

(**********)
Lemma increasing_decreasing_opp :
  forall f:R -> R, increasing f -> decreasing (- f)%F.
Proof.
  unfold increasing, decreasing, opp_fct; intros; generalize (H x y H0);
    intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption.
Qed.

(**********)
Lemma nonpos_derivative_1 :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, derive_pt f x (pr x) <= R0) -> decreasing f.
Proof.
  intros.
  cut (forall h:R, - - f h = f h).
  intro.
  generalize (increasing_decreasing_opp (- f)%F).
  unfold decreasing.
  unfold opp_fct.
  intros.
  rewrite <- (H0 x); rewrite <- (H0 y).
  apply H1.
  cut (forall x:R, R0 <= derive_pt (- f) x (derivable_opp f pr x)).
  intros.
  replace (fun x:R => - f x) with (- f)%F; [ idtac | reflexivity ].
  apply (nonneg_derivative_1 (- f)%F (derivable_opp f pr) H3).
  intro.
  assert (H3 := derive_pt_opp f x0 (pr x0)).
  cut
    (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
      derive_pt (- f) x0 (derivable_opp f pr x0)).
  intro.
  rewrite <- H4.
  rewrite H3.
  rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; apply (H x0).
  apply pr_nu.
  assumption.
  intro. now rewrite Ropp_involutive.
Qed.

(**********)
Lemma positive_derivative :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, R0 < derive_pt f x (pr x)) -> strict_increasing f.
Proof.
  intros.
  unfold strict_increasing.
  intros.
  apply Rplus_lt_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  assert (H1 := MVT_cor1 f _ _ pr H0).
  elim H1; intros.
  elim H2; intros.
  unfold Rminus in H3.
  rewrite H3.
  apply Rmult_lt_0_compat.
  apply H.
  apply Rplus_lt_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | idtac ].
fold (y-x). rewrite Rplus_minus. reflexivity.
Qed.

(**********)
Lemma strictincreasing_strictdecreasing_opp :
  forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
Proof.
  unfold strict_increasing, strict_decreasing, opp_fct; intros;
    generalize (H x y H0); intro; apply Ropp_lt_gt_contravar;
      assumption.
Qed.

(**********)
Lemma negative_derivative :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, derive_pt f x (pr x) < R0) -> strict_decreasing f.
Proof.
  intros.
  cut (forall h:R, - - f h = f h).
  intros.
  generalize (strictincreasing_strictdecreasing_opp (- f)%F).
  unfold strict_decreasing, opp_fct.
  intros.
  rewrite <- (H0 x).
  rewrite <- (H0 y).
  apply H1; [ idtac | assumption ].
  cut (forall x:R, R0 < derive_pt (- f) x (derivable_opp f pr x)).
  intros; eapply positive_derivative; apply H3.
  intro.
  assert (H3 := derive_pt_opp f x0 (pr x0)).
  cut
    (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
      derive_pt (- f) x0 (derivable_opp f pr x0)).
  intro.
  rewrite <- H4; rewrite H3.
  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (H x0).
  apply pr_nu.
  intro. now rewrite Ropp_involutive.
Qed.

(**********)
Lemma null_derivative_0 :
  forall (f:R -> R) (pr:derivable f),
    constant f -> forall x:R, derive_pt f x (pr x) = R0.
Proof.
  intros.
  unfold constant in H.
  apply derive_pt_eq_0.
  intros; exists (mkposreal R1 Rlt_0_1); simpl; intros.
  rewrite (H x (x + h)); unfold Rminus; unfold Rdiv;
    rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r;
      rewrite Rabs_R0; assumption.
Qed.

(**********)
Lemma increasing_decreasing :
  forall f:R -> R, increasing f -> decreasing f -> constant f.
Proof.
  unfold increasing, decreasing, constant; intros;
    case (Rtotal_order x y); intro.
  generalize (Rlt_le x y H1); intro;
    apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
  elim H1; intro.
  rewrite H2; reflexivity.
  generalize (Rlt_le y x H2); intro; symmetry ;
    apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
Qed.

(**********)
Lemma null_derivative_1 :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, derive_pt f x (pr x) = R0) -> constant f.
Proof.
  intros.
  cut (forall x:R, derive_pt f x (pr x) <= R0).
  cut (forall x:R, R0 <= derive_pt f x (pr x)).
  intros.
  assert (H2 := nonneg_derivative_1 f pr H0).
  assert (H3 := nonpos_derivative_1 f pr H1).
  apply increasing_decreasing; assumption.
  intro; right; symmetry ; apply (H x).
  intro; right; apply (H x).
Qed.

(**********)
Lemma derive_increasing_interv_ax :
  forall (a b:R) (f:R -> R) (pr:derivable f),
    a < b ->
    ((forall t:R, a < t < b -> R0 < derive_pt f t (pr t)) ->
      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y) /\
    ((forall t:R, a < t < b -> R0 <= derive_pt f t (pr t)) ->
      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y).
Proof.
  intros.
  split; intros.
  apply Rplus_lt_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  assert (H4 := MVT_cor1 f _ _ pr H3).
  elim H4; intros.
  elim H5; intros.
  unfold Rminus in H6.
  rewrite H6.
  apply Rmult_lt_0_compat.
  apply H0.
  elim H7; intros.
  split.
  elim H1; intros.
  apply Rle_lt_trans with x; assumption.
  elim H2; intros.
  apply Rlt_le_trans with y; assumption.
  apply Rplus_lt_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | idtac ].
fold (y-x). now rewrite Rplus_minus.
  apply Rplus_le_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  assert (H4 := MVT_cor1 f _ _ pr H3).
  elim H4; intros.
  elim H5; intros.
  unfold Rminus in H6.
  rewrite H6.
  apply Rmult_le_pos.
  apply H0.
  elim H7; intros.
  split.
  elim H1; intros.
  apply Rle_lt_trans with x; assumption.
  elim H2; intros.
  apply Rlt_le_trans with y; assumption.
  apply Rplus_le_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y;
    [ left; assumption | idtac ].
fold (y-x). now rewrite Rplus_minus.
Qed.

(**********)
Lemma derive_increasing_interv :
  forall (a b:R) (f:R -> R) (pr:derivable f),
    a < b ->
    (forall t:R, a < t < b -> R0 < derive_pt f t (pr t)) ->
    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y.
Proof.
  intros.
  generalize (derive_increasing_interv_ax a b f pr H); intro.
  elim H4; intros H5 _; apply (H5 H0 x y H1 H2 H3).
Qed.

(**********)
Lemma derive_increasing_interv_var :
  forall (a b:R) (f:R -> R) (pr:derivable f),
    a < b ->
    (forall t:R, a < t < b -> R0 <= derive_pt f t (pr t)) ->
    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y.
Proof.
  intros a b f pr H H0 x y H1 H2 H3;
    generalize (derive_increasing_interv_ax a b f pr H);
      intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3).
Qed.

(**********)
(**********)
Theorem IAF :
  forall (f:R -> R) (a b k:R) (pr:derivable f),
    a <= b ->
    (forall c:R, a <= c <= b -> derive_pt f c (pr c) <= k) ->
    f b - f a <= k * (b - a).
Proof.
  intros.
  destruct (total_order_T a b) as [[H1| -> ]|H1].
  pose proof (MVT_cor1 f _ _ pr H1) as (c & -> & H4).
  do 2 rewrite <- (Rmult_comm (b - a)).
  apply Rmult_le_compat_l.
  apply Rplus_le_reg_l with a; rewrite Rplus_0_r.
  replace (a + (b - a)) with b; [ assumption | idtac ].
fold (b-a). now rewrite Rplus_minus.
  apply H0.
  elim H4; intros.
  split; left; assumption.
  unfold Rminus; do 2 rewrite Rplus_opp_r.
  rewrite Rmult_0_r; right; reflexivity.
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H H1)).
Qed.

Lemma IAF_var :
  forall (f g:R -> R) (a b:R) (pr1:derivable f) (pr2:derivable g),
    a <= b ->
    (forall c:R, a <= c <= b -> derive_pt g c (pr2 c) <= derive_pt f c (pr1 c)) ->
    g b - g a <= f b - f a.
Proof.
  intros.
  cut (derivable (g - f)).
  intro X.
  cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= R0).
  intro.
  assert (H2 := IAF (g - f)%F a b R0 X H H1).
  rewrite Rmult_0_l in H2; unfold minus_fct in H2.
  apply Rplus_le_reg_l with (- f b + f a).
  replace (- f b + f a + (f b - f a)) with R0.
2:{
symmetry.
unfold Rminus.
repeat rewrite Rplus_assoc.
rewrite (Rplus_comm (f a)).
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l, Rplus_0_r, Rplus_opp_l.
reflexivity.
}
  replace (- f b + f a + (g b - g a)) with (g b - f b - (g a - f a));
  [ apply H2 | idtac ].
{
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
apply Rplus_eq_compat_r.
rewrite Rplus_comm.
repeat rewrite <- Rplus_assoc.
reflexivity.
}
  intros.
  cut
    (derive_pt (g - f) c (X c) =
      derive_pt (g - f) c (derivable_pt_minus _ _ _ (pr2 c) (pr1 c))).
  intro.
  rewrite H2.
  rewrite derive_pt_minus.
  apply Rplus_le_reg_l with (derive_pt f c (pr1 c)).
  rewrite Rplus_0_r.
  replace
  (derive_pt f c (pr1 c) + (derive_pt g c (pr2 c) - derive_pt f c (pr1 c)))
    with (derive_pt g c (pr2 c)).
2:{
rewrite Rplus_minus.
reflexivity.
}
  apply H0; assumption.
  apply pr_nu.
  apply derivable_minus; assumption.
Qed.

(* If f has a null derivative in ]a,b[ and is continue in [a,b], *)
(* then f is constant on [a,b] *)
Lemma null_derivative_loc :
  forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
    (forall x:R, a <= x <= b -> continuity_pt f x) ->
    (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = R0) ->
    constant_D_eq f (fun x:R => a <= x <= b) (f a).
Proof.
  intros; unfold constant_D_eq; intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
  assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
  intros; apply derivable_pt_id.
  assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y).
  intros; apply derivable_continuous; apply derivable_id.
  assert (H4 : forall y:R, a < y < x -> derivable_pt f y).
  intros; apply pr; elim H4; intros; split.
  assumption.
  elim H1; intros; apply Rlt_le_trans with x; assumption.
  assert (H5 : forall y:R, a <= y <= x -> continuity_pt f y).
  intros; apply H; elim H5; intros; split.
  assumption.
  elim H1; intros; apply Rle_trans with x; assumption.
  elim H1; clear H1; intros; elim H1; clear H1; intro.
  assert (H7 := MVT f id a x H4 H2 H1 H5 H3).
  destruct H7 as (c & P & H9).
  assert (H10 : a < c < b).
  split.
  apply P.
  apply Rlt_le_trans with x; [apply P|assumption].
  assert (H11 : derive_pt f c (H4 c P) = R0).
  replace (derive_pt f c (H4 c P)) with (derive_pt f c (pr c H10));
  [ apply H0 | apply pr_nu ].
  assert (H12 : derive_pt id c (H2 c P) = R1).
  apply derive_pt_eq_0; apply derivable_pt_lim_id.
  rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
    rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry ;
      assumption.
  rewrite H1; reflexivity.
  assert (H2 : x = a).
  rewrite <- Heq in H1; elim H1; intros; apply Rle_antisym; assumption.
  rewrite H2; reflexivity.
  elim H1; intros;
    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) Hgt)).
Qed.

(* Unicity of the antiderivative *)
Lemma antiderivative_Ucte :
  forall (f g1 g2:R -> R) (a b:R),
    antiderivative f g1 a b ->
    antiderivative f g2 a b ->
    exists c : R, (forall x:R, a <= x <= b -> g1 x = g2 x + c).
Proof.
  unfold antiderivative; intros; elim H; clear H; intros; elim H0;
    clear H0; intros H0 _; exists (g1 a - g2 a); intros;
      assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
  intros; unfold derivable_pt; exists (f x0); elim (H x0 H3);
    intros; eapply derive_pt_eq_1; symmetry ;
      apply H4.
  assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
  intros; unfold derivable_pt; exists (f x0);
    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry ;
      apply H5.
  assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
  intros; elim H5; intros; apply derivable_pt_minus;
    [ apply H3; split; left; assumption | apply H4; split; left; assumption ].
  assert (H6 : forall x:R, a <= x <= b -> continuity_pt (g1 - g2) x).
  intros; apply derivable_continuous_pt; apply derivable_pt_minus;
    [ apply H3 | apply H4 ]; assumption.
  assert (H7 : forall (x:R) (P:a < x < b), derive_pt (g1 - g2) x (H5 x P) = R0).
  intros; elim P; intros; apply derive_pt_eq_0; replace R0 with (f x0 - f x0).
2:{
unfold Rminus. rewrite Rplus_opp_r. reflexivity.
}
  assert (H9 : a <= x0 <= b).
  split; left; assumption.
  apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
    eapply derive_pt_eq_1; symmetry ; apply H10.
  assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
    unfold constant_D_eq in H8; assert (H9 := H8 _ H2);
      unfold minus_fct in H9; rewrite <- H9.
rewrite Rplus_minus. reflexivity.
Qed.

(* A variant of MVT using absolute values. *)
Lemma MVT_abs :
  forall (f f' : R -> R) (a b : R),
  (forall c : R, Rmin a b <= c <= Rmax a b ->
      derivable_pt_lim f c (f' c)) ->
  exists c : R, Rabs (f b - f a) = Rabs (f' c) * Rabs (b - a) /\
             Rmin a b <= c <= Rmax a b.
Proof.
intros f f' a b.
destruct (Rle_dec a b) as [aleb | blta].
 destruct (Req_dec a b) as [ab | anb].
  unfold Rminus; intros _; exists a; split.
   now rewrite <- ab, !Rplus_opp_r, Rabs_R0, Rmult_0_r.
  split;[apply Rmin_l | apply Rmax_l].
 rewrite Rmax_right, Rmin_left; auto; intros derv.
 destruct (MVT_cor2 f f' a b) as [c [hc intc]];
  [destruct aleb;[assumption | contradiction] | apply derv | ].
 exists c; rewrite hc, Rabs_mult;split;
  [reflexivity | unfold Rle; tauto].
assert (b < a) by (apply Rnot_le_gt; assumption).
assert (b <= a) by (apply Rlt_le; assumption).
rewrite Rmax_left, Rmin_right; try assumption; intros derv.
destruct (MVT_cor2 f f' b a) as [c [hc intc]];
 [assumption | apply derv | ].
exists c; rewrite <- Rabs_Ropp, Ropp_minus_distr, hc, Rabs_mult.
split;[now rewrite <- (Rabs_Ropp (b - a)), Ropp_minus_distr| unfold Rle; tauto].
Qed.


From Undecidability.L.Datatypes Require Import LNat Lists LOptions LSum.
Require Import Undecidability.L.Tactics.GenEncode.

Inductive reccode :=
| rc_cst (n : nat)
| rc_zero
| rc_succ
| rc_proj (n : nat)
| rc_comp (f : reccode) (g : reccode)
| rc_cons (f : reccode) (g : reccode)
| rc_nil
| rc_rec (f : reccode) (g : reccode)
| rc_min (f : reccode).

Fixpoint eval (fuel : nat) (min : nat) (c : reccode) (v : list nat) : option (nat + list nat) :=
  match fuel with
  | 0 => None
  | S fuel =>
    match c with
    | rc_cst n => Some (inl n)
    | rc_zero => Some (inl 0)
    | rc_succ => match v with
                | x :: _ => Some (inl (S x))
                | _ => None
                end
    | rc_proj n => match nth_error v n with Some r => Some (inl r) | None => None end
    | rc_comp f g => match eval fuel min g v
                    with
                    | Some (inr g) => match eval fuel min f g with Some (inl f) => Some (inl f) | _ => None end
                    | _ => None
                    end
    | rc_cons f g => match eval fuel min f v, eval fuel min g v with
                    | Some (inl f), Some (inr g) => Some (inr (f :: g))
                    | _, _ => None
                    end
    | rc_nil => Some (inr nil)
    | rc_rec f g => match v with
                   | 0 :: v => match eval fuel min f v with Some (inl r) => Some (inl r) | _ => None end
                   | S n :: v => match eval fuel min (rc_rec f g) (n :: v) with
                               | Some (inl y) => match eval fuel min g (n :: y :: v) with Some (inl r) => Some (inl r) | _ => None end
                               | _ => None
                               end
                   | _ => None
                   end
    | rc_min f => match eval fuel 0 f (min :: v) with
                 | Some (inl 0) => Some (inl min)
                 | Some (inl _) => match eval fuel (S min) (rc_min f) v with Some (inl r) => Some (inl r) | _ => None end
                 | _ => None
                 end
    end
  end.

MetaCoq Run (tmGenEncode "enc_reccode" reccode).
#[export] Hint Resolve enc_reccode_correct : Lrewrite.

#[global]
Instance term_rc_comp: computable rc_comp. Proof. extract constructor. Qed.
#[global]
Instance term_rc_cons : computable rc_cons. Proof. extract constructor. Qed.
#[global]
Instance term_rc_rec : computable rc_rec. Proof. extract constructor. Qed.
#[global]
Instance term_rc_min : computable rc_min. Proof. extract constructor. Qed.
#[global]
Instance term_eval : computable eval.
Proof.
  extract.
Qed.


Require Export ListFunctions.

Set Implicit Arguments.
Unset Strict Implicit.

Definition SECLEV := nat.
Parameter CATEGORY : Set.

Record SecClass : Set := sclass {level : SECLEV; categs : set CATEGORY}.

Definition eq_sc (a b : SecClass) : Prop :=
  level a = level b /\ categs a = categs b.

Definition le_sc (a b : SecClass) : Prop :=
  level a <= level b /\ Included (categs a) (categs b).

Hint Unfold eq_sc le_sc.

(*********************************************************************)
(*                  Security Policy Entities                         *)
(*********************************************************************)

Parameter ENTITY : Set.

Axiom ENTeq_dec : forall x y : ENTITY, {x = y} + {x <> y}.

Hint Resolve ENTeq_dec.

Parameter BYTE : Set.

Definition ENTCONT := list BYTE.

Axiom BYTEeq_dec : forall x y : BYTE, {x = y} + {x <> y}.

Lemma ENTCONTeq_dec : forall x y : ENTCONT, {x = y} + {x <> y}.
unfold ENTCONT in |- *; intros; apply Listeq_dec.
apply BYTEeq_dec.
Qed.

Hint Resolve ENTCONTeq_dec.

(*********************************************************************)
(*                  Security Policy ENTITYs                          *)
(*********************************************************************)

Record RIGHTS : Set := allowedTo {read_right : bool; write_right : bool}.

Record CapabilityData : Set := capdata
  {CanReadEntities : set ENTITY;
   CanWriteEntities : set ENTITY}.

Record ReadingWriting : Set := mkRW
  {EntReadingList : set ENTITY; EntWritingList : set ENTITY}.

Axiom RWeq_dec : forall x1 x2 : ReadingWriting, {x1 = x2} + {x1 <> x2}.

(*********************************************************************)
(*                     Secured System                            *)
(*********************************************************************)

Record SFSstate : Set := mkSFS
  {
   entitySC : set (ENTITY * SecClass);
   cap : set (ENTITY * CapabilityData);
   secmat : set (ENTITY * ReadingWriting);
   entitycontent : set (ENTITY * ENTCONT)}.

Axiom ESCeq_dec : forall x1 x2 : ENTITY * SecClass, {x1 = x2} + {x1 <> x2}.
Axiom
  CAPeq_dec :
    forall x1 x2 : ENTITY * CapabilityData, {x1 = x2} + {x1 <> x2}.
Axiom
  SECMATeq_dec :
    forall x1 x2 : ENTITY * ReadingWriting, {x1 = x2} + {x1 <> x2}.

Hint Resolve ESCeq_dec CAPeq_dec SECMATeq_dec RWeq_dec.

(*In this section we implement finite partial functions (FPF) with type set defined at module ListSet.v.*)

Section PartialFunctions.

Variable X Y : Set.

Hypothesis Xeq_dec : forall x1 x2 : X, {x1 = x2} + {x1 <> x2}.
Hypothesis Yeq_dec : forall x1 x2 : Y, {x1 = x2} + {x1 <> x2}.
Hypothesis XYeq_dec : forall x1 x2 : X * Y, {x1 = x2} + {x1 <> x2}.

(*Domain of a FPF*)
Fixpoint DOM (f : set (X * Y)) : set X :=
  match f with
  | nil => nil (A:=X)
  | (x, y) :: g => set_add Xeq_dec x (DOM g)
  end.

(*Range of a FPF*)
Fixpoint RAN (f : set (X * Y)) : set Y :=
  match f with
  | nil => nil (A:=Y)
  | (x, y) :: g => set_add Yeq_dec y (RAN g)
  end.

(*Application of a FPF*)
Fixpoint PARTFUNC (f : set (X * Y)) : X -> Exc Y :=
  fun x : X =>
  match f with
  | nil => None (A:=Y)
  | (x1, y) :: g =>
      match Xeq_dec x x1 with
      | left _ => Some y
      | right _ => PARTFUNC g x
      end
  end.

(*Test to decide whether a set of pairs is a FPF or not*)
Fixpoint IsPARTFUNC (f : set (X * Y)) : Prop :=
  match f with
  | nil => True
  | a :: l =>
      match set_In_dec Xeq_dec (fst a) (DOM l) with
      | left _ => False
      | right _ => IsPARTFUNC l
      end
  end.

(*Some usefull lemmas about our implementation of FPF*)

Lemma AddEq :
 forall (a b : X) (y : Y) (f : set (X * Y)),
 a <> b -> PARTFUNC f a = PARTFUNC (set_add XYeq_dec (b, y) f) a.
intros.
induction  f as [| a0 f Hrecf].
simpl in |- *.
elim (Xeq_dec a b).
intros.
cut False.
intro.
elim H0.

unfold not in H; apply H.
auto.

auto.

simpl in |- *.
elim a0.
intros.
elim (Xeq_dec a a1).
elim (XYeq_dec (b, y) (a1, b0)).
intros.
cut False.
intro F.
elim F.

unfold not in H.
apply H.
rewrite a3.
injection a2.
auto.

simpl in |- *.
elim (Xeq_dec a a1).
auto.

intros.
cut False.
intro F.
elim F.

auto.

elim (XYeq_dec (b, y) (a1, b0)).
simpl in |- *.
elim (Xeq_dec a a1).
intros.
cut False.
intro F.
elim F.

auto.

auto.

simpl in |- *.
elim (Xeq_dec a a1).
intros.
cut False.
intro F.
elim F.

auto.

intros.
auto.

Qed.

Lemma AddEq1 :
 forall (x : X) (y : Y) (f : set (X * Y)),
 ~ set_In x (DOM f) -> value y = PARTFUNC (set_add XYeq_dec (x, y) f) x.
simple induction f.
simpl in |- *.
elim (Xeq_dec x x); auto.
intro; absurd (x = x); auto.

simpl in |- *.
intros until l.
elim a.
intros until b.
elim (XYeq_dec (x, y) (a0, b)).
simpl in |- *.
elim (Xeq_dec x a0).
intros.
injection a2; intros.
rewrite H1; auto.

intros.
injection a1; intros; absurd (x = a0); auto.

simpl in |- *.
elim (Xeq_dec x a0).
intros.
rewrite a1 in H0.
cut False.
tauto.

apply H0.
apply set_add_intro2; auto.

intros.
apply H.
intro; apply H0; apply set_add_intro1; auto.

Qed.

Lemma RemEq :
 forall (a b : X) (y : Y) (f : set (X * Y)),
 a <> b -> PARTFUNC f a = PARTFUNC (set_remove XYeq_dec (b, y) f) a.
intros.
induction  f as [| a0 f Hrecf].
auto.

simpl in |- *.
elim a0.
intros.
elim (Xeq_dec a a1).
elim (XYeq_dec (b, y) (a1, b0)).
intros.
cut False.
intro F.
elim F.

unfold not in H.
apply H.
rewrite a3.
injection a2.
auto.

simpl in |- *.
elim (Xeq_dec a a1).
auto.

intros.
cut False.
intro F.
elim F.

auto.

elim (XYeq_dec (b, y) (a1, b0)).
simpl in |- *.
elim (Xeq_dec a a1).
intros.
cut False.
intro F.
elim F.

auto.

auto.

simpl in |- *.
elim (Xeq_dec a a1).
intros.
cut False.
intro F.
elim F.

auto.

intros.
auto.

Qed.

Lemma AddRemEq :
 forall (a b : X) (y z : Y) (f : set (X * Y)),
 a <> b ->
 PARTFUNC f a =
 PARTFUNC (set_add XYeq_dec (b, z) (set_remove XYeq_dec (b, y) f)) a.
intros.
induction  f as [| a0 f Hrecf].
simpl in |- *.
elim (Xeq_dec a b).
intros.
cut False.
intro F; elim F.

auto.

auto.

simpl in |- *.
elim a0.
intros.
elim (Xeq_dec a a1).
elim (XYeq_dec (b, y) (a1, b0)).
intros.
cut False.
intro F; elim F.

unfold not in H; apply H.
rewrite a3.
injection a2.
auto.

simpl in |- *.
elim (XYeq_dec (b, z) (a1, b0)).
intros.
cut False.
intro F; elim F.

unfold not in H.
apply H.
rewrite a3.
injection a2.
auto.

simpl in |- *.
elim (Xeq_dec a a1).
auto.

intros.
cut False.
intro F; elim F.

auto.

elim (XYeq_dec (b, y) (a1, b0)).
auto.

intros.
simpl in |- *.
elim (XYeq_dec (b, z) (a1, b0)).
simpl in |- *.
elim (Xeq_dec a a1).
intros.
cut False.
intro F; elim F.

auto.

intros.
apply RemEq.
auto.

auto.

simpl in |- *.
elim (Xeq_dec a a1).
intros.
cut False.
intro F; elim F.

auto.

auto.

Qed.

Lemma NotInDOMIsUndef :
 forall (o : X) (f : set (X * Y)), ~ set_In o (DOM f) -> PARTFUNC f o = None.
intros.
induction  f as [| a f Hrecf].
simpl in |- *.
auto.

generalize H.
simpl in |- *.
elim a.
intro; intro.
elim (Xeq_dec o a0).
intro.
rewrite a1.
intro.
cut False.
intro F; elim F.

unfold not in H0.
apply H0.
apply set_add_intro2.
auto.

intros.
apply Hrecf.
unfold not in H0; unfold not in |- *.
intro; apply H0.
apply set_add_intro1.
auto.

Qed.

Hint Resolve NotInDOMIsUndef.

Lemma InDOMIsNotUndef :
 forall (o : X) (f : set (X * Y)), set_In o (DOM f) -> PARTFUNC f o <> None.
simple induction f.
auto.

simpl in |- *.
intro.
elim a.
intro.
elim (Xeq_dec o a0).
intros; intro H3; discriminate H3.

intros; apply H.

eauto.

Qed.

Lemma InDOMWhenAdd :
 forall (x : X) (y : Y) (f : set (X * Y)),
 set_In x (DOM (set_add XYeq_dec (x, y) f)).
intros; induction  f as [| a f Hrecf].
simpl in |- *.
left; auto.

simpl in |- *.
elim (XYeq_dec (x, y) a).
simpl in |- *.
elim a.
intros.
injection a1; intros.
apply set_add_intro2; auto.

simpl in |- *.
elim a.
intros.
apply set_add_intro1; auto.

Qed.

Lemma DOMFuncRel :
 forall (a : X * Y) (f : set (X * Y)),
 ~ set_In (fst a) (DOM f) -> f = set_remove XYeq_dec a f.
simple induction f.
simpl in |- *; auto.

simpl in |- *.
intro; elim a0.
intros until b; elim (XYeq_dec a (a1, b)).
elim a.
intros.
injection a3; intros.
simpl in H0; rewrite H2 in H0.
cut False.
tauto.

apply H0; apply set_add_intro2; auto.

elim a.
simpl in |- *.
intros.
cut (l = set_remove XYeq_dec (a2, b0) l).
intro.
rewrite <- H1; auto.

apply H.
intro; apply H0; apply set_add_intro; auto.

Qed.

Hint Resolve DOMFuncRel.

Lemma DOMFuncRel2 :
 forall (z : X * Y) (f : set (X * Y)), set_In z f -> set_In (fst z) (DOM f).
simple induction f.
simpl in |- *; auto.

simpl in |- *.
intro; elim a.
elim z.
simpl in |- *.
intros.
elim H0; intro.
injection H1; intros.
apply set_add_intro; auto.

cut (set_In a0 (DOM l)).
intro; apply set_add_intro1; auto.

auto.

Qed.

Hint Resolve DOMFuncRel2.

Lemma DOMFuncRel3 :
 forall (x : X) (y : Y) (f : set (X * Y)),
 IsPARTFUNC f ->
 set_In (x, y) f -> ~ set_In x (DOM (set_remove XYeq_dec (x, y) f)).
simple induction f.
simpl in |- *; auto.

simpl in |- *.
intros until l; elim (set_In_dec Xeq_dec (fst a) (DOM l));
 elim (XYeq_dec (x, y) a).
tauto.

tauto.

intros; cut (l = set_remove XYeq_dec (x, y) l).
intro H2; rewrite <- H2; replace x with (fst a); auto.
rewrite <- a0; auto.

rewrite a0; auto.

simpl in |- *.
elim a.
simpl in |- *.
intros.
elim H1; intro.
absurd ((a0, b) = (x, y)); auto.

elim (Xeq_dec x a0); intro.
rewrite <- a1 in b1.
intro; apply b1; replace x with (fst (x, y)); auto.

cut (~ set_In x (DOM (set_remove XYeq_dec (x, y) l))).
auto.

auto.

Qed.

Lemma DOMFuncRel4 :
 forall (x : X) (f : set (X * Y)),
 match PARTFUNC f x with
 | Some a => set_In (x, a) f
 | None => ~ set_In x (DOM f)
 end.
simple induction f.
simpl in |- *; auto.

simpl in |- *.
intros until l; elim a.
intros until b; elim (Xeq_dec x a0).
elim (PARTFUNC l x).
intros y2 H; left; rewrite H; auto.

intros H H1; left; rewrite H; auto.

elim (PARTFUNC l x).
auto.

auto.

Qed.

Lemma UndefWhenRem :
 forall (x : X) (y : Y) (f : set (X * Y)),
 IsPARTFUNC f ->
 set_In (x, y) f -> PARTFUNC (set_remove XYeq_dec (x, y) f) x = None.
simple induction f.
simpl in |- *; auto.

simpl in |- *.
intros until l.
elim (set_In_dec Xeq_dec (fst a) (DOM l)); elim (XYeq_dec (x, y) a).
tauto.

tauto.

intros.
replace (set_remove XYeq_dec (x, y) l) with l.
rewrite <- a0 in b.
simpl in b.
auto.

rewrite <- a0 in b.
auto.

simpl in |- *.
elim a.
intros.
elim H1; intro.
cut False.
tauto.

apply b0; symmetry  in |- *; auto.

elim (Xeq_dec x a0).
intro.
simpl in b1.
rewrite <- a1 in b1.
absurd (set_In x (DOM l)).
auto.

replace x with (fst (x, y)); auto.

auto.

Qed.

End PartialFunctions.

Hint Resolve AddEq RemEq AddRemEq NotInDOMIsUndef InDOMIsNotUndef
  InDOMWhenAdd UndefWhenRem AddEq1 DOMFuncRel3.

(*Shorthands for domains and partial functions defined for each of the state's*)
(*components.   *)
Definition dome (f : set (ENTITY * ENTCONT)) := DOM ENTeq_dec f.

Definition fentities (f : set (ENTITY * ENTCONT)) : ENTITY -> Exc ENTCONT :=
  PARTFUNC ENTeq_dec f.

Definition domcap (f : set (ENTITY * CapabilityData)) := DOM ENTeq_dec f.

Definition fcap (f : set (ENTITY * CapabilityData)) :
  ENTITY -> Exc CapabilityData := PARTFUNC ENTeq_dec f.

Definition domsecmat (f : set (ENTITY * ReadingWriting)) := DOM ENTeq_dec f.

Definition ransecmat (f : set (ENTITY * ReadingWriting)) := RAN RWeq_dec f.

Definition fsecmat (f : set (ENTITY * ReadingWriting)) :
  ENTITY -> Exc ReadingWriting := PARTFUNC ENTeq_dec f.

Definition domESC (f : set (ENTITY * SecClass)) := DOM ENTeq_dec f.

Definition fESC (f : set (ENTITY * SecClass)) : ENTITY -> Exc SecClass :=
  PARTFUNC ENTeq_dec f.

(*Filesystem update functions.                                       *)
Parameter write_entities : ENTITY -> nat -> ENTCONT -> set (ENTITY * ENTCONT).

(*
READ: pure read access
WRITE: pure write access
*)

Inductive MODE : Set :=
  | READ : MODE
  | WRITE : MODE.

(*The names of the system operations.                                *)

Inductive Operation : Set :=
  | Read : Operation
  | Write : Operation.


(*https://lists.chalmers.se/pipermail/agda/2010/001565.html
-----------------------------------------------------

From this proof, I realized it can be applied to Set as well.

-----------------------------------------------------*)
Inductive I : (Set -> Set) -> Set :=
| i1 : I (fun x => x)
| i2 : I (fun x => x)
.

Axiom inj_I : forall x y, I x = I y -> x = y.

Definition R (x : Set) : Set := forall p: Set -> Set, x = I p -> p x -> False.

Lemma R_eqv_1 :
  forall p, R (I p) -> (p (I p) -> False).

Proof.
intros ? ?.
  apply H. reflexivity.
Qed.

Lemma R_eqv_2 :
  forall p, (p (I p) -> False) -> R (I p).

intros.
 unfold R; intros q H0.
 rewrite <- (inj_I p q H0).
 assumption.
Qed.

Lemma R_eqv_not_R_1 :
  R (I R) -> R (I R) -> False.

Proof (R_eqv_1 R).

Lemma R_eqv_not_R_2 :
  (R (I R) -> False) -> R (I R).

Proof (R_eqv_2 R).

Lemma absurd : False.

Proof.
set (H := R_eqv_not_R_1).
set (H0 := R_eqv_not_R_2).

exact (H (H0 (fun x => H x x)) (H0 (fun x => H x x))).
Qed.