Require Import Coq.Strings.String.
Require Import Coq.Init.Datatypes.
Require Import List.
Import ListNotations.
Open Scope list_scope.
Require Import Core.

Definition g1 := {|
  start_symbol := NT "S";
  rules := [
    (NT "S", [inr (T "("); inl (NT "S"); inr (T ")")]);
    (NT "S", [inl (NT "S"); inl (NT "S")]);
    (NT "S", [inr (T "O")])
  ];
|}.
Definition new_name (ss: nt) :=
  match ss with
  | NT s => NT (s ++ "'")
  end.

Definition new_s_s (g: cfg) := {|
  start_symbol := new_name (start_symbol g);
  rules := (new_name (start_symbol g), [inl (start_symbol g)])::(rules g)
|}.

Compute (new_s_s g1).

Definition well_named_left_local (g: cfg) :=
  forall (left: nt) (right: sf),
    In (left,right) (rules g) ->
    left <> new_name (start_symbol g).

Definition well_named_right_local (g: cfg) :=
  forall (left: nt) (right: sf),
    In (left,right) (rules g) ->
    (forall nt, In nt right -> nt <> inl (new_name (start_symbol g))).

(* Definition well_named_local (g: cfg) :=
  well_named_left_local g /\ well_named_right_local g. *)

Theorem progress:
  forall (g:cfg) (left: nt) (right: sf),
    well_named_left_local g ->
    In (left,right) (rules (new_s_s g)) ->
    left = (start_symbol (new_s_s g)) ->
    right = [inl (start_symbol g)].
Proof.
  intros g l r WN H0 H1.
  unfold well_named_left_local in WN.
  simpl in H0.
  destruct H0.
  - inversion_clear H. reflexivity.
  - apply WN in H. subst. destruct H. simpl. reflexivity.
Qed.

Lemma lemma_5:
  forall nt,
    nt <> new_name nt.
Proof.
  intros nt contra.
  destruct nt. unfold new_name in contra.
  inversion contra.
  clear contra. induction s.
  - inversion H0.
  - inversion H0. auto.
Qed.

Theorem progress':
  forall (g:cfg) (rule: nt * sf),
    well_named_right_local g ->
    In rule (rules (new_s_s g)) ->
    ~ (In (inl (start_symbol (new_s_s g))) (snd rule)).
Proof.
  intros g rule WN2 H contra.
  unfold well_named_right_local in WN2.
  destruct rule.
  simpl in *.
  destruct H.
  - inversion H. subst. destruct contra.
    + inversion H0. apply lemma_5 in H2. assumption.
    + inversion H0.
  - apply WN2 with (nt0 := inl (new_name (start_symbol g)))in H.
    + unfold not in H. apply H. reflexivity.
    + assumption.
Qed.

(* Lemma lemma_1:
  forall g left right, In (left, right) (rules g) -> In (left, right) (rules (new_s_s g)).
Proof.
  Admitted.
 *)
Lemma lemma_2:
  forall g g' s,
    derives g [inl (start_symbol g)] s ->
    (forall rule, In rule (rules g) -> In rule (rules g')) ->
    derives g' [inl (start_symbol g)] s.
Proof.
  intros.
  induction H.
  - apply derives_refl.
  - apply derives_trans with (s2 := s2 ++ inl left :: s3).
    + apply IHderives.
    + apply derives_step with (left := left).
      * apply derives_refl.
      * apply H0. apply H1.
Qed.

Lemma lemma_3:
  forall g s,
    derives g [inl (start_symbol g)] s ->
    derives (new_s_s g) [inl (start_symbol g)] s.
Proof.
  intros.
  apply lemma_2.
  - assumption.
  - intros.
    simpl. right. assumption. Qed.

Theorem derives_rule:
  forall g left right s1 s2,
    In (left,right) (rules g) ->
    derives g (s1 ++ [inl left] ++ s2) (s1 ++ right ++ s2).
Proof.
  intros g left right s1 s2 H.
  apply derives_step with (left:=left).
  - apply derives_refl.
  - exact H.
Qed.

Theorem derives_start:
  forall g left right,
    In (left,right) (rules g) -> derives g [inl left] right.
Proof.
  intros g left right H.
  apply derives_rule with (s1:=[]) (s2:=[]) in H.
  simpl in H.
  rewrite app_nil_r in H.
  exact H.
Qed.

Lemma lemma_8:
  forall g s (l:nt) r,
    derives g [inl l] s ->
    In (l,r) (rules g) ->
    (forall l' r', In (l',r') (rules g) -> l = l' -> r = r') ->
    s = r.
Proof.
  intros. apply derives_start in H0.
  destruct s. admit. inversion H.
Admitted.

Lemma lemma_7:
  forall g s (l:nt) r,
    derives g [inl l] s ->
    In (l,r) (rules g) ->
    (forall l' r', In (l',r') (rules g) -> l = l' -> r = r') ->
    derives g r s.
Proof.
  intros.
  apply lemma_8 with (r := r) in H.
  - subst. apply derives_refl.
  - assumption.
  - assumption.
Qed.

Lemma lemma_4:
  forall (g: cfg) s,
    well_named_left_local g ->
    derives (new_s_s g) [inl (new_name (start_symbol g))] s ->
    derives (new_s_s g) [inl (start_symbol g)] s.
Proof.
  intros.
  apply lemma_7 with (r := [inl (start_symbol g)]) in H0.
  + simpl. assumption.
  + simpl. left. reflexivity.
  + intros. subst. destruct H1. inversion H1. subst. reflexivity.
    unfold well_named_left_local in H. apply H in H1. unfold not in H1. exfalso. apply H1. reflexivity.
Qed.

Lemma lemma_6:
  forall g s1 s2 s3,
  ~ (derives (new_s_s g) s1
      (s2 ++ inl (new_name (start_symbol g)) :: s3)).
Proof.
  intros g s1 s2 s3 c.
Admitted.

Lemma lemma_11:
  forall g s,
    derives (new_s_s g) [inl (start_symbol g)] s -> derives g [inl (start_symbol g)] s.
Proof.
  intros.
  induction H.
Admitted.

Lemma lemma_9:
  forall g s,
    derives g [inl (start_symbol g)] s ->
    derives (new_s_s g) [inl (new_name (start_symbol g))] s.
Proof.
  intros.
  apply derives_left with (g := new_s_s g) (s1 := []) (right := [inl (start_symbol g)]).
  + simpl. apply lemma_3. assumption.
  + simpl. left. reflexivity.
Qed.

Lemma lemma_10:
  forall g s,
    derives (new_s_s g) [inl (new_name (start_symbol g))] s ->
    derives g [inl (start_symbol g)] s.
Proof.
  intros.
  apply lemma_4 in H.
  apply lemma_11 in H.
  exact H.
Admitted.

Theorem equivalence:
  forall g,
      g_equiv g (new_s_s g).
Proof.
  unfold g_equiv. unfold produces. unfold generates. simpl. split.
  - apply lemma_9.
  - apply lemma_10.
Qed.


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedSubtype.

Opaque reducible_values.

Lemma annotated_subtype_prod:
  forall Θ Γ A1 A2 B1 B2 x,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv A1) ->
    ~(x ∈ fv A2) ->
    ~(x ∈ fv B1) ->
    ~(x ∈ fv B2) ->
    ~(x ∈ Θ) ->
    is_annotated_type A2 ->
    is_annotated_type B2 ->
    [[ Θ; Γ ⊨ A1 <: B1 ]] ->
    [[ Θ; (x,A1) :: Γ ⊨ open 0 A2 (fvar x term_var) <: open 0 B2 (fvar x term_var) ]] ->
    [[ Θ; Γ ⊨ T_prod A1 A2 <: T_prod B1 B2 ]].
Proof.
  unfold open_subtype;
    repeat step.
  apply reducible_prod_subtype_subst with (erase_type A1) (erase_type A2) x (erase_context Γ);
    repeat step;
    side_conditions.

  unshelve epose proof (H8 ρ l0 _ _ _ v0 _);
    repeat step || erase_open.
Qed.

Lemma annotated_subtype_prod2:
  forall Θ Γ T A B x,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv B) ->
    ~(x ∈ fv A) ->
    ~(x ∈ fv T) ->
    ~(x ∈ Θ) ->
    is_annotated_type B ->
    wf B 1 ->
    subset (fv B) (support Γ) ->
    [[ Θ; (x,T) :: Γ ⊨ pi1 (fvar x term_var) : A ]] ->
    [[ Θ; (x,T) :: Γ ⊨ pi2 (fvar x term_var) : open 0 B (pi1 (fvar x term_var)) ]] ->
    [[ Θ; Γ ⊨ T  <: T_prod A B ]].
Proof.
  unfold open_subtype; repeat step.

  apply subtype_prod2 with (erase_context Γ) (erase_type T) x;
    repeat step || erase_open;
    side_conditions.
Qed.


(** Examples of (mutual) nested fixpoints *)
From ConCert.Extraction Require Import Loader.
From Coq Require Import Arith.
From Coq Require Import Bool.
From Coq Require Import Extraction.
From Coq Require Import List.
From Coq Require Import Program.

Fixpoint ack (n m : nat) : nat :=
match n with
| O => S m
| S p => let fix ackn (m : nat) :=
          match m with
          | O => ack p 1
          | S q => ack p (ackn q)
          end
        in ackn m
end.

(** Mutual fixpoints are extracted as mutual internal fixpoints with closure allocation *)
Fixpoint even n :=
  match n with
  | O => true
  | S m => odd m
  end
  with odd n :=
    match n with
    | O => false
    | S k => even k
    end.

Definition even_odd (n : nat) : bool := even n.

From ConCert.Extraction Require Import ExtrRustBasic.
From ConCert.Extraction Require Import ExtrRustUncheckedArith.

Redirect "../tests/extracted-code/rust-extract/Ack.rs" ConCert Extract ack.
Redirect "../tests/extracted-code/rust-extract/Even.rs" ConCert Extract even.


Require Import
  MathClasses.theory.categories MathClasses.interfaces.abstract_algebra MathClasses.interfaces.functors.

Section constant_functor.
  Context `{Category A} `{Category B}.
  Context (b:B).

  Notation F := (const b: A → B).
  Global Instance: Fmap F := λ _ _ _, cat_id.

  Global Instance: ∀ a a' : A, Setoid_Morphism (fmap F : (a ⟶ a') → (F a ⟶ F a')).
  Proof.
    intros; constructor; try apply _.
    now intros ? ? ?.
  Qed.

  Global Instance ConstantFunctor : Functor F (λ _ _ _, cat_id).
  Proof.
    split; try apply _.
     reflexivity.
    intros; symmetry; compute; apply left_identity.
  Qed.
End constant_functor.

Typeclasses Transparent const.

Section constant_transformation.
  Context `{Category A} `{Category J}.
  Context {a a' : A}.

  Global Instance constant_transformation {f : a⟶a'} : NaturalTransformation (const f : J → _).
  Proof. intros ? ? ?. now rewrite left_identity, right_identity. Qed.
End constant_transformation.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Optimizer.AbstractMap.
Require Import Optimizer.Machine.
Require Import Optimizer.System.
Require Import Optimizer.Util.Deciders.
Require Import Optimizer.Util.ListUtil.
Import ListNotations.
Local Open Scope Z_scope.
Import Machine.Machine.

Section MachineProofs.
  Context `{instrt : instr_impl}.
  Existing Instance reg_mapt. Existing Instance flag_mapt.
  Existing Instance reg_enum. Existing Instance flag_enum.
  Hint Resolve instr_eq_dec reg_eq_dec : deciders.

  Lemma valid_context_range ctx r :
    valid_context ctx ->
    0 <= get ctx r < 2 ^ (register_size r).
  Proof. auto. Qed.

  Definition valid_dec p : {valid p} + {~ valid p}.
  Proof.
    induction p;
      repeat match goal with
             | |- context [valid (Instr ?i ?rd ?args _)] =>
               progress
                 (match goal with
                  | H : context [precondition i rd args] |- _ =>
                    idtac
                  | _ => destruct (precondition_dec i rd args)
                  end)
             | _ => destruct IHp
             | _ => left; constructor; solve [auto]
             | _ => right; inversion 1; tauto
             end.
  Defined.

  Definition valid_context_dec (ctx : map register Z) :
    {valid_context ctx} + {~ (valid_context ctx)}.
  Proof.
    cbv [valid_context].
    apply dec_forall with (enum:=enum); [ solve [auto with deciders] | | ].
    { intro r.
      destruct (Z_le_dec 0 (get ctx r)); [| right; lia].
      destruct (Z_lt_dec (get ctx r) (2^(register_size r)));
        [left | right]; lia. }
    { intro r; specialize (enum_complete r); tauto. }
  Defined.
  Hint Resolve valid_context_dec : deciders.

  Definition arg_eq_dec (a1 a2 : register + Z) : {a1 = a2} + {a1 <> a2}.
  Proof. destruct a1, a2; try (right; congruence); f_equal_dec. Defined.
  Hint Resolve arg_eq_dec : deciders.

  Definition program_eq_dec :
    forall p1 p2 : program, {p1 = p2} + {p1 <> p2}.
  Proof. induction p1; destruct p2; try (right; congruence); f_equal_dec. Defined.

  Section with_context_enumerators.
    Context (valid_contexts : list (map register Z))
            (valid_contexts_complete : forall ctx, valid_context ctx -> In ctx valid_contexts)
            (fctx_enum : enumerator (map flag bool)).
    Context (context_eq_dec : forall ctx1 ctx2 : map register Z, {ctx1 = ctx2} + {ctx1 <> ctx2})
            (flag_context_eq_dec : forall fctx1 fctx2 : map flag bool, {fctx1 = fctx2} + {fctx1 <> fctx2}).
    Hint Resolve context_eq_dec flag_context_eq_dec : deciders.

    Definition equiv_dec p1 p2 : {equivalent p1 p2} + {~ (equivalent p1 p2)}.
    Proof.
      repeat match goal with
             | _ => progress (intros; cbv [equivalent])
             | |- {forall (_ : ?A), _} + {~ (forall (_ : ?A), _)} =>
               apply dec_forall with (enum:=enum)
             | |- {forall (_ : ?A), _} + {~ (forall (_ : ?A), _)} =>
               apply dec_forall with (enum:=valid_contexts)
             | H : ~ In ?x ?ls |- _ => assert (In x ls) by auto using enum_complete; tauto
             | _ => tauto
             | _ => solve [apply enum_complete]
             | |- { _ } + { _ } => solve [auto using dec_imp with deciders]
             end.
    Qed.
  End with_context_enumerators.
End MachineProofs.
Hint Resolve valid_dec valid_context_dec arg_eq_dec program_eq_dec equiv_dec : deciders.

Ltac pose_valid_context_range :=
  match goal with
  | H : valid_context ?ctx |- context [get ?ctx ?r] =>
    progress (match goal with
              | _ : 0 <= get ctx r < _ |- _ => idtac
              | _ =>
                let H':= fresh in pose proof (valid_context_range ctx r H) as H'; autounfold in H'
              end)
  end.
Ltac inversion_valid :=
  match goal with
  | H : Machine.valid (Instr ?i ?rd ?args ?cont) |- _ =>
    inversion H; clear H;
    try match goal with H' : ?x = i |- _ => subst x end;
    try match goal with H' : ?x = rd |- _ => subst x end;
    try match goal with H' : ?x = args |- _ => subst x end;
    try match goal with H' : ?x = cont |- _ => subst x end
  end; list_cleanup.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model UNIPROC+SCA *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition sm := unknown_relation "sm".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition si := sm.
Definition sca := irreflexive (co ⋅ (si ⋅ (co ⋅ si))).
Definition sca_0 := irreflexive (rf ⋅ (si ⋅ (fr ⋅ si))).
Definition uniproc := acyclic (po_loc ⊔ (rf ⊔ (fr ⊔ co))).
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := sca /\ (sca_0 /\ uniproc).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc sm tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos cobase coi coe fr fri fre si sca sca_0 uniproc witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model UNIPROC+SCA *)


Require Export desargues3Dlemmas.

Module Desargues3D (DecPoints: FSetInterface.WS) (M: RankProjectiveSpace DecPoints).

Export M.

Module Export Desargues3DLemmas := Desargues3DLemmas DecPoints M.

Section Desargues_general.

(** Hypotheses *)

Variables a b c : Point.
Variables A B C : Point.
Variables alpha beta gamma : Point.
Variables O : Point.

Variable raAO : rk(triple a A O)=2.
Variable rbBO : rk(triple b B O)=2.
Variable rcCO : rk(triple c C O)=2.
Variable rABC : rk(triple A B C)=3.
Variable rabc : rk(triple a b c)=3.

Variable rABCabc : rk(union (triple A B C) (triple a b c))>=4. (* not coplanar *)

Variable rABgamma : rk(triple A B gamma)=2.
Variable rabgamma : rk(triple a b gamma)=2.

Variable rACbeta : rk(triple A C beta)=2.
Variable racbeta : rk(triple a c beta)=2.

Variable rBCalpha : rk(triple B C alpha)=2.
Variable rbcalpha : rk(triple b c alpha) =2.

Definition ps : set_of_points := triple a b c.
Definition Ps : set_of_points := triple A B C.

Variable raA : rk(couple a A)=2.
Variable rcC : rk(couple c C)=2.
Variable rbB : rk(couple b B)=2.

Lemma a_not_alpha :rk(couple a alpha) =2. (* contradicts hyp rabc *)
Proof.
apply rk_couple1.
intro H;rewrite H in *;clear H.
setoid_replace (triple alpha b c) with (triple b c alpha) in rabc by fsetdecide.
rewrite rabc in rbcalpha; omega.
Qed.

Lemma a_not_gamma :rk(couple a gamma) =2 \/ rk (triple gamma alpha beta) = 2.
Proof.
apply (a_not_gamma_scheme a b c A B C alpha beta gamma O); try assumption.
Qed.

Lemma c_not_beta : rk(couple c beta) = 2 \/ rk (triple beta gamma alpha)=2.
Proof.
apply (a_not_gamma_scheme c a b C A B gamma alpha beta O); try assumption.
setoid_replace (triple C A B) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple c a b) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple C A B) with (triple A B C) by fsetdecide.
setoid_replace (triple c a b) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple C A beta) with (triple A C beta) by fsetdecide; assumption.
setoid_replace (triple c a beta) with (triple a c beta) by fsetdecide; assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by fsetdecide; assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by fsetdecide; assumption.
Qed.

Lemma b_not_gamma : rk(couple b gamma) = 2 \/ rk (triple gamma beta alpha)=2.
Proof.
apply (a_not_gamma_scheme b a c B A C beta alpha gamma O); try assumption.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple b a c) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide.
setoid_replace (triple b a c) with  (triple a b c) by fsetdecide; assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide; assumption.
setoid_replace (triple b a gamma) with( triple a b gamma) by fsetdecide; assumption.
Qed.

Hint Resolve  a_not_alpha a_not_gamma c_not_beta b_not_gamma : rk.

Lemma A_not_alpha  : rk(couple A alpha) =2.
Proof.
apply rk_couple1.
intro H;rewrite H in *;clear H.
setoid_replace (triple alpha B C) with (triple B C alpha) in rABC by fsetdecide.
rewrite rABC in rBCalpha; omega.
Qed.

Lemma B_not_beta :rk(couple B beta) =2.
Proof.
apply rk_couple1.
intro H;rewrite H in *;clear H.
setoid_replace (triple A beta C) with (triple A C beta) in rABC by fsetdecide.
rewrite rABC in rACbeta; omega.
Qed.

Lemma C_not_gamma :rk(couple C gamma) =2.
Proof.
apply rk_couple1.
intro H;rewrite H in *;clear H.
omega.
Qed.

Lemma A_not_beta  : rk(couple A beta) =2\/rk(triple alpha beta gamma)=2.
Proof.
eapply (A_not_beta_scheme a b c A B C alpha beta gamma O); try assumption.
Qed.

Lemma A_not_gamma :rk(couple A gamma) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple alpha gamma beta) by fsetdecide.
apply (A_not_beta_scheme a c b A C B alpha gamma beta O); try assumption.
setoid_replace (triple A C B) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple a c b) with (triple  a b c) by fsetdecide; assumption.
setoid_replace (triple A C B) with (triple A B C) by fsetdecide.
setoid_replace  (triple a c b) with (triple a b c)  by fsetdecide; assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by fsetdecide;assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by fsetdecide; assumption.
Qed.

Lemma B_not_alpha :rk(couple B alpha) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple beta alpha gamma)  by fsetdecide.
apply (A_not_beta_scheme b a c B A C beta alpha gamma O); try assumption.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple b a c) with (triple  a b c) by fsetdecide; assumption.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide.
setoid_replace (triple b a c) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide; assumption.
setoid_replace (triple b a gamma) with (triple a b gamma) by fsetdecide; assumption.
Qed.

Lemma B_not_gamma:rk(couple B gamma) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple beta gamma alpha) by fsetdecide.
apply (A_not_beta_scheme b c a B C A beta gamma alpha O); try assumption.
setoid_replace (triple B C A) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple b c a) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple B C A) with (triple A B C) by fsetdecide.
setoid_replace (triple b c a)  with  (triple a b c)  by fsetdecide; assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide; assumption.
setoid_replace (triple b a gamma) with (triple a b gamma) by fsetdecide; assumption.
setoid_replace (triple C A beta) with (triple A C beta) by fsetdecide; assumption.
setoid_replace (triple c a beta) with (triple a c beta) by fsetdecide; assumption.
Qed.

Lemma C_not_alpha :rk(couple C alpha) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple gamma alpha beta) by fsetdecide.
apply (A_not_beta_scheme c a b C A B gamma alpha beta O); try assumption.
setoid_replace (triple C A B) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple c a b) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple C A B) with (triple A B C) by fsetdecide.
setoid_replace (triple c a b) with (triple a b c)  by fsetdecide; assumption.
setoid_replace (triple C A beta) with (triple A C beta) by fsetdecide;assumption.
setoid_replace (triple c a beta) with (triple a c beta) by fsetdecide;assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by fsetdecide;assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by fsetdecide;assumption.
Qed.

Lemma C_not_beta :rk(couple C beta) =2\/rk(triple alpha beta gamma)=2.
Proof.
setoid_replace (triple alpha beta gamma) with (triple gamma beta alpha) by fsetdecide.
apply (A_not_beta_scheme c b a C B A gamma beta alpha O) ; try assumption.
setoid_replace (triple C B A) with (triple A B C) by fsetdecide; assumption.
setoid_replace (triple c b a) with (triple a b c) by fsetdecide; assumption.
setoid_replace (triple C B A) with (triple A B C) by fsetdecide.
setoid_replace  (triple c b a) with (triple a b c)  by fsetdecide; assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by fsetdecide;assumption.
setoid_replace (triple c b alpha) with (triple b c alpha) by fsetdecide;assumption.
setoid_replace (triple C A beta) with (triple A C beta) by fsetdecide;assumption.
setoid_replace (triple c a beta) with (triple a c beta) by fsetdecide;assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide;assumption.
setoid_replace (triple b a gamma) with (triple a b gamma) by fsetdecide;assumption.
Qed.

(* these 6 lemmas (above) contradict coplanarity hyp rABCabc or lead to rk(alpha,beta,gamma)=2 *)

Hint Resolve A_not_alpha B_not_beta C_not_gamma
 A_not_beta A_not_gamma B_not_alpha B_not_gamma
C_not_alpha C_not_beta.

Lemma rAB :  rk(couple A B)=2.
Proof.
eauto with rk.
Qed.

Lemma rBC : rk(couple B C)=2.
Proof.
eauto with rk.
Qed.

Lemma rAC : rk(couple A C)=2.
Proof.
eauto with rk.
Qed.

Lemma rab : rk(couple a b)=2.
Proof.
eauto with rk.
Qed.

Lemma rac : rk(couple a c)=2.
Proof.
eauto with rk.
Qed.

Lemma rbc : rk(couple b c)=2.
Proof.
eauto with rk.
Qed.

Lemma L1alpha : rk(union Ps (singleton alpha))=3.
Proof.
unfold Ps.
eapply (rk_triple_singleton).
intuition.
Qed.

Lemma L1palpha:rk(union ps (singleton alpha)) = 3.
Proof.
unfold ps.
eapply (rk_triple_singleton).
intuition.
Qed.

Lemma L1Pbeta : rk(union Ps (singleton beta))=3.
Proof.
apply  L1beta_gen;auto.
Qed.

Lemma L1pbeta : rk(union ps (singleton beta))=3.
Proof.
apply  L1beta_gen;auto.
Qed.

Lemma L1Pgamma : rk(union Ps (singleton gamma))=3.
Proof.
apply  L1gamma_gen;auto.
Qed.

Lemma L1pgamma : rk(union ps (singleton gamma))=3.
Proof.
apply  L1gamma_gen;auto.
Qed.

Lemma ralphabeta : rk(couple alpha beta)=2\/rk(triple alpha beta gamma)=2.
Proof.
classical_left.
rename H into HnotDes.
apply le_antisym.
auto with rk.
assert (rk (couple alpha beta) = 0 \/ rk (couple alpha beta) =1 \/ rk (couple alpha beta) >= 2).
omega.
elim H;intro.
simplify_rk.

elim H0;intro.
assert (rk (couple c beta) = 2 \/ rk (triple beta gamma alpha) = 2).
apply c_not_beta.
elim H2;intro c_not_beta_local.
2:setoid_replace (triple beta gamma alpha)  with (triple alpha beta gamma)
in c_not_beta_local  by fsetdecide;omega.
simplify_rk.
rewrite H3 in *; clear H3.
assert  (T:= (col_trans a b c beta racbeta rbcalpha c_not_beta_local)).
omega.
omega.
Qed.

Lemma ralphagamma : rk(couple alpha gamma)=2\/rk(triple alpha beta gamma)=2.
Proof.
classical_left.
rename H into HnotDes.
apply le_antisym.
auto with rk.
assert (rk (couple alpha gamma) = 0 \/ rk (couple alpha gamma) =1 \/ rk (couple alpha gamma) >= 2).
omega.

elim H;intro.
simplify_rk.

elim H0;intro.
assert (rk (couple b gamma) = 2 \/ rk (triple gamma beta alpha) = 2).
apply b_not_gamma.
elim H2;intro b_not_gamma_local.
2:setoid_replace (triple gamma beta alpha)  with (triple alpha beta gamma)
in b_not_gamma_local  by fsetdecide;omega.
simplify_rk.
rewrite H3 in *; clear H3.
setoid_replace (triple b c gamma) with (triple c b gamma) in rbcalpha by fsetdecide.
assert  (T:= (col_trans a c b gamma rabgamma rbcalpha b_not_gamma_local)).
setoid_replace (triple a b c) with (triple a c b) in rabc by fsetdecide.
omega.
omega.
Qed.

Lemma rbetagamma : rk(couple beta gamma)=2 \/ rk (triple alpha beta gamma) = 2.
Proof.
classical_left.
rename H into HnotDes.
apply le_antisym.
auto with rk.
assert (rk (couple beta gamma) = 0 \/ rk (couple beta gamma) =1 \/ rk (couple beta gamma) >= 2).
omega.

elim H;intro.
simplify_rk.
elim H0;intro.

assert (rk (couple a gamma) = 2 \/ rk (triple gamma alpha beta) = 2).
apply a_not_gamma.
elim H2;intro a_not_gamma_local.
2:setoid_replace (triple gamma alpha beta) with (triple alpha beta gamma)
in a_not_gamma_local  by fsetdecide;omega.
simplify_rk.
rewrite H3 in *; clear H3.
setoid_replace (triple a c gamma) with (triple c a gamma) in racbeta by fsetdecide.
setoid_replace (triple a b gamma) with (triple b a gamma) in rabgamma by fsetdecide.
assert (rk (triple c b a) <= 2) by (apply (col_trans  c b a gamma racbeta rabgamma a_not_gamma_local)).
setoid_replace (triple a b c) with (triple c b a) in rabc by fsetdecide.
omega.
omega.
Qed.

Lemma L2P : rk(union Ps (triple alpha beta gamma))=3 \/  rk (triple alpha beta gamma) = 2.
Proof.
classical_left.
rename H into HnotDes.
apply le_antisym.

(* >= *)
assert (rk (union Ps (couple alpha beta)) <= 3).

generalize (matroid3 (union Ps (singleton alpha)) (union Ps (singleton beta))).
rewrite L1alpha.
rewrite L1Pbeta.
setoid_replace (inter (union Ps (singleton alpha)) (union Ps (singleton beta))) with Ps.
unfold Ps at 3; rewrite rABC.

setoid_replace (union (union Ps (singleton alpha)) (union Ps (singleton beta))) with (union Ps (couple alpha beta)).
omega.
fsetdecide_no_hyps.
unfold Ps.
assert (~ alpha [==] beta).
generalize ralphabeta.
intro.
elim H;intros;clear H.
apply couple_rk1;auto.
intuition.
solve [auto with hset].

generalize (matroid3 (union Ps (couple alpha beta)) (union Ps (singleton gamma))).

setoid_replace (union (union Ps (couple alpha beta)) (union Ps (singleton gamma))) with
                        (union Ps (triple alpha beta gamma)) by fsetdecide_no_hyps.

setoid_replace (inter (union Ps (couple alpha beta)) (union Ps (singleton gamma))) with Ps.
rewrite L1Pgamma.
unfold Ps at 2.
rewrite rABC.
omega.
unfold Ps.
assert (~ alpha [==] gamma).
generalize ralphagamma.
intro.
elim H0;intro; clear H0.
apply couple_rk1;auto.
intuition.
assert (~ beta [==] gamma).
generalize rbetagamma.
intro.
elim H1;intro; clear H1.
apply couple_rk1;auto.
intuition.
solve [auto with hset].
(* <= *)
assert (Hsubset : (Subset (union Ps (couple alpha beta)) (union Ps (triple alpha beta gamma))))
by fsetdecide_no_hyps.
apply le_trans with (rk (union Ps (couple alpha beta))).
2:apply (matroid2 (union Ps (couple alpha beta)) (union Ps (triple alpha beta gamma)) Hsubset).
assert (Hsubset' : Subset (union Ps (singleton alpha)) (union Ps (couple alpha beta))) by fsetdecide_no_hyps.
apply le_trans with (rk (union Ps (singleton alpha))).
2: apply (matroid2 (union Ps (singleton alpha)) (union Ps (couple alpha beta)) Hsubset').
rewrite L1alpha.
auto with arith.
Qed.

Lemma  L2p : rk(union ps (triple alpha beta gamma))=3 \/ rk (triple alpha beta gamma) = 2.
Proof.
classical_left.
rename H into HnotDes.
apply le_antisym.
(*<=*)
assert (rk(union ps (couple alpha beta)) <=3).
generalize (matroid3 (union ps (singleton alpha)) (union ps (singleton beta))).
rewrite L1palpha.
rewrite L1pbeta.
setoid_replace (union(union ps (singleton alpha))(union ps (singleton beta)))
with (union ps (couple alpha beta)).
2:fsetdecide_no_hyps.
setoid_replace (inter (union ps (singleton alpha))(union ps (singleton beta)))
                        with ps.
unfold ps.
rewrite rabc.
omega.
assert (~ alpha [==] beta).
generalize (ralphabeta).
intros.
elim H; intros;clear H.
apply couple_rk1;auto.
intuition.
solve [auto with hset].

generalize (matroid3 (union ps(couple alpha beta))(union ps(singleton gamma))).
rewrite L1pgamma.
setoid_replace (union(union ps (couple alpha beta))(union ps (singleton gamma)))
                with (union ps(triple alpha beta gamma)) by fsetdecide_no_hyps.

assert (~ alpha [==] gamma).
  generalize (ralphagamma).
  intros.
  elim H; intros;clear H.
  apply couple_rk1;auto.
  intuition.
  auto.

assert (~ beta [==] gamma).
   generalize (rbetagamma).
   intros.
   elim H; intros;clear H.
   apply couple_rk1;auto.
   intuition.
   auto.

setoid_replace (inter (union ps(couple alpha beta))(union ps (singleton gamma)))
                        with ps by (solve [auto with hset]).

unfold ps at 2.
rewrite rabc.
omega.

(*>=*)

assert (Hsubset : (Subset (union ps (couple alpha beta)) (union ps (triple alpha beta gamma))) )
by fsetdecide_no_hyps.
apply le_trans with (rk(union ps (couple alpha beta))).
Focus 2.
apply (matroid2 (union ps (couple alpha beta))(union ps (triple alpha beta gamma))).
assumption.

assert (Hsubset' : (Subset (union ps (singleton alpha)) (union ps (couple alpha beta))) )
by fsetdecide_no_hyps.
generalize (matroid2 (union ps (singleton alpha)) (union ps (couple alpha beta))).
rewrite L1palpha.
auto with arith.
Qed.

Lemma rPpalbega :
  rk (union Ps (union ps (triple alpha beta gamma))) >= 4 \/ rk (triple alpha beta gamma) = 2.
Proof.
classical_left.
rename H into HnotDes.
assert(Hsubset:Subset (union Ps ps) (union Ps(union ps(triple alpha beta gamma))) )
by (unfold Ps, ps;fsetdecide_no_hyps).
generalize (matroid2 (union Ps ps) (union Ps(union ps (triple alpha beta gamma))) Hsubset).
unfold Ps,ps.
omega.
Qed.

Ltac unfold_p := unfold Ps, ps.

Theorem Desargues_general : rk (triple alpha beta gamma) <= 2.
Proof.
assert (T: rk
         (union (union Ps (triple alpha beta gamma))
            (union ps (triple alpha beta gamma))) +
       rk (triple alpha beta gamma) <=
       rk (union Ps (triple alpha beta gamma)) +
       rk (union ps (triple alpha beta gamma))).
apply (matroid3_useful (union Ps (triple alpha beta gamma))
                                    (union ps (triple alpha beta gamma))
                                    (triple alpha beta gamma)).
fsetdecide.
setoid_replace (union (union Ps (triple alpha beta gamma))
     (union ps (triple alpha beta gamma))) with (union Ps (union ps (triple alpha beta gamma)))
     in T by (unfold Equal; split; fsetdecide_no_hyps).
assert (rk (union Ps (union ps (triple alpha beta gamma))) >= 4 \/
       rk (triple alpha beta gamma) = 2).
apply rPpalbega.
elim H;intro.
rename H0 into HrPpalbega.
2:omega.
assert (rk (union ps (triple alpha beta gamma)) = 3 \/
       rk (triple alpha beta gamma) = 2).
apply L2p.
elim H0;intro.
rename H1 into HL2p.
2:omega.
rewrite HL2p in T.
assert ( rk (union Ps (triple alpha beta gamma)) = 3 \/
       rk (triple alpha beta gamma) = 2).
apply L2P.
elim H1;intro.
rename H2 into HL2P.
2:omega.
rewrite HL2P in T.
omega.
Qed.

End Desargues_general.

End Desargues3D.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import Utils.utils Code.subcode.

Set Implicit Arguments.

Reserved Notation "ρ '//' r '-1>' s" (at level 70, no associativity).
Reserved Notation "P '//' r ':1>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '-[' n ']->' s" (at level 70, no associativity, format "P  //  r  -[ n ]->  s").
Reserved Notation "P '//' r '-+>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '->>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '-]]' s" (at level 70, no associativity).
Reserved Notation "P '//' r '~~>' s" (at level 70, no associativity).
Reserved Notation "P '//' r '~[' n ']~>' s" (at level 70, no associativity, format "P  //  r  ~[ n ]~>  s").
Reserved Notation "P '//' r ↓" (at level 70, no associativity).

(* Intented meaning of notations

  ρ // r -1> s :      execution of instruction ρ changes state r into state s
  P // r :1> s :      execution of ONE instruction in P changes state r into state s            (one step)
  P // r -[n]-> s :   execution of n instructions in P changes state r into state s             (n steps)
  P // r -+> s :      execution of at least one instruction in P changes state r into state s   (progress)
  P // r ->> s :      execution of some instructions in P changes state r into state s          (compute)
  P // r -]] s :      maximal execution in P  (not really used, ~~> prefered below)
  P // r ~~> s :      execution of some instructions in P until s is outside of P
                           (stronger than -]] below if semantics is not total)                  (output)
  P // r ~[n]~> s :   execution of n instructions in P and then s is outside of P
  P // r ↓ :          termination on a state outside of P
                           NOT identical to termination for non-total semantics                 (terminates)

  see ./compiler_correction.v for typical use of these notations
*)

Section Small_Step_Semantics.

  (* * Code
      A generic library to implement Small Step Semantics on programs described
      by lists of instructions that modify a state and a Program Counter (PC)

      An important part of the library is devoted to show locality lemmas
      that related computation inside sub-programs to outer programs

      This is ESSENTIAL to be able to show properties compositionally,
      ie to derive properties of program from properties of sub-programs
   *)

  (* ** Syntax *)

  Variable (instr : Set) (data : Type).

  (* A state contain the PC (current instruction) and data *)

  Notation state := (nat * data)%type.

  Variable one_step : instr -> state -> state -> Prop.

  Notation "i // s -1> t" := (one_step i s t) (at level 70, no associativity).
  Notation "s ⟬ i ⦒  t" := (one_step i s t) (at level 70, no associativity).

  Hypothesis (sss_fun : forall i s t1 t2, i // s -1> t1 -> i // s -1> t2 -> t1 = t2).
  Hypothesis (sss_dec : forall i st1 st2, { i // st1 -1> st2 } + { ~ i // st1 -1> st2 }).

  (* A code is a contiguous list of instructions starting at some position *)

  Notation code := (nat * list instr)%type.

  (* ** Semantics *)

  (* This a one step computation *)

  Definition sss_step P st1 st2 := exists k l i r d, P = (k,l++i::r)
                                                  /\ st1 = (k+length l,d)
                                                  /\ i // st1 -1> st2.

  Notation "P // r :1> s" := (sss_step P r s)  (at level 70, no associativity).

  (* Functionality of one step computations *)

  Fact sss_step_fun P s t1 t2 : P // s :1> t1 -> P // s :1> t2 -> t1 = t2.
  Proof using sss_fun.
    intros (k1 & l1 & i1 & r1 & d1 & ? & ? & H1)
           (k2 & l2 & i2 & r2 & d2 & ? & ? & H2).
    subst.
    inversion H3.
    inversion H4.
    subst k2.
    apply list_app_inj in H5; try lia.
    destruct H5 as (? & H5); inversion H5.
    subst.
    revert H1 H2; apply sss_fun.
  Qed.

  (* A "more general/usable" constructor *)

  Fact in_sss_step k l i r st1 st2 : fst st1 = k+length l
                               ->       i     // st1  -1>  st2
                               -> (k,l++i::r) // st1  :1>  st2.
  Proof. destruct st1 as (j,d); simpl; intro; subst; exists k,l,i,r,d; auto. Qed.

  (* A destructor *)

  Fact sss_step_subcode_inv P ii st st' :
        (fst st, ii::nil) <sc P -> P // st :1> st' -> ii // st -1> st'.
  Proof.
    intros H1 (k & l2 & jj & r2 & d1 & H3 & H4 & H5); subst P st.
    destruct H1 as (l1 & r1 & H1 & H2).
    simpl in H1, H2.
    apply list_app_inj in H1; try lia.
    destruct H1 as (? & H1); subst l2.
    inversion H1; subst jj r2; auto.
  Qed.

  Fact sss_step_supcode P Q st st' :
       P <sc Q -> in_code (fst st) P -> Q // st :1> st' -> P // st :1> st'.
  Proof.
    intros H1 H2 (k & l & ii & r & d & ? & ? & H3); subst.
    destruct P as (iP,cP).
    destruct H1 as (ll & rr & H1 & H4).
    simpl in H2.
    symmetry in H1.
    apply list_app_cons_eq_inv in H1.
    destruct H1 as [ (m & G1 & G2) | (m & G1 & G2) ].
    2: apply f_equal with (f := @length _) in G1;
       exfalso; revert G1; rew length; intro; lia.
    apply list_app_cons_eq_inv in G2.
    destruct G2 as [ (p & G3 & G4) | (p & G3 & G4) ].
    subst; exfalso; revert H2; rew length; intro; lia.
    subst.
    apply in_sss_step; auto.
    revert H2; rew length; simpl; intro; lia.
  Qed.

  (* sss_step is decidable *)

  Fact sss_step_dec P st1 st2 : { P // st1 :1> st2 } + { ~ P // st1 :1> st2 }.
  Proof using sss_fun sss_dec.
    destruct st1 as (j,d).
    destruct P as (k,ll).
    destruct (le_lt_dec k j) as [ H1 | H1 ].
    + destruct (le_lt_dec (S j) (k+length ll)) as [ H2 | H2 ].
      * destruct (@list_pick _ ll (j-k)) as (i & l & r & ? & ?).
        - lia.
        - assert (j = k+length l) by lia; subst.
          destruct (sss_dec i (k+length l,d) st2) as [ | C ].
          ++ left; apply in_sss_step; auto.
          ++ right; contradict C.
             destruct C as (k1 & l1 & i1 & r1 & d1 & H3 & H4 & H5).
             inversion H3; subst.
             inversion H4; subst.
             apply list_app_inj in H7 as (-> & H7); try lia.
             inversion H7; subst; auto.
      * right; intros (k1 & l1 & i1 & r1 & d1 & H3 & H4 & H5).
        inversion H3; subst.
        inversion H4; subst.
        rewrite app_length in H2; simpl in H2; lia.
    + right; intros (k1 & l1 & i1 & r1 & d1 & H3 & H4 & H5).
      inversion H3; subst.
      inversion H4; subst.
      lia.
  Qed.

  (* This is a n steps computation *)

  Inductive sss_steps (P : code) : nat -> state -> state -> Prop :=
    | in_sss_steps_0 : forall st,                  P // st   -[0]->    st
    | in_sss_steps_S : forall n st1 st2 st3,       P // st1   :1>      st2
                                              ->   P // st2  -[n]->    st3
                                              ->   P // st1  -[S n]->  st3
  where "P // r -[ n ]-> s" := (sss_steps P n r s).

  (* More usable constructors *)

  Fact sss_steps_0 P st1 st2 : st1 = st2 -> P // st1 -[0]-> st2.
  Proof. intros []; constructor. Qed.

  Fact sss_steps_1 P st1 st2 : P // st1 :1> st2 -> P // st1 -[1]-> st2.
  Proof.
    constructor 2 with st2; auto.
    constructor 1.
  Qed.

  Fact sss_steps_trans P n m st1 st2 st3 :
         P // st1 -[n]-> st2 -> P // st2 -[m]-> st3 -> P // st1 -[n+m]-> st3 .
  Proof.
    intros H; revert H st3.
    induction 1 as [ | ? ? st2 ]; simpl; intros; auto.
    constructor 2 with st2; auto.
  Qed.

  (* Inversion lemma *)

  Fact sss_steps_0_inv P st1 st2 : P // st1 -[0]-> st2 -> st1 = st2.
  Proof. inversion 1; auto. Qed.

  Fact sss_steps_S_inv P st1 st3 k :
                        st1 <> st3
      ->                P // st1 -[k]-> st3
      -> exists k' st2, k = S k'
                     /\ P // st1 :1> st2
                     /\ P // st2 -[k']-> st3.
  Proof.
    intros H.
    inversion 1; subst.
    destruct H; auto.
    exists n, st2; auto.
  Qed.

  Fact sss_steps_inv P k st1 st3 :
          P // st1 -[k]-> st3
       -> (k = 0 /\ st1 = st3)
        + { k' | exists st2, k = S k'
                       /\ P // st1 :1> st2
                       /\ P // st2 -[k']-> st3 }%type.
  Proof.
    intros H.
    destruct k as [ | k ]; [ left | right ].
    apply sss_steps_0_inv in H; auto.
    exists k.
    inversion H; subst.
    exists st2; auto.
  Qed.

  Fact sss_steps_S_inv' P st1 st3 k :
                        P // st1 -[S k]-> st3
      -> exists st2,    P // st1 :1> st2
                     /\ P // st2 -[k]-> st3.
  Proof.
    intros H.
    inversion H; subst.
    exists st2; auto.
  Qed.

  Fact sss_steps_fun P k s t1 t2 :
         P // s -[k]-> t1
      -> P // s -[k]-> t2
      -> t1 = t2.
  Proof using sss_fun.
    intros H; revert H t2; induction 1 as [ | ? ? st2 ? H1 H2 IH2 ]; simpl; intros t2 Ht2; auto.
    inversion Ht2; auto.
    inversion Ht2; subst.
    generalize (sss_step_fun H1 H0); intro; subst.
    apply IH2 in H3; auto.
  Qed.

  Fact sss_steps_plus_inv P n m st1 st3 :
         P // st1 -[n+m]-> st3
      -> exists st2, P // st1 -[n]-> st2
                  /\ P // st2 -[m]-> st3.
  Proof.
    revert st1 st3; induction n as [ | n IHn ]; intros s t.
    exists s; split; auto; constructor.
    inversion 1; subst.
    apply IHn in H2; destruct H2 as (st & ? & ?).
    exists st; split; auto.
    constructor 2 with st2; auto.
  Qed.

  Definition sss_progress P st1 st2 := exists k, 0 < k /\ P // st1 -[k]-> st2.
  Definition sss_compute  P st1 st2 := exists k, P // st1 -[k]-> st2.

  Notation "P // r -+> s" := (sss_progress P r s).
  Notation "P // r ->> s" := (sss_compute P r s).

  Fact sss_progress_compute P st1 st2 : P // st1 -+> st2 -> P // st1 ->> st2.
  Proof. intros (k & _ & ?); exists k; auto. Qed.

  Fact sss_compute_trans P st1 st2 st3 : P // st1 ->> st2 -> P // st2 ->> st3 -> P // st1 ->> st3.
  Proof. intros (i & H1) (j & H2); exists (i+j); revert H1 H2; apply sss_steps_trans. Qed.

  Fact sss_progress_compute_trans P st1 st2 st3 : P // st1 -+> st2 -> P // st2 ->> st3 -> P // st1 -+> st3.
  Proof. intros (i & ? & H1) (j & H2); exists (i+j); split; try lia; revert H1 H2; apply sss_steps_trans. Qed.

  Fact sss_compute_progress_trans P st1 st2 st3 : P // st1 ->> st2 -> P // st2 -+> st3 -> P // st1 -+> st3.
  Proof. intros (i & H1) (j & ? & H2); exists (i+j); split; try lia; revert H1 H2; apply sss_steps_trans. Qed.

  Fact sss_progress_trans P st1 st2 st3 : P // st1 -+> st2 -> P // st2 -+> st3 -> P // st1 -+> st3.
  Proof. intro; apply sss_compute_progress_trans, sss_progress_compute; trivial. Qed.

  (* Computations must start inside code *)

  Fact sss_step_in_code P st1 st2 : P // st1 :1> st2 -> in_code (fst st1) P.
  Proof.
    revert P st1 st2; intros (n,c) (i,d) st2 (q & l & ii & r & d1 & H1 & H2 & _).
    inversion H1; subst.
    inversion H2; subst.
    simpl; rew length; lia.
  Qed.

  Fact sss_steps_compute P n st1 st2 : P // st1 -[n]-> st2 -> P // st1 ->> st2.
  Proof. exists n; trivial. Qed.

  (* We propose a library of locality lemmas that link computations
      in subcode to computations in the code *)

  (* ** Compisitional Reasoning over Subcode *)

  (* First inclusions lemmas *)

  Fact subcode_sss_step P Q st1 st2: P <sc Q -> P // st1 :1> st2 -> Q // st1 :1> st2.
  Proof.
    destruct P as (n1,c1).
    destruct Q as (n2,c2).
    simpl.
    intros (l & r & H1 & H2) H3.
    destruct H3 as (q & ll & i & rr & d1 & H3 & H4 & H5).
    inversion H3; subst.
    exists n2, (l++ll), i, (rr++r), d1; repeat split; auto.
    f_equal; solve list eq.
    f_equal; rew length; lia.
  Qed.

  Fact subcode_sss_steps P Q k st1 st2: P <sc Q -> P // st1 -[k]-> st2 -> Q // st1 -[k]-> st2.
  Proof.
    induction 2 as [ | k st1 st2 st3 H3 H4 IH4 ].
    constructor.
    constructor 2 with st2; auto.
    revert H3; apply subcode_sss_step; auto.
  Qed.

  Fact subcode_sss_progress P Q st1 st2: P <sc Q -> P // st1 -+> st2 -> Q // st1 -+> st2.
  Proof.
    intros ? (k & ? & Hk); exists k; split; auto; revert Hk; apply subcode_sss_steps; auto.
  Qed.

  Fact subcode_sss_compute P Q st1 st2: P <sc Q -> P // st1 ->> st2 -> Q // st1 ->> st2.
  Proof.
    intros ? (k & Hk); exists k; revert Hk; apply subcode_sss_steps; auto.
  Qed.

  Fact subcode_sss_compute_trans P Q st1 st2 st3 :
       P <sc Q -> P // st1 ->> st2 -> Q // st2 ->> st3 -> Q // st1 ->> st3.
  Proof.
    intros ? H.
    apply sss_compute_trans.
    revert H; apply subcode_sss_compute; auto.
  Qed.

  Fact subcode_sss_compute_linstr k li P st1 st2 st :
            (fst st1,li) // st1 -[k]-> st2
         -> (fst st1,li) <sc P
         -> P // st2 ->> st
         -> P // st1 ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H2).
    exists k; auto.
  Qed.

  Fact subcode_sss_compute_instr P i st1 st2 st3 :
            i // st1 -1> st2
        ->  (fst st1,i::nil) <sc P
        ->  P // st2 ->> st3
        ->  P // st1 ->> st3.
  Proof.
    intro H; apply subcode_sss_compute_linstr with (k := 1).
    apply sss_steps_1, in_sss_step with (l := nil); auto.
  Qed.

  (* Then are reverse inclusion lemmas *)

  Fact subcode_sss_step_inv P Q st1 st2 :
         P <sc Q
      -> in_code (fst st1) P
      -> Q // st1 :1> st2
      -> P // st1 :1> st2.
  Proof.
    revert P Q st1 st2; intros (nP,cP) (nQ,cQ) (i,d) st; simpl.
    intros (l & r & H1 & H2) H3 (q & ll & ii & rr & d1 & H4 & H5 & H6).
    inversion H4; subst.
    inversion H5; subst.
    clear H4 H5.
    apply list_app_cons_eq_inv in H7.
    destruct H7 as [ (m & Hm1 & Hm2) | (m & Hm1 & Hm2) ].
    apply list_app_cons_eq_inv in Hm2.
    destruct Hm2 as [ (p & Hp1 & Hp2) | (p & Hp1 & Hp2) ].
    + apply f_equal with (f := @length _) in Hm1.
      apply f_equal with (f := @length _) in Hp1.
      revert Hm1 Hp1; rew length; intros; lia.
    + subst cP; apply in_sss_step; auto.
      simpl; subst; rew length; lia.
    + apply f_equal with (f := @length _) in Hm1.
      apply f_equal with (f := @length _) in Hm2.
      revert Hm1 Hm2; rew length; intros; lia.
  Qed.

  Definition sss_output P st st' := P // st ->> st' /\ out_code (fst st') P.

  Notation "P // x ~~> y" := (sss_output P x y).
  Notation "P // r ~[ n ]~> s" := (P // r -[n]-> s /\ out_code (fst s) P).

  Definition sss_terminates P st := exists st', P // st ~~> st'.

  Notation "P // x ↓" := (sss_terminates P x).

  Fact subcode_sss_terminates_instr P i st1 st2 :
            i // st1 -1> st2
        ->  (fst st1,i::nil) <sc P
        ->  P // st2 ↓
        ->  P // st1 ↓.
  Proof.
    intros H1 H2 (st3 & H3 & H4).
    exists st3; split; auto.
    revert H1 H2 H3; apply subcode_sss_compute_instr.
  Qed.

  (* No computation is possible *)

  Definition sss_stall ii st := forall st', ~ ii // st -1> st'.
  Definition sss_step_stall P st := forall st', ~ P // st :1> st'.

  Fact sss_steps_stall_inv P p s1 s2 : sss_step_stall P s1 -> P // s1 -[p]-> s2 -> p = 0 /\ s1 = s2.
  Proof.
    intros H; induction 1 as [ | p st1 st2 st3 H1 ]; auto.
    apply H in H1; destruct H1.
  Qed.

  Fact sss_steps_stall_fun P p q s1 s2 :
         sss_step_stall P s2
      -> P // s1 -[p]-> s2
      -> P // s1 -[q]-> s2
      -> p = q.
  Proof using sss_fun.
    intros H1 H2; revert H2 q.
    induction 1 as [ s1 | p s1 s2 s3 H2 H3 IH3 ];
      intros q H5.
    apply sss_steps_stall_inv, proj1 in H5; auto.
    destruct q.
    apply sss_steps_0_inv in H5; subst.
    apply H1 in H2; destruct H2.
    specialize (IH3 H1).
    apply sss_steps_S_inv' in H5.
    destruct H5 as (st2' & H5 & H6).
    generalize (sss_step_fun H2 H5).
    intros; subst st2'.
    apply IH3 in H6; subst; auto.
  Qed.

  Definition sss_compute_max P s1 s2 := (P // s1 ->> s2 /\ sss_step_stall P s2).

  Notation " P // s1 -]] s2 " := (sss_compute_max P s1 s2).

  (* No computation outside the code *)

  Fact sss_out_step_stall P st : out_code (fst st) P -> sss_step_stall P st.
  Proof.
    revert P st; intros (n,code) (i,st).
    intros H1 st' (k & l & ii & r & d1 & H2 & H3 & H4).
    inversion H2; inversion H3; subst.
    simpl in H1.
    revert H1; rew length; intros []; lia.
  Qed.

  Fact sss_stall_step_stall ii P st :
          (fst st,ii::nil) <sc P
       -> sss_stall ii st
       -> sss_step_stall P st.
  Proof.
    intros H1 H2 st' H.
    apply sss_step_subcode_inv  with (1 := H1) in H.
    revert H; apply H2.
  Qed.

  Fact sss_stall_step_0 ii P q st st' :
          (fst st,ii::nil) <sc P
       -> sss_stall ii st
       -> P // st -[q]-> st' -> q = 0 /\ st = st'.
  Proof.
    intros H1 H2.
    generalize (sss_stall_step_stall H1 H2).
    intros H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ | (k & st2 & _ & H5 & _) ]; auto.
    contradict H5; apply H3.
  Qed.

  Fact sss_step_stall_inv P st :
          sss_step_stall P st
       -> { ii | (fst st,ii::nil) <sc P /\ sss_stall ii st }
        + { out_code (fst st) P }.
  Proof.
    intros H.
    destruct (in_out_code_dec (fst st) P) as [ H1 | H1 ].
    2: tauto.
    destruct P as (iP,cP).
    destruct st as (j,d).
    simpl in H1.
    destruct (@list_pick _ cP (j-iP)) as (ii & l & r & H2 & H3).
    lia.
    left; exists ii; simpl; split.
    exists l, r; split; auto; lia.
    intros st' H4.
    apply (H st').
    subst; apply in_sss_step; auto.
    simpl; lia.
  Qed.

  Fact sss_steps_stall k P st st' :
         out_code (fst st) P
      -> P // st -[k]-> st'
      -> k = 0 /\ st = st'.
  Proof.
    destruct P; simpl.
    intros H1 H2.
    apply sss_steps_inv in H2.
    destruct H2 as [ (? & ?) | (m & st2 & ? & H2 & _) ]; auto.
    apply sss_out_step_stall in H2; try red; tauto.
  Qed.

  (* This is a critical lemma about the locality of computations

      If P is subcode of Q and a computation in Q starts in P and ends outside of P,
      then it is decomposed in a first computation in P ending outside of P
      and a second computation in Q

    *)

  Lemma subcode_sss_steps_inv P Q k st1 st3 :
       P <sc Q
    -> in_code  (fst st1) P
    -> out_code (fst st3) P
    -> Q // st1 -[k]-> st3
    -> exists k1 k2 st2,
          P // st1 -[k1]-> st2
       /\ Q // st2 -[k2]-> st3
       /\ k = k1+k2
       /\ out_code (fst st2) P.
  Proof.
    intros H1 H2 H3 H4; revert H4 H2 H3.
    induction 1 as [ st1 | k st1 st2 st3 H4 H5 IH5 ]; intros H2 H3.

    exists 0, 0, st1; repeat split; auto; constructor.

    apply subcode_sss_step_inv with (1 := H1) in H4; auto.
    destruct (in_out_code_dec (fst st2) P) as [ H6 | H6 ].

    destruct (IH5 H6 H3) as (k1 & k2 & st & ? & ? & ? & ?).
    exists (S k1), k2, st; repeat split; auto.
    constructor 2 with (1 := H4); auto.
    lia.

    exists 1, k, st2; repeat split; auto.
    apply sss_steps_1; auto.
  Qed.

  Lemma subcode_sss_compute_inv P Q st1 st3 :
       P <sc Q
    -> out_code (fst st3) P
    -> Q // st1 ->> st3
    -> exists st2,
          P // st1 ->> st2
       /\ Q // st2 ->> st3
       /\ out_code (fst st2) P.
  Proof.
    intros H1 H3 (k & Hk).
    destruct (in_out_code_dec (fst st1) P) as [ H2 | H2 ].
    + apply subcode_sss_steps_inv with (1 := H1) in Hk; auto.
      destruct Hk as (k1 & k2 & st2 & H4 & H5 & H6 & H7).
      exists st2; repeat split; auto; red; firstorder.
    + exists st1; repeat split; auto.
      * exists 0; constructor.
      * red; firstorder.
  Qed.

  (* Inversion lemma *)

  Fact subcode_sss_step_inv_1 P i st1 st2 : (fst st1,i::nil) <sc P -> P // st1 :1> st2 -> i // st1 -1> st2.
  Proof.
    revert P st1; intros (j,cj) (n,d) H1 H2.
    apply subcode_sss_step_inv with (1 := H1) in H2.
    2: simpl; lia.
    destruct H2 as (q & l & ii & r & d1 & H2 & H3 & H4).
    inversion H3; subst n d1; auto.
    eq goal H4; f_equal.
    inversion H2.
    destruct l as [ | ? [ | ] ]; try discriminate.
    inversion H5; subst; auto.
  Qed.

  (* Starting a computation in subcode ending outside of it
     can be cut in half *)

  Fact subcode_sss_subcode_inv P Q p k st1 st2 st3 :
           out_code (fst st3) P
        -> P <sc Q
        -> P // st1 -[p]-> st2
        -> Q // st1 -[k]-> st3
        -> exists q, k = p+q /\ Q // st2 -[q]-> st3.
  Proof using sss_fun.
    revert P Q st3; intros P (j,cj) (n,d) H1 H2 H3.
    simpl in H1.
    revert k.
    induction H3 as [ st | p st1 st2 st3 H4 H5 IH5 ];
      intros k Hk.
    exists k; auto.
    apply sss_steps_inv in Hk.
    destruct Hk as [ (? & Hk) | (m & st4 & ? & Hk & H3) ].
    1: subst st1; apply sss_step_in_code in H4; simpl in H4; lia.
    apply subcode_sss_step with (1 := H2) in H4.
    rewrite (sss_step_fun Hk H4) in H3.
    apply IH5 in H3; auto.
    destruct H3 as (q & ? & H3).
    exists q; split; auto; lia.
  Qed.

  Fact subcode_sss_terminates_inv P Q st st1 :
           Q // st ↓
        -> P <sc Q
        -> P // st ~~> st1
        -> Q // st1 ↓.
  Proof using sss_fun.
    intros (st3 & (k & H1) & H2) H3 ((p & H4) & H5).
    destruct subcode_sss_subcode_inv with (2 := H3) (3 := H4) (4 := H1)
      as (q & _ & H6).
    1: revert H2; apply subcode_out_code; auto.
    exists st3; split; auto; exists q; auto.
  Qed.

  Fact subcode_sss_progress_inv P Q p st1 st2 st3 :
           out_code (fst st3) P
        -> P <sc Q
        -> P // st1 -+> st2
        -> Q // st1 -[p]-> st3
        -> exists q, q < p /\ Q // st2 -[q]-> st3.
  Proof using sss_fun.
    intros H1 H2 (k & ? & H3) H4.
    apply subcode_sss_subcode_inv with (3 := H3) in H4; auto.
    destruct H4 as (q & ? & ?); exists q; split; auto; lia.
  Qed.

  Section sss_compute_max_ind.

    Variable (P : code) (R : state -> state -> Prop).

    Hypothesis (HQ0 : forall st, sss_step_stall P st -> R st st)
               (HQ1 : forall st1 st3, (forall Q st2, Q <sc P -> Q // st1 -+> st2 -> P // st2 -]] st3 -> R st2 st3) -> R st1 st3).

    Theorem sss_compute_max_ind st1 st3 : P // st1 -]] st3 -> R st1 st3.
    Proof using sss_fun HQ0 HQ1.
      intros ((k & H1) & H2); revert st1 H1.
      induction k as [ k IH ] using (well_founded_induction_type lt_wf).
      intros st1 H1.
      destruct k as [ | k ].
      apply sss_steps_0_inv in H1.
      subst; apply HQ0; auto.
      apply HQ1.
      intros Q st2' HQ H5 ((q & H6) & _).
      apply subcode_sss_progress with (1 := HQ) in H5.
      destruct H5 as (l & Hl & H5).
      generalize (sss_steps_trans H5 H6); intro H7.
      generalize (sss_steps_stall_fun H2 H1 H7); intros H8.
      apply IH with q; auto; lia.
    Qed.

  End sss_compute_max_ind.

  Hint Resolve subcode_refl : core.

  Fact sss_compute_inv P st1 st2 st3 :
             out_code (fst st3) P
          -> P // st1 ->> st2
          -> P // st1 ->> st3
          -> P // st2 ->> st3.
  Proof using sss_fun.
    intros H2 (p & H3) (k & H4).
    apply subcode_sss_subcode_inv with (3 := H3) in H4; auto.
    destruct H4 as (q & _ & ?); exists q; auto.
  Qed.

  Section sss_terminates_ind.

  Variable (P : code) (R : state -> Prop).

  Hypothesis (HR0 : forall st, out_code (fst st) P -> R st)
             (HR1 : forall st1, (forall Q st2, Q <sc P -> Q // st1 -+> st2 -> R st2) -> R st1).

  Theorem sss_terminates_ind st : P // st ↓ -> R st.
  Proof using sss_fun HR0 HR1.
    intros (st2 & (k & H1) & H2); revert st st2 H1 H2.
    induction k as [ k IH ] using (well_founded_induction_type lt_wf).
    intros st1 st2 H1 H2.
    destruct k as [ | k ].
    + apply sss_steps_0_inv in H1.
      subst; apply HR0; auto.
    + apply HR1.
      intros Q st2' HQ H5.
      assert (P // st2' ↓) as (st3 & H6 & H7).
      { assert (P // st1 ↓) as (st3' & H'6 & H'7).
        { exists st2. split; [exists (S k)|]; assumption. }
        apply (subcode_sss_progress _ HQ) in H5.
        apply (sss_progress_compute) in H5.
        assert (H8 := sss_compute_inv H'7 H5 H'6).
        exists st3'. split; assumption. }
      apply subcode_sss_progress_inv with (3 := H5) in H1; auto.
      destruct H1 as (q & G1 & G2).
      apply IH with (2 := G2); auto.
      revert H2; apply subcode_out_code; auto.
  Qed.

  End sss_terminates_ind.

  Fact sss_compute_step_out_inv P k st1 st2 st3 :
           st1 <> st2
        -> out_code (fst st3) P
        -> P // st1 ->> st2
        -> P // st1 -[k]-> st3
        -> exists q, q < k /\ P // st2 -[q]-> st3.
  Proof using sss_fun.
    intros H1 H2 (p & H3) H4.
    apply subcode_sss_subcode_inv with (3 := H3) in H4; auto.
    destruct H4 as (q & H4 & H5).
    exists q; split; auto.
    destruct p; try lia.
    apply sss_steps_0_inv in H3.
    destruct H1; auto.
  Qed.

  Fact subcode_sss_subcode_compute_inv P Q k st1 st2 st3 :
           in_code (fst st1) P
        -> out_code (fst st2) P
        -> out_code (fst st3) P
        -> P <sc Q
        -> P // st1 ->> st2
        -> Q // st1 -[k]-> st3
        -> exists q, q < k /\ Q // st2 -[q]-> st3.
  Proof using sss_fun.
    intros H H0 H1 H2 (p & H3) H4.
    apply subcode_sss_subcode_inv with (2 := H2) (3 := H3) in H4; auto.
    destruct H4 as (q & Hq & H4).
    exists q; split; auto.
    destruct p; try lia.
    apply sss_steps_0_inv in H3; subst st2.
    red in H, H0; lia.
  Qed.

  Fact subcode_sss_steps_inv_1 P i k st1 st2 st3 :
        st1 <> st3
     -> i // st1 -1> st2
     -> (fst st1,i::nil) <sc P
     -> P // st1 -[k]-> st3
     -> exists k', k = S k' /\ P // st2 -[k']-> st3.
  Proof using sss_fun.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (_ & H4) | (k' & st & ? & H4 & ?) ].
    contradict H1; auto.
    exists k'; split; auto.
    apply subcode_sss_step_inv_1 with (1 := H3) in H4.
    rewrite (sss_fun H2 H4); auto.
  Qed.

  Fact subcode_sss_steps_stop P i k st1 st2 :
            (forall st, ~ i // st1 -1> st)
        ->  (fst st1,i::nil) <sc P
        ->  P // st1 -[k]-> st2 -> k = 0 /\ st1 = st2.
  Proof.
    intros H1 H2 H3.
    apply sss_steps_inv in H3.
    destruct H3 as [ | (k' & st & ? & H3 & H4) ]; auto; exfalso.
    apply (H1 st), subcode_sss_step_inv_1 with (1 := H2); auto.
  Qed.

  Fact sss_steps_stop P k st1 st2 :
             out_code (fst st1) P
          -> P // st1 -[k]-> st2
          -> st1 = st2.
  Proof.
    intros H1 H2.
    apply sss_steps_inv in H2.
    destruct H2 as [ [ _ ? ] | (k' & st3 & H2 & H3 & H4) ]; auto.
    destruct (sss_out_step_stall H1 H3).
  Qed.

  Fact sss_compute_stop P st1 st2 :
             out_code (fst st1) P
          -> P // st1 ->> st2
          -> st1 = st2.
  Proof.
    intros H1 (k & H2); revert H2; apply sss_steps_stop; auto.
  Qed.

  Fact sss_steps_stop_fun P a b st1 st2 st3 :
             out_code (fst st2) P
          -> out_code (fst st3) P
          -> P // st1 -[a]-> st2
          -> P // st1 -[b]-> st3
          -> a = b /\ st2 = st3.
  Proof using sss_fun.
    intros H1 H2 H3 H4.
    assert (a = b) as Hab.
    { destruct subcode_sss_subcode_inv with (3 := H3) (4 := H4)
        as (u & Hu & _); auto.
      destruct subcode_sss_subcode_inv with (3 := H4) (4 := H3)
        as (v & Hv & _); auto.
      lia. }
    split; auto; subst b.
    revert H3 H4; apply sss_steps_fun.
  Qed.

  Fact sss_compute_fun P st1 st2 st3 :
             out_code (fst st2) P
          -> out_code (fst st3) P
          -> P // st1 ->> st2
          -> P // st1 ->> st3
          -> st2 = st3.
  Proof using sss_fun.
    intros ? ? (a & H1) (b & H2).
    revert H1 H2; apply sss_steps_stop_fun; auto.
  Qed.

  Fact sss_steps_output_fun P a b st1 st2 st3 :
             P // st1 ~[a]~> st2
          -> P // st1 ~[b]~> st3
          -> a = b /\ st2 = st3.
  Proof using sss_fun.
    intros (H1 & H2) (H3 & H4).
    revert H1 H3; apply sss_steps_stop_fun; auto.
  Qed.

  Fact sss_output_fun P st st1 st2 : P // st ~~> st1 -> P // st ~~> st2 -> st1 = st2.
  Proof using sss_fun.
    intros (H1 & H2) (H3 & H4); revert H2 H4 H1 H3; apply sss_compute_fun.
  Qed.

  Fact subcode_sss_terminates P Q st : P <sc Q -> Q // st ↓ -> P // st ↓.
  Proof.
    intros H (st' & H1 & H2).
    apply subcode_sss_compute_inv with (1 := H) in H1; auto.
    + destruct H1 as (st2 & H1 & H3 & H4).
      exists st2; split; auto.
    + revert H2; apply subcode_out_code; auto.
  Qed.

  Fact sss_progress_non_termination P st : P // st -+> st -> ~ P // st ↓.
  Proof using sss_fun.
    intros (a & H1 & H2) (st' & (b & H3) & H4).
    assert (P // st -[a+b]-> st') as H5.
    { apply sss_steps_trans with (1 := H2); auto. }
    destruct sss_steps_stop_fun with (3 := H3) (4 := H5); auto; lia.
  Qed.

  Section sss_loop.

    (* P contains a loop that modifies the data (in a way computable by f)
       when condition C1 is satisfied and otherwise stops somewhere outside
       of P when condition C2 is satisfied.

       Then P stops iff exists n, C2 (iter f x n) *)

    Variable (P : code) (pre : data -> Prop) (spec : data -> data -> Prop)
             (f : data -> data) (Hf : forall x, x <> f x)
             (C1 C2 : data -> Prop) (HC : forall x, pre x -> { C1 x } + { C2 x })
             (i : nat) (p : nat) (Hp : out_code p P)
             (HP1 : forall x, pre x -> C1 x -> P // (i,x) ->> (i,f x) /\ pre (f x))
             (HP2 : forall x, pre x -> C2 x -> exists y, P // (i,x) ->> (p,y) /\ spec x y).

    Theorem sss_loop_sound x : pre x
                            -> (exists n, C2 (iter f x n))
                            -> exists n y, P // (i,x) ->> (p,y) /\ spec (iter f x n) y.
    Proof using HP1 HP2 HC.
      intros H (n & Hn); revert x H Hn.
      induction n as [ | n IHn ]; intros x Hx Hn.
      simpl; exists 0; apply HP2; auto.
      destruct (HC Hx) as [ H | H ].
      apply IHn in Hn.
      destruct Hn as (m & y & H1 & H2).
      exists (S m), y; split; auto.
      generalize H1; apply sss_compute_trans.
      apply HP1; auto.
      apply HP1; auto.
      destruct (HP2 Hx) as (y & H1 & H2); auto.
      exists 0, y; auto.
    Qed.

    Theorem sss_loop_complete x y q : pre x
                                   -> out_code q P
                                   -> P // (i,x) ->> (q,y)
                                   -> p = q /\ exists n, C2 (iter f x n) /\ spec (iter f x n) y.
    Proof using sss_fun HP1 HP2 HC Hp Hf.
      intros Hx Hq (k & Hk); revert x Hx y q Hq Hk.
      induction k as [ k IHk ] using (well_founded_induction lt_wf); intros x Hx y q Hq Hk.
      destruct (HC Hx) as [ H | H ].
      * apply HP1 in H; auto; destruct H as [ H1 H2 ].
        destruct (@sss_compute_step_out_inv P k (i,x) (i,f x) (q,y))
          as (k' & H3 & H4); auto.
        { inversion 1 as [ H3 ]; revert H3; apply Hf. }
        destruct IHk with (2 := H2) (4 := H4) as (E & n & Hn); auto.
        split; auto; exists (S n); auto.
      * destruct HP2 with (2 := H) as (z & Hz & Hy); auto.
        apply ex_intro with (x := k) in Hk.
        generalize (@sss_compute_fun _ _ (p,z) (q,y) Hp Hq Hz Hk).
        inversion 1; subst; auto.
        split; auto.
        exists 0; simpl; auto.
    Qed.

  End sss_loop.

End Small_Step_Semantics.

(*
Notation " P '//' r ':1>' s " := (sss_step _ P r s)  (at level 70, no associativity).
Notation " P '//' r '-[' n ']->' s " := (sss_steps _ P n r s) (at level 70, no associativity).
Notation " P '//' r '->>' s " := (sss_compute _ P r s) (at level 70, no associativity).
*)