Require Import Ast.
Require Import ch2o.prelude.stringmap.
Require Import ch2o.prelude.base.
Require Import ch2o.prelude.list.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Sumbool.
Require Import pigeon.
Require Import common.

Definition subtype_cap (sub super: ecap) :=
  match sub, super with
  | cap_iso_eph, cap_iso_eph => Some ()
  | cap_iso, cap_iso => Some ()
  | cap_trn_eph, cap_trn_eph => Some ()
  | cap_trn, cap_trn => Some ()
  | cap_ref, cap_ref => Some ()
  | cap_val, cap_val => Some ()
  | cap_box, cap_box => Some ()
  | cap_tag, cap_tag => Some ()

  | cap_iso_eph, _ => Some ()

  | cap_trn_eph, cap_trn => Some ()
  | cap_trn_eph, cap_ref => Some ()
  | cap_trn_eph, cap_val => Some ()
  | cap_trn_eph, cap_box => Some ()

  | cap_trn, cap_box => Some ()
  | cap_ref, cap_box => Some ()
  | cap_val, cap_box => Some ()

  | _, cap_tag => Some ()

  | _, _ => None
  end.

Record Subtyping : Type := {
  subtype_ty' : ty -> ty -> option unit;
  subtype_structural' : string -> string -> option unit;
}.

Definition assumes_wf (P: program) (assumes: list (string * string)) : Prop :=
  ch2o.prelude.base.NoDup assumes ∧ Forall (λ a, a ∈ (P, P)) assumes.

Program Fixpoint subtyping (P: program) (assumes: list (string * string) | assumes_wf P assumes)
    {measure (size (P,P) - size (assumes: list (string * string)))} : Subtyping :=

  let fix subclass (maxdepth: nat) (sub_name: string) (super_name: string) : option unit :=
    let fix subtype_nominal (is: list string) :=
      match maxdepth, is with
      | S maxdepth', i::is' =>
          match subclass maxdepth' i super_name with
          | Some () => Some ()
          | None => subtype_nominal is'
          end
      | O, _ => None
      | _, nil => None
      end
    in

    match decide (elem_of (sub_name, super_name) (assumes: list (string * string))) with
    | left _ => Some ()
    | right HnotElem =>
        is <- lookup_Is P sub_name;

        if string_beq sub_name super_name
        then Some () else

        if decide (is_Some (subtype_nominal is))
        then Some () else

        if lookup_is_interface P super_name
        then
          if decide (is_Some (lookup_P P sub_name) ∧ is_Some (lookup_P P super_name))
          then
            let assumes' := ((sub_name, super_name)::assumes) in
            subtype_structural' (subtyping P assumes') sub_name super_name
          else None
        else None
    end
  in

  let subtype_ty (sub_ty: ty) (super_ty: ty) :=
    match sub_ty, super_ty with
    | ty_name name_sub cap_sub, ty_name name_super cap_super =>
        _ <- subclass 100 name_sub name_super;
        subtype_cap cap_sub cap_super

    | ty_null, _ => Some ()
    | _, ty_null => None
    end
  in

  let fix subtype_args (sub_args: list (string * ty)) (super_args: list (string * ty)) :=
    match sub_args, super_args with
    | nil, nil => Some ()
    | (_, sub_arg_ty)::sub_args', (_, super_arg_ty)::super_args' =>
        _ <- subtype_ty sub_arg_ty super_arg_ty;
        subtype_args sub_args' super_args'
    | _, _ => None
    end
  in

  let subtype_method (sub_method: func_stub) (super_method: func_stub) : option unit :=
    let '(_, (sub_recv, sub_args, sub_retty)) := sub_method in
    let '(_, (super_recv, super_args, super_retty)) := super_method in

    _ <- subtype_cap sub_recv super_recv;  (* Covariant receiver capability *)
    _ <- subtype_args super_args sub_args; (* Contravariant arguments *)
    _ <- subtype_ty sub_retty super_retty; (* Covariant return type *)
    Some ()
  in

  let subtype_structural (sub_name: string) (super_name: string) : option unit :=
    sub_ms <- lookup_Ms P 100 sub_name;
    super_ms <- lookup_Ms P 100 super_name;

    _ <- mapM (λ m, m' <- sub_ms !! (fst m); subtype_method (fst m, m') m) super_ms;

    Some ()
  in

  {|
      subtype_ty' := subtype_ty;
      subtype_structural' := subtype_structural;
  |}.

Next Obligation.
unfold assumes_wf.
destruct H2.
split.
+ apply NoDup_cons_2.
  exact HnotElem.
  exact H2.
+ apply Forall_cons.
  unfold elem_of, collection_cross_elem.
  - split.
    * apply lookup_P_is_some_elem_of2.
      auto.
    * apply lookup_P_is_some_elem_of2.
      auto.
  - exact H3.
Defined.

Next Obligation.
destruct H2.
assert ((size ((sub_name, super_name)::assumes)) <= size (P, P)).

apply pigeonhole.
+ apply NoDup_cons_2.
  exact HnotElem.
  exact H2.
+ apply Forall_cons.
  unfold elem_of, collection_cross_elem.
  - split.
    * apply lookup_P_is_some_elem_of2.
      auto.
    * apply lookup_P_is_some_elem_of2.
      auto.
  - exact H3.
+
unfold size, list_size, Datatypes.length, collection_cross_size in H4.
fold (Datatypes.length assumes) in H4.

unfold size, list_size, Datatypes.length, collection_cross_size.
fold (Datatypes.length assumes).
fold (size P).

omega.

Defined.

Next Obligation.
split.
intros.
unfold not.
intros.
destruct H1.
auto with *.
unfold not.
intros.
destruct H1.
auto with *.
Defined.

Next Obligation.
split.
intros.
unfold not.
intros.
destruct H3.
auto with *.
unfold not.
intros.
destruct H3.
auto with *.
Defined.

Program Definition subtyping' (P: program) : Subtyping := subtyping P nil.
Next Obligation.
unfold assumes_wf.
split.
apply NoDup_nil_2.
apply Forall_nil.
Qed.

Definition subtype_ty P := subtype_ty' (subtyping' P).
Definition subtype_structural P := subtype_structural' (subtyping' P).


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import Reals mathcomp.ssreflect.ssreflect Psatz Omega.
Require Import Hierarchy PSeries Rbar Lim_seq.

(** This file describes an experiment: most 18-year old French
students pass an exam called Baccalaureate which ends the high school
and is required for attending the university. We took the 2013
mathematics test of the scientific Baccalaureate at the same time as
the students. The pdf of the test is available #here#. This file is dedicated
to the mathematics specialty exercise, done after the exam. *)

Open Scope R_scope.

(** * Bac 2013 - Exercice 4 spécialité *)

(** 1. Exprimer v (S n) et c (S n) en fonction de v n et c n *)

Fixpoint v (n : nat) : R :=
  match n with
  | O => 7 / 10 * 250000
  | S n => 95 / 100 * v n + 1 / 100 * c n
  end
with c (n : nat) : R :=
  match n with
  | O => 3 / 10 * 250000
  | S n => 5 / 100 * v n + 99 / 100 * c n
  end.

(** 2. Définition de la matrice A *)

Definition A : matrix 2 2 :=
  [[95/100, 1/100 ] ,
    [ 5/100, 99/100]].

Definition X (n : nat) : matrix 2 1 :=
  [[v n],[c n]].

Lemma Q2 : forall n, X (S n) = scal A (X n).
Proof.
  intros n.
  rewrite /scal /= /Mmult.
  apply (coeff_mat_ext 0).
  case ; [ | case => //].
  case ; [ | case => //] ;
  rewrite coeff_mat_bij /= ; (try omega) ;
  rewrite sum_Sn sum_O /plus /mult //=.
  case ; [ | case => //] ;
  rewrite coeff_mat_bij /= ; (try omega) ;
  rewrite sum_Sn sum_O /plus /mult //=.
Qed.

(** 3. Diagonalisation *)

Definition P : matrix 2 2 :=
  [[1,-1], [5,1]].
Definition Q : matrix 2 2 :=
  [[1,1],[-5,1]].

Goal mult P Q = [[6,0],[0,6]].
apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
rewrite coeff_mat_bij => //.
rewrite /coeff_mat /= /mult /plus /=.
(destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try ring) ;
(try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /= ; try ring) ;
rewrite sum_Sn sum_O /= /plus /= ; ring.
Qed.

Goal mult Q P = [[6,0],[0,6]].
apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
rewrite coeff_mat_bij => //.
rewrite /coeff_mat /= /mult /plus /=.
(destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try ring) ;
(try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /= ; try ring) ;
rewrite sum_Sn sum_O /= /plus /= ; ring.
Qed.

Definition P' : matrix 2 2 :=
  [[1 / 6,1 / 6],[-5 / 6,1 / 6]].

Lemma Q3a : mult P P' = Mone /\ mult P' P = Mone.
Proof.
  split.
  apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
  rewrite coeff_mat_bij => //.
  rewrite /coeff_mat /= /mult /plus /=.
  (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try field) ;
  (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
  rewrite sum_Sn sum_O /= /plus /= ; field.
  apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
  rewrite coeff_mat_bij => //.
  rewrite /coeff_mat /= /mult /plus /=.
  (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try field) ;
  (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
  rewrite sum_Sn sum_O /= /plus /= ; field.
Qed.

Definition D : matrix 2 2 := [[1,0],[0,94 / 100]].

Lemma Q3b : mult P' (mult A P) = D.
Proof.
  apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
  rewrite coeff_mat_bij => //.
  rewrite /coeff_mat /= /mult /plus /=.
  (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try field) ;
  (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
  rewrite sum_Sn sum_O /= /plus /= ; (try field) ;
  rewrite !sum_Sn !sum_O /= /plus /coeff_mat /= ; field.
Qed.

Lemma Q3c : forall n, pow_n A n = mult P (mult (pow_n D n) P').
Proof.
  elim => /= [ | n IH].
  rewrite mult_one_l.
  apply sym_eq, Q3a.
  by rewrite -{1}Q3b !mult_assoc (proj1 Q3a) mult_one_l -!mult_assoc IH.
Qed.

(** 4. Terme général et limite de la suite v n *)

Lemma Q4 : forall n, v n = 1 / 6 * (1 + 5 * (94 / 100) ^ n) * v 0
                         + 1 / 6 * (1 - (94 / 100) ^ n) * c 0.
Proof.
  intros n.
  assert (X n = scal (pow_n A n) (X 0)).
    elim: n => [ | n IH] /=.
    by rewrite scal_one.
    rewrite -scal_assoc -IH.
    by apply Q2.
  assert (pow_n D n = [[1,0], [0,(94 / 100)^n]]).
    elim: (n) => [ | m IH] //=.
    rewrite IH.
    apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
    rewrite coeff_mat_bij => //=.
    rewrite /plus /mult /= /coeff_mat /=.
    (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /one /=) ;
    (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
    rewrite sum_Sn sum_O /= /plus /= ; field.
  rewrite Q3c H0 in H.
  apply (proj1 (coeff_mat_ext 0 _ _)) with (i := O) (j := O) in H.
  rewrite {1}/coeff_mat /= in H.
  rewrite H ; repeat (rewrite !/coeff_mat /=).
  rewrite !sum_Sn !sum_O /= /plus /mult /= ; field.
Qed.

Lemma lim_v : is_lim_seq v (41666 + 2 / 3).
Proof.
  eapply is_lim_seq_ext.
  intros n ; apply sym_eq, Q4.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_mult.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  eapply is_lim_seq_plus.
  apply is_lim_seq_const.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq ; lra.
  by [].
  by [].
  by [].
  apply is_lim_seq_const.
  by [].
  eapply is_lim_seq_mult.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  eapply is_lim_seq_minus.
  apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq ; lra.
  by [].
  by [].
  apply is_lim_seq_const.
  by [].
  apply (f_equal (fun x => Some (Finite x))) ;
  simpl ; field.
Qed.

Lemma lim_c : is_lim_seq c (208333 + 1 / 3).
Proof.
  assert (forall n, c n = 250000 - v n).
    elim => [ | n /= ->] /= ; field.
  eapply is_lim_seq_ext.
  intros n ; apply sym_eq, H.
  eapply is_lim_seq_minus.
  apply is_lim_seq_const.
  by apply lim_v.
  apply (f_equal (fun x => Some (Finite x))) ;
  simpl ; field.
Qed.


Require Import FP.Structures.Injection.
Require Import FP.Structures.FUnit.
Require Import FP.Data.Function.

Import FunctionNotation.

Section Deriving_FUnit.
  Context {m:Type->Type}.
  Variable (n:Type->Type).
  Context {HFI_:HasFunctorInjection n m}.
  Context {FUnit_:FUnit n}.

  Definition deriving_funit {A} : A -> m A := finject '.' funit.

  Definition Deriving_FUnit : FUnit m :=
    {| funit := @deriving_funit |}.
End Deriving_FUnit.


Require Import Lia.
Require Export CFGloop.

Section cfg.
  Context `{C : redCFG}.

  Notation "p '-a>b' q" := (a_edge p q) (at level 55).
  Notation "p '-a>' q" := (p -a>b q = true) (at level 55).
  Notation "p '-->b' q" := (edge p q) (at level 55).
  Notation "p '-->' q" := (p -->b q = true) (at level 55, right associativity).

  (** * Loop ordering **)

  (** ** Loop ordering by relative depth **)

  Definition deq_loop q p : Prop :=
    forall h, loop_contains h p -> loop_contains h q.

  Global Instance deq_loop_dec h p : dec (deq_loop h p).
  eauto.
  Qed.

  (** ** Preorder properties of deq_loop **)

  (** Reflexivity **)

  Lemma deq_loop_refl l :
    deq_loop l l.
  Proof.
    unfold deq_loop;firstorder.
  Qed.

  Global Instance deq_loop_Reflexive : Reflexive deq_loop.
  Proof.
    unfold Reflexive. intros. eapply deq_loop_refl.
  Qed.

  (** ** Transitivity **)

  Lemma deq_loop_trans p q r
        (H1 : deq_loop p q)
        (H2 : deq_loop q r)
    : deq_loop p r.
  Proof.
    unfold deq_loop in *. intros. eapply H1,H2;eauto.
  Qed.

  Global Instance deq_loop_Transitive : Transitive deq_loop.
  Proof.
    unfold Transitive; eapply deq_loop_trans.
  Qed.

  Program Instance deq_loop_PreOrder : PreOrder deq_loop.

  (** ** deq_loop facts **)

  Lemma loop_contains_deq_loop h p
        (Hloop : loop_contains h p)
    : deq_loop p h.
  Proof.
    unfold deq_loop. intros. eapply loop_contains_trans;eauto.
  Qed.

  Lemma deq_loop_root p
    : deq_loop p root.
  Proof.
    unfold deq_loop.
    intros.
    exfalso.
    eapply root_loop_root in H as H'. subst.
    unfold loop_contains in H. destructH.
    eapply back_edge_incl in H0. eapply root_no_pred;eauto.
  Qed.

  Lemma exit_not_deq h p q
        (Hexit : exit_edge h p q)
        (Hdeq : deq_loop q h)
    : False.
  Proof.
    unfold exit_edge in Hexit. destructH.
    apply Hexit2.
    eapply Hdeq.
    eapply loop_contains_self. eapply loop_contains_loop_head;eauto.
  Qed.

  Lemma deq_loop_head_loop_contains p h
        (Hdeq : deq_loop p h)
        (Hhead : loop_head h)
    : loop_contains h p.
  Proof.
    eapply Hdeq.
    eapply loop_contains_self.
    eauto.
  Qed.

  Lemma deq_loop_depth p q
        (Hdeq : deq_loop p q)
    : depth q <= depth p.
  Proof.
    unfold depth.
    eapply NoDup_incl_length.
    - eapply NoDup_iff_dupfree.
      eapply dupfree_filter.
      eapply dupfree_elements.
    - intros x Hx.
      eapply in_filter_iff in Hx. cbn in Hx.
      eapply in_filter_iff. cbn. destruct Hx. split;auto.
  Qed.

  Lemma deq_loop_depth_leq p q
        (Hdeq : deq_loop p q)
        (Hdep : depth p <= depth q)
    : deq_loop q p.
  Proof.
    unfold depth in Hdep.
    eapply NoDup_length_incl in Hdep.
    - unfold incl in Hdep. setoid_rewrite in_filter_iff in Hdep. cbn in Hdep.
      intros a Ha. eapply Hdep;eauto.
    - eapply NoDup_iff_dupfree. eapply dupfree_filter. eapply dupfree_elements.
    - unfold incl. setoid_rewrite in_filter_iff. intros.
      cbn in *. destructH. eapply Hdeq in H1. eauto.
  Qed.

  Lemma deq_loop_depth_eq p q
        (Hdeq : deq_loop p q)
        (Hdep : depth q = depth p)
    : deq_loop q p.
  Proof.
    eapply deq_loop_depth_leq;eauto.
    lia.
  Qed.

  Lemma depth_zero_iff q
    : depth q = 0 <-> forall h, loop_contains h q -> False.
  Proof.
    unfold depth.
    rewrite length_zero_iff_nil.
    split;intros.
    - eapply filter_nil;eauto.
    - eapply list_emp_in. intros. intro N. eapply H.
      eapply in_filter_iff in N. destructH. cbn in N1. eauto.
  Qed.

  (** ** Equivalence relation eq_loop **)

  Definition eq_loop q p : Prop :=
    deq_loop q p /\ deq_loop p q.

  Lemma eq_loop1  p p' q
    : eq_loop p p' -> deq_loop p q -> deq_loop p' q.
  Proof.
    intros. destruct H.
    eapply deq_loop_trans;eauto.
  Qed.

  Lemma eq_loop2 p q q'
    : eq_loop q q' -> deq_loop p q -> deq_loop p q'.
  Proof.
    intros. destruct H.
    eapply deq_loop_trans;eauto.
  Qed.

  Global Instance eq_loop_Eq : Equivalence eq_loop.
  Proof.
    econstructor.
  - econstructor;apply deq_loop_refl.
  - econstructor; destruct H;eauto.
  - econstructor; destruct H,H0; eapply deq_loop_trans;eauto.
  Qed.

  Global Instance eq_loop_proper_deq_loop1 (p : Lab)
    : Proper (eq_loop ==> Basics.impl) ((Basics.flip deq_loop) p).
  Proof.
    unfold Proper, respectful, Basics.impl.
    intros. eapply eq_loop1; eauto.
  Qed.

  Global Instance eq_loop_proper_deq_loop2 (p : Lab) : Proper (eq_loop ==> Basics.impl) (deq_loop p).
  Proof.
    unfold Proper. unfold respectful. unfold Basics.impl.
    intros. eapply eq_loop2; eauto.
  Qed.

  Global Instance eq_loop_proper_contains (h : Lab)
    : Proper (eq_loop ==> iff) (loop_contains h).
  Proof.
    unfold Proper, respectful, Basics.impl.
    intros. split;eapply H.
  Qed.

  Global Instance eq_loop_depth
    : Proper (eq_loop ==> eq) depth.
  Proof.
    clear.
    unfold Proper,respectful. intros.
    destruct H.
    eapply deq_loop_depth in H.
    eapply deq_loop_depth in H0.
    lia.
  Qed.

  Lemma loop_head_eq_loop_eq h1 h2
        (Hloop1 : loop_head h1)
        (Hloop2 : loop_head h2)
        (Heq : eq_loop h1 h2)
    : h1 = h2.
  Proof.
    destruct Heq.
    eapply loop_contains_Antisymmetric;eauto.
    1: eapply H0.
    2: eapply H.
    1,2: eapply loop_contains_self;eauto.
  Qed.

  Lemma head_unique h b x y
        (Hh : loop_contains h x)
        (Hb : loop_contains b y)
        (Heq : eq_loop h b)
    : h = b.
  Proof.
    unfold eq_loop in Heq.
    unfold deq_loop in *.
    destruct Heq as [H1 H2].
    eapply loop_contains_Antisymmetric; eauto using loop_contains_loop_head, loop_contains_self.
  Qed.

  Lemma eq_loop_same (h h' : Lab)
        (Heq : eq_loop h h')
        (Hl : loop_head h)
        (Hl' : loop_head h')
    : h = h'.
  Proof.
    eapply loop_contains_Antisymmetric.
    all: unfold eq_loop,deq_loop in *;destructH;eauto using loop_contains_self.
  Qed.

  Definition basic_edge p q := eq_loop p q /\ a_edge__P p q.
  Definition eexit_edge p q := exists h, exit_edge h p q.

  Lemma basic_edge_eq_loop p q
        (Hedge : basic_edge p q)
    : eq_loop p q.
  Proof.
    destruct Hedge;auto.
  Qed.

  Lemma depth_basic p q
        (Hedge : basic_edge p q)
    : depth p = depth q.
  Proof.
    eapply basic_edge_eq_loop in Hedge.
    rewrite Hedge. reflexivity.
  Qed.

  Lemma back_edge_eq_loop (p h : Lab)
        (Hp : p ↪ h)
    : eq_loop p h.
  Proof.
    split.
    - eapply loop_contains_deq_loop. eapply loop_contains_ledge;eauto.
    - decide (deq_loop h p);[auto|exfalso]. unfold deq_loop in n. simpl_dec' n.
      simpl_dec' n. destructH. eapply no_exit_head.
      + unfold exit_edge. split_conj;eauto 1. eapply back_edge_incl;eauto.
      + eexists;eauto.
  Qed.

  Lemma depth_back p q
        (Hedge : p ↪ q)
    : depth p = depth q.
  Proof.
    eapply back_edge_eq_loop in Hedge.
    rewrite Hedge. reflexivity.
  Qed.
  Lemma deq_loop_entry (p q : Lab)
        (Hentry : entry_edge p q)
    : deq_loop q p.
  Proof.
    unfold entry_edge in Hentry.
    destructH.
    intros h Heq.
    assert (~ exit_edge h p q).
    - contradict Hentry0. eapply no_exit_head;eauto.
    - do 2 simpl_dec' H. destruct H as [H|[H|H]];[contradiction| |contradiction].
      eapply dec_DN;eauto.
  Qed.

  Lemma deq_loop_entry_or (p q : Lab)
        (Hentry : entry_edge p q)
    : forall h, loop_contains h q -> loop_contains h p \/ h = q.
  Proof.
    intros.
    decide (h = q);[right;auto|left].
    unfold loop_contains,entry_edge in *. destructH. destructH.
    exists p0, (π :r: p). split_conj;eauto.
    - eapply path_rcons;eauto.
    - rewrite rev_rcons. cbn. rewrite <-in_rev. eapply nin_tl_iff in H3;eauto.
      destruct H3;[eauto|]. destr_r' π;subst π;cbn in H. 1: inversion H2.
      path_simpl' H2.
      rewrite rev_rcons in H. cbn in H. inversion H. contradiction.
  Qed.

  Lemma depth_entry p q
        (Hentry : entry_edge p q)
    : S (depth p) = depth q.
  Proof.
    unfold depth.
    match goal with |- S (| ?l |) = | ?l' | => set (lp := l); set (lq := l') end.
    assert (lq =' (q :: lp)).
    {
      split.
      - intros h H. eapply deq_loop_entry_or in Hentry. destruct Hentry;[right|left].
        + eapply in_filter_iff in H. eapply in_filter_iff. destructH. cbn in *. split;eauto.
        + symmetry;eauto.
        + eapply in_filter_iff in H. destructH. cbn in *. eauto.
      - intros h H. destruct H.
        + subst. eapply in_filter_iff. split;eauto. cbn.
          unfold entry_edge in Hentry. destructH.
          eauto using loop_contains_self.
        + eapply in_filter_iff. split; eauto; cbn. eapply deq_loop_entry;eauto.
          eapply in_filter_iff in H. destructH. cbn in H1. auto.
    }
    setoid_rewrite set_eq_NoDup_len at 2;eauto.
    - cbn. reflexivity.
    - eapply NoDup_iff_dupfree. eapply dupfree_filter.
      eapply dupfree_elements.
    - econstructor.
      + intro N. eapply in_filter_iff in N. destructH. cbn in N1. unfold entry_edge in Hentry.
        destructH. contradiction.
      + eapply NoDup_iff_dupfree. eapply dupfree_filter.
        eapply dupfree_elements.
  Qed.

  Lemma deq_loop_exit_or (h p q : Lab)
        (Hexit : exit_edge h p q)
    : forall h', loop_contains h' p -> loop_contains h' q \/ h' = h.
  Proof.
    intros.
    decide (h' = h);[right;auto|left].
    decide (loop_contains h' q);[eauto|].
    exfalso. eapply n.
    eapply single_exit;eauto.
    unfold exit_edge in *. destructH. split;eauto.
  Qed.

  Lemma deq_loop_exiting h qe e
        (Hexit : exit_edge h qe e)
    : deq_loop h qe.
  Proof.
    unfold deq_loop;intros. copy Hexit Hexit'.
    unfold exit_edge in Hexit. destructH. eapply loop_contains_either in Hexit0;eauto.
    destruct Hexit0;[auto|].
    enough (h = h0) by (subst;eauto using loop_contains_self,loop_contains_loop_head).
    eapply single_exit;eauto.
    unfold exit_edge. repeat (split;eauto).
    contradict Hexit2. eapply loop_contains_trans;eauto.
  Qed.

  Lemma deq_loop_exited h qe e
        (Hexit : exit_edge h qe e)
    : deq_loop qe e.
  Proof.
    eapply no_exit_head in Hexit as Hneh.
    unfold exit_edge in *. destructH.
    unfold deq_loop. intros.
    eapply preds_in_same_loop in H;eauto.
    intro N. eapply loop_contains_loop_head in H. subst. contradiction.
  Qed.

  Lemma deq_loop_exited' : forall (h qe e : Lab), exit_edge h qe e -> deq_loop h e.
  Proof.
    intros.
    eapply deq_loop_exited in H as H'.
    eapply deq_loop_exiting in H as H''.
    eapply deq_loop_trans;eauto.
  Qed.

  Lemma eq_loop_exiting h p q
        (Hexit : exit_edge h p q)
    : eq_loop h p.
  Proof.
    split.
    - eapply deq_loop_exiting;eauto.
    - unfold exit_edge in Hexit.
      destruct Hexit as [Hexit _].
      eapply loop_contains_deq_loop;eauto.
  Qed.

  Lemma depth_exit p q
        (Heexit : eexit_edge p q)
    : depth p = S (depth q).
  Proof.
    unfold depth.
    match goal with |- | ?l | = S (| ?l' |) => set (lp := l); set (lq := l') end.
    unfold eexit_edge in Heexit. destructH.
    assert (lp =' (h :: lq)).
    {
      split;intros h' H;[|destruct H]. 1,3: eapply in_filter_iff in H; cbn in H; destructH.
      1: decide (h = h');[left;auto|right].
      all: eapply in_filter_iff; cbn;split;eauto.
      - eapply deq_loop_exit_or in Heexit;eauto. destruct Heexit;[auto|subst;contradiction].
      - eapply deq_loop_exited;eauto.
      - subst. unfold exit_edge in Heexit;destructH;eauto.
    }
    setoid_rewrite set_eq_NoDup_len at 1;eauto.
    3: econstructor.
    2,4: eapply NoDup_iff_dupfree; eapply dupfree_filter;
      eapply dupfree_elements.
    - cbn. reflexivity.
    - intro N. eapply in_filter_iff in N. destructH. cbn in N1. unfold exit_edge in Heexit.
      destructH. contradiction.
  Qed.

  Lemma root_no_loop h
    : ~ loop_contains h root.
  Proof.
    intro H. copy H Q.
    eapply dom_loop in H. unfold Dom in H.
    specialize (H [root]). exploit H. 1: econstructor.
    destruct H;[|contradiction]. subst h.
    eapply loop_contains_loop_head in Q.
    unfold loop_head in Q. destructH. eapply back_edge_incl in Q.
    eapply root_no_pred;eauto.
  Qed.

  Lemma basic_edge_no_loop2 p q
        (Hedge : basic_edge p q)
    : ~ loop_head q.
  Proof.
    intro N.
    destruct Hedge.
    assert (loop_contains q p) as Hloop.
    { destruct H. eapply H. eapply loop_contains_self. eauto. }
    eapply dom_loop in Hloop.
    specialize (a_reachability p) as Hreach. destructH.
    eapply PathCons in H0;eauto.
    eapply dom_dom_acyclic in Hloop.
    unfold Dom in Hloop. eapply Hloop in Hreach.
    eapply acyclic_path_NoDup in H0. inversion H0;subst. contradiction.
  Qed.

  Lemma depth_root
    : depth root = 0.
  Proof.
    unfold depth. eapply length_zero_iff_nil.
    remember (elem Lab) as l. clear Heql.
    induction l;cbn;auto.
    decide (loop_contains a root).
    - exfalso;eapply root_no_loop;eauto.
    - eauto.
  Qed.

  Lemma depth_loop_head h
        (Hhead : loop_head h)
    : depth h > 0.
  Proof.
    unfold depth.
    match goal with |- | ?x | > 0 => set (l := x) end.
    enough (h ∈ l).
    - eapply not_le. intro N. setoid_rewrite <-NoDup_incl_length with (l:=[h]) in N.
      + cbn in N. lia.
      + econstructor;eauto. econstructor.
      + eauto.
    - eapply loop_contains_self in Hhead.
      eapply in_filter_iff. split;eauto.
  Qed.

  Lemma acyclic_entry_head h p
        (Hedge : p -a> h)
        (Hloop : loop_head h)
    : entry_edge p h.
  Proof.
    unfold entry_edge. split;eauto.
    split;[|eapply a_edge_incl;eauto].
    intro N.
    eapply loop_reachs_member in N.
    destruct N.
    eapply a_edge_acyclic;eauto.
  Qed.

  Definition nexit_edge q p := forall h, ~ exit_edge h q p.
  Definition nexited p := forall h q, ~ exit_edge h q p.

  Lemma exited_or_nexited p
    : (forall q, q --> p -> eexit_edge q p) \/ nexited p.
  Proof.
    decide (exists h q, exit_edge h q p);[left|right].
    - intros. destructH. exists h. eapply exit_edge_pred_exiting;eauto.
    - do 2 simpl_dec' n. eassumption.
  Qed.

  Lemma two_edge_exit_cases (q1 q2 p : Lab)
        (Hedge1 : q1 --> p)
        (Hedge2 : q2 --> p)
    : (exists h, exit_edge h q1 p /\ exit_edge h q2 p)
      \/ nexit_edge q1 p /\ nexit_edge q2 p.
  Proof.
    specialize (exited_or_nexited p) as Hen.
    destruct Hen;[left|right].
    - eapply H in Hedge1.
      destruct Hedge1.
      eexists;split;eauto.
      eapply exit_edge_pred_exiting;eauto.
    - unfold nexited,nexit_edge in *. split;intros;eapply  H.
  Qed.

  Lemma depth_exit': forall [h p q : Lab], exit_edge h p q -> depth p = S (depth q).
  Proof.
    intros.
    eapply depth_exit.
    eexists;eauto.
  Qed.

  Lemma exit_edges_loop_eq h1 h2 e1 e2 q1 q2 p
        (Hexit1 : exit_edge h1 q1 e1)
        (Hexit2 : exit_edge h2 q2 e2)
        (Hin1 : loop_contains h1 p)
        (Hin2 : loop_contains h2 p)
        (Heq : eq_loop e1 e2)
    : eq_loop q1 q2.
  Proof.
    eapply loop_contains_either in Hin1 as Heither. 2: eapply Hin2.
    eapply depth_exit' in Hexit1 as Hexdep1.
    eapply depth_exit' in Hexit2 as Hexdep2.
    eapply eq_loop_exiting in Hexit1.
    eapply eq_loop_exiting in Hexit2.
    rewrite <-Hexit1. rewrite <-Hexit2.
    rewrite Heq in Hexdep1. rewrite <-Hexdep1 in Hexdep2.
    rewrite <-Hexit1 in Hexdep2. rewrite <-Hexit2 in Hexdep2.
    destruct Heither;eapply loop_contains_deq_loop in H.
    - eapply deq_loop_depth_eq in Hexdep2;eauto. split;eauto.
    - symmetry in Hexdep2. eapply deq_loop_depth_eq in Hexdep2;eauto. split;eauto.
  Qed.

  (** * Innermost loops and strit-innermost loops **)

  (** ** Definitions **)

  Definition innermost_loop h p : Prop := loop_contains h p /\ deq_loop h p.

  Definition innermost_loop_strict (h p : Lab)
    := loop_contains h p /\ h <> p /\ forall h', loop_contains h' p -> (loop_contains h' h \/ h' = p).

  Definition finType_sig_or_never (X : finType) (P : decPred X) : {x : X | P x} + {forall x : X, ~ P x}.
  Proof.
    remember (filter P (elem X)).
    destruct l.
    - right. intros ? ?. specialize (in_filter_iff P x (elem X)) as Hiff. rewrite <-Heql in Hiff.
      cbn in Hiff. eapply Hiff. split;eauto.
    - left. econstructor. specialize (in_filter_iff P e (elem X)) as Hiff.
      rewrite <-Heql in Hiff. cbn in Hiff. eapply Hiff. eauto.
  Qed.

  Definition ex_innermost_loop p
    := finType_sig_or_never (DecPred (fun h => innermost_loop h p)).

  Definition ex_innermost_loop_strict (p : Lab)
    : {h : Lab | innermost_loop_strict h p} + {forall h, ~ innermost_loop_strict h p}
    := finType_sig_or_never (DecPred (fun h => innermost_loop_strict h p)).

  Definition get_innermost_loop (p : Lab) : option Lab :=
    match ex_innermost_loop p with
    | inleft (exist _ h _) => Some h
    | inright _ => None
    end.

  Definition get_innermost_loop_strict (p : Lab) : option Lab :=
    match ex_innermost_loop_strict p with
    | inleft (exist _ h _) => Some h
    | inright _ => None
    end.

  Definition get_innermost_loop_dep (p : Lab) : option {h : Lab | loop_contains h p} :=
    match ex_innermost_loop p with
    | inleft (exist _ h H) => Some (exist _ h (match H with
                                              | conj Q _ => Q
                                              end))
    | inright _ => None
    end.

  Definition get_innermost_loop_strict_dep (p : Lab) : option {h : Lab | loop_contains h p} :=
    match ex_innermost_loop_strict p with
    | inleft (exist _ h H) => Some (exist _ h (match H with
                                              | conj Q _ => Q
                                              end))
    | inright _ => None
    end.

  (** ** Basic facts  **)

  Lemma innermost_eq_loop h q
        (Hinnermost : innermost_loop h q)
    : eq_loop h q.
  Proof.
    destruct Hinnermost. split;auto.
    eapply loop_contains_deq_loop;auto.
  Qed.

  Lemma innermost_loop_head h h'
        (Hloop : loop_head h)
        (Hinner : innermost_loop h' h)
    : h = h'.
  Proof.
    eapply eq_loop_same.
    - symmetry. eapply innermost_eq_loop;eauto.
    - eauto.
    - destruct Hinner. eapply loop_contains_loop_head;eauto.
  Qed.

  Lemma innermost_loop_deq_loop h p q
        (Hinner : innermost_loop h p)
        (Hloop : loop_contains h q)
    : deq_loop q p.
  Proof.
    unfold innermost_loop in Hinner. destructH.
    eapply deq_loop_trans;eauto.
    eapply loop_contains_deq_loop;eauto.
  Qed.

  Lemma eq_loop_innermost h p q
        (Heq : eq_loop p q)
        (Hinner : innermost_loop h p)
    : innermost_loop h q.
  Proof.
    unfold innermost_loop in *.
    destructH.
    split;[eapply Heq in Hinner0;auto|].
    unfold eq_loop in Heq. destructH.
    eapply deq_loop_trans;eauto.
  Qed.

  Lemma path_no_loop_head_deq p e h π
        (Hπ : Path edge__P p e π)
        (Hinner : innermost_loop h e)
        (Hnin : h ∉ π)
    : forall x, x ∈ π -> deq_loop x e.
  Proof.
    intros.
    decide (deq_loop x e); try eassumption.
    rename n into Hndeq.
    exfalso.
    assert (Hncont : ~ loop_contains h x). {
      eauto using innermost_loop_deq_loop.
    }
    eapply path_from_elem in H; try eauto.
    destruct H as [ϕ [Hϕ Hpost]].
    eapply Hnin.
    destruct Hinner.
    eapply in_postfix_in; try eassumption.
    eapply dom_loop_contains; try eassumption.
  Qed.

  Global Instance eq_loop_proper_innermost (h : Lab)
    : Proper (eq_loop ==> iff) (innermost_loop h).
  Proof.
    unfold Proper, respectful, Basics.impl.
    intros. unfold innermost_loop. split; intros.
    - rewrite H in H0. eassumption.
    - rewrite <- H in H0. eassumption.
  Qed.

  (** ** Uniqueness *)

  Lemma innermost_loop_strict_unique (h h' p : Lab)
        (H : innermost_loop_strict h p)
        (Q : innermost_loop_strict h' p)
    : h = h'.
  Proof.
    unfold innermost_loop_strict in *. do 2 destructH.
    eapply H3 in Q0. destruct Q0;[|contradiction].
    eapply Q3 in H0. destruct H0;[|contradiction].
    eapply loop_contains_Antisymmetric;auto.
  Qed.

  Lemma innermost_unique a b c
        (Ha : innermost_loop a c)
        (Hb : innermost_loop b c)
    : a = b.
  Proof.
    destruct Ha as [Ha Ha'].
    destruct Hb as [Hb Hb'].
    unfold deq_loop in *.
    eauto using loop_contains_Antisymmetric.
  Qed.

  Lemma innermost_unique' a b c d
        (Ha : innermost_loop a c)
        (Hb : innermost_loop b d)
        (Heq : eq_loop c d)
    : a = b.
  Proof.
    destruct Ha as [Ha Ha'].
    destruct Hb as [Hb Hb'].
    destruct Heq.
    unfold deq_loop in *.
    eapply loop_contains_Antisymmetric; eauto.
  Qed.

  Lemma back_edge_loop_contains a b x
        (Hedge : back_edge a b)
        (Hinner : loop_contains x a)
    : loop_contains x b.
  Proof.
    specialize (loop_contains_loop_head Hinner) as Hhead.
    eauto using loop_contains_deq_loop, back_edge_eq_loop, deq_loop_head_loop_contains, eq_loop1.
  Qed.

  Lemma back_edge_innermost h l
        (Hbe : back_edge l h)
    : innermost_loop h l.
  Proof.
    destruct (back_edge_eq_loop Hbe) as [H1 H2].
    unfold innermost_loop.
    eauto using loop_contains_ledge.
  Qed.

  Lemma back_edge_src_no_loop_head
        a b
        (Hbe : back_edge b a)
    : ~ loop_head b.
  Proof.
    intro. eapply no_self_loops.
    - eapply Hbe.
    - eapply innermost_unique. unfold innermost_loop. unfold deq_loop.
      eauto using loop_contains_self.
      eauto using back_edge_innermost.
  Qed.

  (** ** Paths in the loop tree **)

  Definition LPath := Path (fun h p => (innermost_loop_strict h p)).

  Lemma find_some_strong (A : Type) `{Q:EqDec A eq} (f : A -> bool) (l : list A) (x : A) (Hnd : NoDup l)
    : find f l = Some x -> x ∈ l /\ f x = true /\ forall y, y ≻* x | l -> f y = true -> x = y.
  Proof.
    repeat split. 1,2: eapply find_some in H; firstorder.
    revert dependent x.
    induction l;intros.
    - inversion H0.
    - cbn in H.
      destruct (f a) eqn:E.
      + inversion H; subst. inversion H0;subst;auto.
        inversion Hnd; subst. exfalso; contradict H5. eapply splinter_incl;[eapply H4|]. firstorder 0.
      + destruct (a == y);[rewrite e in E;congruence|].
        inversion Hnd; subst. eapply IHl;eauto. inversion H0;subst;auto. congruence.
  Qed.

  Lemma loop_LPath_helper p h π
        (Hpath : Path a_edge__P root p (p :: π))
        (Hloop : loop_contains h p)
        (Hin : h ∈ π)
        (Hnolo : forall q : Lab, q ≻* h | π -> toBool _ (D:=decision (loop_contains q p)) = true -> h = q)
    : (forall h' : Lab, loop_contains h' p -> loop_contains h' h \/ h' = p).
  Proof.
    intros. eapply loop_contains_either in H as H';[|apply Hloop].
    destruct H';[|left;auto].
    decide (h' = p);[right;auto|].
    specialize (Hnolo h'). exploit Hnolo.
    - eapply subgraph_path' in Hpath;eauto using a_edge_incl.
      eapply loop_contains_splinter in Hpath;eauto.
      cbn in Hpath. inversion Hpath;subst;auto. inversion H2;subst;contradiction.
    - decide (loop_contains h' p); cbn in *;[congruence|contradiction].
    - subst. left. eapply loop_contains_self. eapply loop_contains_loop_head;eauto.
  Qed.

  Lemma loop_LPath h p
        (Hloop : loop_contains h p)
    : exists π, LPath h p π.
  Proof.
    specialize (a_reachability p) as Hreach.
    destructH. revert dependent p. revert dependent π.
    specialize (well_founded_ind (R:=(@StrictPrefix' Lab)) (@StrictPrefix_well_founded Lab)
                                 (fun π : list Lab => forall p, loop_contains h p
                                                           -> Path a_edge__P root p π
                                                           -> exists (π0 : list Lab), LPath h p π0))
      as WFind.
    eapply WFind.
    intros;clear WFind.
    destruct x.
    - inversion H1; subst p a e.
    - remember (find (fun h' => decision (loop_contains h' p)) x) as S.
      destruct S; symmetry in HeqS.
      + eapply find_some_strong in HeqS. destructH. decide (loop_contains e0 p);cbn in *;[|congruence].
        2: auto.
        2: { eapply acyclic_path_NoDup in H1. inversion H1;auto. }
        inversion H1; [subst x ;contradiction|]. subst π a c e.
        decide (h = p).
        { subst;eexists;econstructor. }
        specialize (@path_to_elem _ a_edge__P _ _ e0 x H6 HeqS0) as [ϕ [Hϕ0 Hϕ1]].
        specialize (H ϕ). exploit' H.
        { cbn. clear - Hϕ1.
          eapply prefix_strictPrefix;auto.
        }
        specialize (H e0). exploit H.
        { clear - l H0 n HeqS0 HeqS3 H1.
          decide (e0 = h);[subst;eapply loop_contains_self;unfold loop_contains in H0;firstorder|].
          eapply loop_contains_either in H0 as H0'; eauto.
          destruct H0';[exfalso|auto].
          eapply (loop_LPath_helper) in HeqS3;auto. 2:exact H0. destruct HeqS3;[|contradiction].
          eapply loop_contains_Antisymmetric in H. exploit H. contradiction.
        }
        destructH.
        exists (p :: π0).
        econstructor;cycle 1.
        * instantiate (1:=e0). decide (innermost_loop_strict e0 p);cbn;[auto|exfalso;contradict n0].
          unfold innermost_loop_strict. split;auto. split.
          -- eapply acyclic_path_NoDup in H1. clear - HeqS0 H1. inversion H1; subst.
             contradict H2. subst. auto.
          -- eapply loop_LPath_helper;eauto.
        * auto.
      + decide (h = e); subst.
        { inversion H1.
          - subst x e p a. repeat econstructor.
          - subst π e c a. repeat econstructor. }
        eapply find_none in HeqS;cycle 1.
        * instantiate (1:=h).
          enough (h ∈ (e :: x)) as Hex.
          { destruct Hex;[symmetry in H2;contradiction|auto]. }
          eapply dom_dom_acyclic;eauto. eapply dom_loop;auto.
        * exfalso. decide (loop_contains h p); cbn in *; [congruence|contradiction].
  Qed.

  (** ** Existence **)

  Lemma loop_contains_innermost (h p : Lab)
        (Hloop : loop_contains h p)
    : exists h', innermost_loop h' p.
  Proof.
    unfold innermost_loop.
    eapply loop_LPath in Hloop as Hloop'. destructH.
    decide (loop_head p).
    + exists p. split;eauto using loop_contains_self. unfold deq_loop; firstorder.
    + inversion Hloop'. subst.
      * exists p. split;eauto using loop_contains_self. unfold deq_loop; firstorder.
      * subst. exists b.
        decide (innermost_loop_strict b p);cbn in *;[|congruence]. unfold innermost_loop_strict in i.
        clear - i n. destructH. unfold deq_loop.
        split;auto. intros. exploit i3. destruct i3;auto.
        subst. eapply loop_contains_loop_head in H. contradiction.
  Qed.

  Lemma loop_contains_innermost_strict (h p : Lab)
        (Hloop : loop_contains h p)
        (Hneq : h <> p)
    : exists h', innermost_loop_strict h' p.
  Proof.
    eapply loop_LPath in Hloop as Hloop'. destructH.
    inversion Hloop';subst;eauto;[contradiction].
  Qed.

  Lemma get_innermost_loop_spec
    : forall p : Lab,
      match get_innermost_loop p with
      | Some h => innermost_loop h p
      | None => forall h' : Lab, loop_contains h' p -> False
      end.
  Proof.
    unfold get_innermost_loop.
    intro. destruct (ex_innermost_loop p).
    - destruct s;eauto.
    - cbn in n. unfold innermost_loop in n. intros.
      eapply loop_contains_innermost in H. clear h'. destructH.
      specialize (n h'). eapply dec_DM_and in n;eauto.
      destruct n;unfold innermost_loop in H;firstorder.
  Qed.

  Lemma get_innermost_loop_dep_spec
    : forall p : Lab,
      match get_innermost_loop_dep p with
      | Some (exist _ h _) => innermost_loop h p
      | None => forall h' : Lab, loop_contains h' p -> False
      end.
  Proof.
    unfold get_innermost_loop_dep.
    intro. destruct (ex_innermost_loop p).
    - destruct s;eauto.
    - cbn in n. unfold innermost_loop in n. intros.
      eapply loop_contains_innermost in H. clear h'. destructH.
      specialize (n h'). eapply dec_DM_and in n;eauto.
      destruct n;unfold innermost_loop in H;firstorder.
  Qed.

  Lemma get_innermost_loop_strict_spec (p : Lab)
    : match get_innermost_loop_strict p with
      | Some h => innermost_loop_strict h p
      | None => forall h', loop_contains h' p -> h' = p
      end.
  Proof.
    unfold get_innermost_loop_strict.
    destruct (ex_innermost_loop_strict p); cbn.
    - destruct s. eauto.
    - intros.
      decide (h' = p);[eauto|].
      eapply loop_contains_innermost_strict in H;eauto.
      destructH. specialize (n h'0); contradiction.
  Qed.

  Lemma get_innermost_loop_strict_dep_spec (p : Lab)
    : match get_innermost_loop_strict_dep p with
      | Some (exist _ h H) => innermost_loop_strict h p
      | None => forall h', loop_contains h' p -> h' = p
      end.
  Proof.
    unfold get_innermost_loop_strict_dep.
    destruct (ex_innermost_loop_strict p); cbn.
    - destruct s. eauto.
    - intros.
      decide (h' = p);[eauto|].
      eapply loop_contains_innermost_strict in H;eauto.
      destructH. specialize (n h'0); contradiction.
  Qed.

  (** * Lemmas about relative loop depth on exit edges **)

  Lemma exit_edge_innermost h q e
        (Hexit : exit_edge h q e)
    : innermost_loop h q.
  Proof.
    clear - Hexit.
    unfold innermost_loop. split.
    - destruct Hexit. eauto.
    - eapply deq_loop_exiting;eauto.
  Qed.

  Lemma depth_ex_innermost p
        (Hdep : 0 < depth p)
    : exists h, innermost_loop h p.
  Proof.
    decide (exists h, loop_contains h p).
    - destructH. eapply loop_contains_innermost;eauto.
    - simpl_dec' n. eapply depth_zero_iff in n. lia.
  Qed.

  Lemma ex_depth_head' p n
        (Hdep : S n <= depth p)
    : exists h, loop_contains h p /\ depth h = S n.
  Proof.
    eapply Nat.le_exists_sub in Hdep. destructH. clear Hdep1.
    rename Hdep0 into Hdep. rename p0 into d.
    revert dependent p.
    induction d;intros.
    - specialize (@depth_ex_innermost p) as Hinner.
      exploit Hinner. lia. destructH.
      exists h. split;[destruct Hinner;eauto|].
      eapply innermost_eq_loop in Hinner. rewrite Hinner. lia.
    - specialize (@depth_ex_innermost p) as Hinner.
      exploit Hinner. lia. destructH.
      eapply innermost_eq_loop in Hinner as Heq.
      destruct Hinner as [Hloop Hdeq].
      specialize (a_reachability h) as Hreach.
      destructH.
      destruct π as [ | x π];[inv Hreach|].
      destruct π as [ | y π].
      { exfalso. eapply path_single in Hreach. destructH. subst h. subst x.
        eapply root_no_loop. eauto using loop_contains_self, loop_contains_loop_head. }
      inv_path Hreach.
      eapply acyclic_entry_head in H0 as Hentry. 2:eauto using loop_contains_loop_head.
      eapply depth_entry in Hentry as Hentry_dep.
      specialize (IHd y).
      exploit IHd. rewrite Heq in Hentry_dep. lia.
      destructH.
      exists h0. split;[|eauto].
      eapply deq_loop_entry in Hentry.
      eapply Hentry in IHd0.
      eapply loop_contains_trans;eauto.
  Qed.

  Lemma ex_depth_head p n
        (Hdep : n <= depth p)
        (Hn0 : n <> 0)
    : exists h, loop_contains h p /\ depth h = n.
  Proof.
    destruct n. 1:contradiction.
    eapply ex_depth_head' in Hdep;eauto.
  Qed.

(*  Lemma dom_self_loop h p π
        (Hpath : CPath p p π)
        (Hinl : innermost_loop h p)
        (Hnin : h ∉ π)
    : π = [p].
  Proof.
    clear - Hpath Hinl Hnin.
    inversion Hpath;subst.
    - reflexivity.
    - exfalso. eapply Hnin.
*)

  (** * Variant of get_innermost_loop that uses the root if there is no loop **)

  Definition get_innermost_loop' p
    := match get_innermost_loop p with
       | Some h => h
       | None => root
       end.

  Lemma deq_loop_innermost' (p : Lab)
    : deq_loop (get_innermost_loop' p) p.
  Proof.
    remember (get_innermost_loop' p) as h.
    specialize (get_innermost_loop_spec p) as Hspec.
    unfold get_innermost_loop' in Heqh.
    destruct (get_innermost_loop p).
    - subst. unfold innermost_loop in Hspec. subst. destructH; auto.
    - subst. unfold deq_loop. intros. exfalso; eauto.
  Qed.
  Definition innermost_loop' `{redCFG} (h p : Lab) := (loop_contains h p \/ h = root) /\ deq_loop h p.

  Definition get_innermost_loop_strict' p
    := match get_innermost_loop_strict p with
       | Some h => h
       | None => root
       end.

End cfg.


Require Export Iron.Language.SimpleData.TyJudge.
Require Export Iron.Language.SimpleData.Exp.
Require Export Iron.Language.SimpleData.SubstExpExp.

(* The body of an alternative is well typed under an environment
   that includes the arguments of the constructor being matched. *)
Lemma getAlt_bodyIsWellTyped_fromAlts
 :  forall ds te tPat tResult alts dc tsArgs x
 ,  Forall (fun a => TYPEA ds te a tPat tResult) alts
 -> In (AAlt dc tsArgs x) alts
 -> TYPE ds (te >< tsArgs) x tResult.
Proof.
 intros.
 norm. spec H H0.
 inverts_type. auto.
Qed.

(* The body of an alternative of a case expression is well typed
   under an environment that includes the arguments of the constructor
   being matched. *)
Lemma getAlt_bodyIsWellTyped_fromCase
 :  forall ds te tResult tCon alts dc tsArgs x1 x2
 ,  TYPE ds te (XCase x1 alts) tResult
 -> getDataDef dc ds   = Some (DefData dc tsArgs tCon)
 -> getAlt     dc alts = Some (AAlt    dc tsArgs x2)
 -> TYPE ds (te >< tsArgs) x2 tResult.
Proof.
 intros.
 inverts keep H.
 lets HA:  getAlt_in H1.
 lets HXT: getAlt_bodyIsWellTyped_fromAlts H5 HA.
 auto.
Qed.

(* If an alternative is well typed then the types of the ctor
   args embedded in it match those in the data type definition *)
Lemma getAlt_ctorArgTypesMatchDataDef
 :  forall ds te tCon tResult alts dc x tsArgs tsArgs'
 ,  Forall (fun alt => TYPEA ds te alt tCon tResult) alts
 -> getDataDef dc ds = Some (DefData dc tsArgs  tCon)
 -> getAlt dc alts   = Some (AAlt    dc tsArgs' x)
 -> tsArgs = tsArgs'.
Proof.
 intros. norm.
 lets D: getAlt_in H1. spec H D.
 inverts_type. rip.
Qed.


Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.ArithmeticSimplifier.

(** ** Equality for [inverted_expr] *)
Section inverted_expr.
  Context {var : base_type -> Type}.
  Local Notation inverted_expr := (@inverted_expr var).
  Local Notation inverted_expr_code u v
    := (match u, v with
        | const_of u', const_of v'
        | gen_expr u', gen_expr v'
        | neg_expr u', neg_expr v'
          => u' = v'
        | const_of _, _
        | gen_expr _, _
        | neg_expr _, _
          => False
        end).

  (** *** Equality of [inverted_expr] is a [match] *)
  Definition path_inverted_expr {T} (u v : inverted_expr T) (p : inverted_expr_code u v)
    : u = v.
  Proof. destruct u, v; first [ apply f_equal | exfalso ]; exact p. Defined.

  (** *** Equivalence of equality of [inverted_expr] with [inverted_expr_code] *)
  Definition unpath_inverted_expr {T} {u v : inverted_expr T} (p : u = v)
    : inverted_expr_code u v.
  Proof. subst v; destruct u; reflexivity. Defined.

  Definition path_inverted_expr_iff {T}
             (u v : @inverted_expr T)
    : u = v <-> inverted_expr_code u v.
  Proof.
    split; [ apply unpath_inverted_expr | apply path_inverted_expr ].
  Defined.

  (** *** Eta-expansion of [@eq (inverted_expr _ _)] *)
  Definition path_inverted_expr_eta {T} {u v : @inverted_expr T} (p : u = v)
    : p = path_inverted_expr u v (unpath_inverted_expr p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (inverted_expr _ _)] *)
  Definition path_inverted_expr_rect {T} {u v : @inverted_expr T} (P : u = v -> Type)
             (f : forall p, P (path_inverted_expr u v p))
    : forall p, P p.
  Proof. intro p; specialize (f (unpath_inverted_expr p)); destruct u, p; exact f. Defined.
  Definition path_inverted_expr_rec {T u v} (P : u = v :> @inverted_expr T -> Set) := path_inverted_expr_rect P.
  Definition path_inverted_expr_ind {T u v} (P : u = v :> @inverted_expr T -> Prop) := path_inverted_expr_rec P.
End inverted_expr.

(** ** Useful Tactics *)
(** *** [inversion_inverted_expr] *)
Ltac induction_path_inverted_expr H :=
  induction H as [H] using path_inverted_expr_rect;
  try match type of H with
      | False => exfalso; exact H
      end.
Ltac inversion_inverted_expr_step :=
  match goal with
  | [ H : const_of _ _ = const_of _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : const_of _ _ = gen_expr _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : const_of _ _ = neg_expr _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : gen_expr _ _ = const_of _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : gen_expr _ _ = gen_expr _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : gen_expr _ _ = neg_expr _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : neg_expr _ _ = const_of _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : neg_expr _ _ = gen_expr _ _ |- _ ]
    => induction_path_inverted_expr H
  | [ H : neg_expr _ _ = neg_expr _ _ |- _ ]
    => induction_path_inverted_expr H
  end.
Ltac inversion_inverted_expr := repeat inversion_inverted_expr_step.


Require Import Iron.Data.List.
Require Import Iron.Tactics.

(********************************************************************)
(** * Evaluation Contexts of lists *)
(*  A context defined by one place in a list of exps, where all
    the exps to the left of it in the list are values:
         v0 v1 v2 xx x4 x5 x6
                  ^^
    This is useful when enforcing a left-to-right evaluation
    order for a list of exps, like in the arguments of an XCon *)
Inductive exps_ctx
      {exp :Type}         (* type of expressions *)
      (Val: exp -> Prop)  (* predicate to determine whether the exp a value *)
   :  (exp -> list exp)   (* fn to fill the hole in the list evaluation context *)
   -> Prop :=
 | XscHead
   :  forall xs
   ,  exps_ctx Val (fun xx => xx :: xs)

 | XscCons
   :  forall v C
   ,  Val v
   -> exps_ctx Val C
   -> exps_ctx Val (fun xx => v :: C xx).

Hint Constructors exps_ctx.

(* Swapping related expresions in contexts *)
Lemma exps_ctx_Forall2_swap
 :  forall {exp: Type} {B:   Type}
           (Val:  exp -> Prop)
           (R:    exp -> B -> Prop)
           (C:    exp -> list exp)
           (x x': exp)
           (ys:   list B)
 ,  exps_ctx Val C
 -> (forall y, R x y -> R x' y)
 -> Forall2 R (C x)  ys
 -> Forall2 R (C x') ys.
Proof.
 intros. gen ys.
 induction H; intros.
  destruct ys.
   inverts H1.
   eapply Forall2_cons. eapply H0.
    inverts H1. auto.
    inverts H1. auto.

  inverts H2.
   eapply Forall2_cons.
   auto. auto.
Qed.

(* If all the elements in a list context have a property then
   then they also have this property individually. *)
Lemma exps_ctx_Forall
 :  forall {exp: Type}
           (Val: exp -> Prop)
           (C:   exp -> list exp)
           (P:   exp -> Prop)
           (x:   exp)
 ,  exps_ctx Val C
 -> Forall P (C x)
 -> P x.
Proof.
 intros.
 induction H.
  inverts H0. auto.
  inverts H0. auto.
Qed.

Lemma exps_ctx_Forall2_exists_left
 :  forall {exp: Type} {B: Type}
           (Val: exp -> Prop)
           (C:   exp -> list exp)
           (R:   exp -> B -> Prop)
           (x:   exp)
           (ys:  list B)
 ,  exps_ctx Val C
 -> Forall2 R (C x) ys
 -> (exists y, R x y).
Proof.
 intros. gen ys.
 induction H; intros.
  destruct ys.
   inverts H0.
   inverts H0. eauto.
  inverts H1.
  eapply IHexps_ctx. eauto.
Qed.

(* Used when evaluating all the expressions in a list.
   If all the exps in a list are either wnf or have some property,
   then they're either all wnf
     or there is a context consisting of a run of wnf expressions
        followed by one with the property.

   For example:
     C = w1 w2 w3 w4 x1 ?? ?? ?? ??

   This is a context consisting of a run of four wnfs, followed
   by an expression x1 with the desired property. The rest may or
   may not be wnfs, but the'll all have the property.
*)
Lemma exps_ctx_run
 :  forall {exp: Type} {B: Type}
           (Val:  exp -> Prop)
           (P:    exp -> Prop)
           (xs:   list exp)
 ,  Forall (fun x => Val x \/ P x) xs
 -> Forall Val xs
 \/ (exists C x', exps_ctx Val C
               /\ xs = C x'
               /\ P x').
Proof.
 intros.
 induction xs.
  left. auto.
  inverts H.

  inverts H2.
   lets D: IHxs H3. clear IHxs.
   inverts D.
    left. auto.
    right.
     destruct H0 as [C].
     destruct H0 as [x'].
      inverts H0. inverts H2.
      lets D2: (@XscCons exp Val) H H1.
      exists (fun xx => a :: C xx).
      exists x'. auto.

    lets D: IHxs H3. clear IHxs.
    inverts D.
     right.
     lets D2: (@XscHead exp Val) xs.
     exists (fun xx => xx :: xs).
     exists a. auto.

    destruct H0 as [C].
    destruct H0 as [x'].
     inverts H0. inverts H2.
     right.
     exists (fun xx => xx :: C x').
     exists a.
     lets D2: (@XscHead exp Val) (C x').
     auto.
Qed.

(********************************************************************)
(* Joint contexts of lists.
   This is used when we evaluate a list of expressions left to right
   where each expression needs to be a value before we move onto
   the next one. *)
Inductive exps_ctx2
      {exp: Type}        (* type of expressions *)
      (Val: exp -> Prop) (* predicate to determine whether an exp is a value *)
   :  (exp -> list exp)  (* fn for first  evaluation context *)
   -> (exp -> list exp)  (* fn for second evaluation context *)
   -> Prop :=
 | Xsc2Head
   :  forall xs ys
   ,  exps_ctx2 Val (fun xx => xx :: xs)  (fun yy => yy :: ys)

 | Xsc2Cons
   :  forall v C1 C2
   ,  Val v
   -> exps_ctx2 Val C1 C2
   -> exps_ctx2 Val (fun xx => v :: C1 xx) (fun yy => v :: C2 yy).

Hint Constructors exps_ctx2.

(* Take the left of a joint context *)
Lemma exps_ctx2_left
 : forall exp Val C1 C2
 , @exps_ctx2 exp Val C1 C2 -> @exps_ctx exp Val C1.
Proof.
 intros.
 induction H; auto.
Qed.

(* Take the right of a joint context *)
Lemma exps_ctx2_right
 : forall exp Val C1 C2
 , @exps_ctx2 exp Val C1 C2 -> @exps_ctx exp Val C2.
Proof.
 intros.
 induction H; auto.
Qed.

(* Used when evaluating a list of expressions.
   We take an expression from the first list, evaluate it, and
   place the result in the second. For this to happen we need
   to find an appropriate joint evaluation context.

   If we can produce a wnf for every expression in the first list,
   then either all exps are already wnf
     or we can find a joint context consisting of a run of wnf
        expressions, followed by an expression that we can evaluate.

   For example:
    C1 =  w1 w2 w3 x4 ?? ?? ??
    C2 =  w1 w2 w3 w4 ?? ?? ??

   Here we have such a joint context. The first three values in
   each are idential and already wnf. We then have x4 and y4,
   where x4 can be evaluated into y4. The rest may or may not
   be wnfs, but the'll still be related.

   v1 v2 v3 v4 XX x6 x7 x8 x9
   v1 v2 v3 v4 XX v6 v7 v8 v

*)
Lemma exps_ctx2_run
 :   forall {exp:   Type}
            (Val:   exp -> Prop)
            (R:     exp -> exp -> Prop)
            (xs ys: list exp)
 ,   Forall2 (fun x y => R x y /\ Val y /\ (Val x -> y = x)) xs ys
 ->  Forall Val xs
 \/ (exists C1 C2 x' y'
         ,  R x' y'
         /\ exps_ctx2 Val C1 C2
         /\ xs = C1 x'
         /\ ys = C2 y').
Proof.
 intros exp Val R xs ys HR.
 induction HR.
  Case "nil".
   left. auto.

  Case "cons".
   rename l  into xs.
   rename l' into ys.
   inverts H. inverts H1.
   inverts IHHR.
   SCase "xs whnf".
    right.
    exists (fun xx => xx :: xs).
    exists (fun xx => xx :: ys).
    exists x.
    exists y. auto.

   SCase "xs ctx".
    right.
    destruct H1 as [C1].
    destruct H1 as [C2].
    destruct H1 as [x'].
    destruct H1 as [y'].
    inverts H1. inverts H4. inverts H5.

    exists (fun xx => xx :: C1 x').
    exists (fun yy => yy :: C2 y').
    exists x. exists y.
    repeat (split; auto).
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import div path tuple.
Require Import Init_ext ssrZ ZArith_ext String_ext Max_ext.
Require Import machine_int seq_ext ssrnat_ext tuple_ext path_ext.
Require order finmap.
Import MachineInt.
Require Import C_types C_types_fp C_value C_expr.

Local Open Scope C_types_scope.
Local Open Scope C_value_scope.
Local Open Scope C_expr_scope.

(** Equivalence between arithmetic expressions *)

Definition sequiv {g} {sigma : g.-env} {t} (e1 e2 : exp sigma t) :=
  forall s, [ e1 ]_ s = [ e2 ]_ s.

Notation "a '=s' b" := (sequiv a b) (at level 72, format "'[' a  '=s'  b ']'", no associativity) : C_expr_scope.

Instance sequiv_equivalence (g : wfctxt) (sigma : g.-env) (t : g.-typ) :
  Coq.Classes.RelationClasses.Equivalence (@sequiv _ sigma t).
constructor.
move=> e s; reflexivity.
move=> e1 e2 H s; by symmetry.
move=> e1 e2 e3 H12 H23 s; by transitivity ([e2]_ s).
Qed.

Transparent eval.

Instance bop_r_morphism g (sigma : g.-env) (t : integral) bop :
  Coq.Classes.Morphisms.Proper (sequiv ==> sequiv ==> sequiv) (bop_r sigma t bop).
Proof. destruct bop; move=> e1 e2 H1 a b H2 s /=; by rewrite H1 H2. Qed.

Instance bop_n_morphism g (sigma : g.-env) (t : integral) bop :
  Morphisms.Proper (sequiv ==> sequiv ==> sequiv) (bop_n sigma t bop).
Proof. destruct bop; move=> e1 e2 H1 a b H2 s /=; by rewrite H1 H2. Qed.

Instance eq_p_morphism g (sigma : g.-env) (t : g.-typ) :
  Morphisms.Proper (sequiv ==> sequiv ==> sequiv) (eq_p sigma t).
Proof. move => e1 e2 H1 a b H2 s /=; by rewrite H1 H2. Qed.

Instance add_p_morphism g (sigma : g.-env) (t : g.-typ) :
  Morphisms.Proper (eq ==> sequiv ==> sequiv) (add_p sigma t).
Proof. move=> e1 e2 -> a b H s /=; by rewrite H. Qed.

Instance safe_cast_morphism g (sigma : g.-env) (t t' : integral) :
  Morphisms.Proper (sequiv ==> eq ==> sequiv) (safe_cast sigma t t').
Proof. move=> x y Hxy H1 H2 -> s /=; by rewrite Hxy. Qed.

Opaque eval.

Local Open Scope zarith_ext_scope.
Local Open Scope machine_int_scope.

Lemma phy_of_si32_zext {g} {sigma : g.-env} (a : int 8) :
  [ zext 24 a ]pc =s ([ Z<=u a ]sc : exp sigma (ityp: sint)).
Proof.
Transparent eval.
move=> s /=.
apply mkPhy_irrelevance => /=.
congr (i8<=i32) => /=.
apply s2Z_inj.
rewrite (s2Z_zext 24) // Z2sK //.
split; [exact: (leZ_trans _ (min_u2Z _)) | exact: (ltZ_trans (max_u2Z _))].
Opaque eval.
Qed.

Section beq_sect.

Variable (g : wfctxt) (sigma : g.-env).

Lemma beq_exx t (e : exp sigma (ityp: t)) : e \= e =s [ 1 ]uc.
Proof.
Transparent eval.
move=> s /=.
case: t e => //= e; by destruct ([ e ]_s) => //=; rewrite eqxx.
Opaque eval.
Qed.

Lemma beq_pxx t (a : exp sigma (:* t)) : a \= a =s [ 1 ]uc.
Proof.
Transparent eval.
move=> s.
by rewrite /= eqxx.
Opaque eval.
Qed.

Lemma Ceq_sym t (a b : exp sigma (ityp: t)) : a \= b =s b \= a.
Proof.
Transparent eval.
move=> s /=.
move Ha : ( [ a ]_s ) => [ha1 ha2].
move Hb : ( [ b ]_s ) => [hb1 hb2].
destruct t; by rewrite eq_sym.
Opaque eval.
Qed.

Lemma Ceqp_sym t (a b : exp sigma (:* t)) : a \= b =s b \= a.
Proof.
Transparent eval.
move=> s; by rewrite /= eq_sym.
Opaque eval.
Qed.

Lemma sequiv_bop_re_sc x y :
  -2 ^^ 31 < x < 2 ^^ 31 -> -2 ^^ 31 < y < 2 ^^ 31 ->
  ([ x ]sc \= ([ y ]sc : exp sigma (ityp: sint))) =s [ Z<=nat (x == y) ]uc.
Proof.
Transparent eval.
move=> Hx Hy s /=.
rewrite 2!i8_of_i32K.
congr ([ _ ]p).
rewrite Z2sK; last by simpl in *; lia.
rewrite Z2sK; last by simpl in *; lia.
by case: ifP.
Opaque eval.
Qed.

End beq_sect.

Section Cadd_sect.

Variables (g : wfctxt) (sigma : g.-env).

Lemma CaddnC t (e1 e2 : exp sigma (ityp: t)) : e1 \+ e2 =s e2 \+ e1.
Proof.
Transparent eval.
move => s /=.
by case: t e1 e2 => e1 e2; destruct ([e1]_s); destruct ([e2]_s); rewrite /= addC.
Opaque eval.
Qed.

Lemma CaddnA t (e1 e2 e3 : exp sigma (ityp: t)) : e1 \+ e2 \+ e3 =s e1 \+ (e2 \+ e3).
Proof.
Transparent eval.
move => s /=.
case: t e1 e2 e3 => e1 e2 e3; destruct ([e1]_s); destruct ([e2]_s); destruct ([e3]_s).
- by rewrite /= !i8_of_i32K addA.
- by rewrite /= !i8_of_i32K addA.
- rewrite /=.
  destruct phy2seq as [|A []] => //.
  destruct phy2seq0 as [|B []] => //.
  destruct phy2seq1 as [|C []] => //.
  by rewrite /= /i8_to_i8 addA.
- rewrite /=.
  destruct phy2seq as [|A []] => //.
  destruct phy2seq0 as [|B []] => //.
  destruct phy2seq1 as [|C []] => //.
  by rewrite /= /i8_to_i8 addA.
- by rewrite /= !i8_of_i64K addA.
Opaque eval.
Qed.

Lemma sequiv_add_pe_0 t (e : exp sigma (:* t)) : e \+ [ 0 ]sc =s e.
Proof. move=> s; by rewrite add_p_0. Qed.

Lemma eq_pC_const t (a : exp sigma (:* t)) b c : a \+ b \+ c =s a \+ c \+ b.
Proof.
Transparent eval.
move=> s /=.
move Ha : ( [ a ]_ s ) => [a_s Ha_s].
have : size a_s = sizeof_ptr by rewrite Ha_s sizeof_ptyp.
case/optr_of_i8_Some => a_s' Ha_s'.
move Hb : ( [ b ]_ s ) => [b_s Hb_s].
have : size b_s = 4%nat by rewrite Hb_s.
case/oi32_of_i8_Some => b_s' Hb_s' /=.
rewrite !i8_of_ptrK.
move Hc : ( [ c ]_ s ) => [c_s Hc_s].
have : size c_s = 4%nat by rewrite Hc_s.
case/oi32_of_i8_Some => c_s' Hc_s' /=.
rewrite !i8_of_ptrK.
apply mkPhy_irrelevance.
by rewrite add_prodC.
Opaque eval.
Qed.

Lemma Ceqpn_add2r t (a a' : exp sigma (:* t)) (k : Z) :
  - 2 ^^ 31 <= Z<=nat (sizeof t) * k < 2 ^^ 31 ->
  a \+ [ k ]sc \= a' \+ [ k ]sc =s a \= a'.
Proof.
Transparent eval.
move=> Hk s /=.
move Ha : ([ a ]_s) => [la Hla].
move Ha' : ([ a' ]_s) => [la' Hla'].
have : size la = sizeof_ptr by rewrite Hla sizeof_ptyp.
case/optr_of_i8_Some => la'' Hla''.
have : size la' = sizeof_ptr by rewrite Hla' sizeof_ptyp.
case/optr_of_i8_Some => la''' Hla'''.
rewrite i8_of_i32K /add_prod Z2sK; last first.
  move: (sizeof_gt0 g t) => ty_gt0.
  case: (Z_lt_le_dec k 0) => hk.
    split; last by lia.
    apply (leZ_trans (proj1 Hk)).
    rewrite mulZC. apply Zle_scale_neg.
    exact: ltZW.
    rewrite (_ : 0%Z = Z.of_nat 0) //.
    apply inj_lt; exact/ltP.
  split; first by lia.
  apply : (leZ_ltZ_trans _ (proj2 Hk)).
  rewrite -{1}[X in (X <= _)%Z]mul1Z.
  apply leZ_wpmul2r => //.
  omegaz' ssromega.
(*  rewrite (_ : 1%Z = Z.of_nat 1) //; apply inj_le.
  by apply/leP.*)
case/boolP : (0 <=? k)%Z => k0.
- case: ifP.
    move/eqP/phy_of_ptr_inj.
    move/add_reg => la''la'''.
    move/ptr_of_i8_inj in la''la'''; subst la'.
    rewrite (_ : Hla = Hla'); last by apply eq_irrelevance.
    by rewrite eqxx.
  case: ifP => //.
  case/eqP => ?; subst la'.
  move=> abs.
  rewrite Hla'' in Hla'''.
  case: Hla''' => ?; subst la''.
  rewrite (_ : Hla = Hla') in abs; last by apply eq_irrelevance.
  by rewrite eqxx in abs.
- case: ifP.
    move/eqP/phy_of_ptr_inj.
    move/add_reg.
    move/ptr_of_i8_inj => ?; subst la'.
    rewrite (_ : Hla = Hla'); last by apply eq_irrelevance.
    by rewrite eqxx.
  case: ifP => //.
  case/eqP => ?; subst la'.
  move=> abs.
  rewrite Hla'' in Hla'''.
  case: Hla''' => ?; subst la''.
  rewrite (_ : Hla = Hla') in abs; last by apply eq_irrelevance.
  by rewrite eqxx in abs.
Opaque eval.
Qed.

Lemma CaddnpA t (a : exp sigma (:* t)) b c :
  0 <= Z<=nat (sizeof t) * b < 2 ^^ 31 -> 0 <= Z<=nat (sizeof t) * c < 2 ^^ 31 ->
  0 <= Z<=nat (sizeof t) * b + Z<=nat (sizeof t) * c < 2 ^^ 31 ->
  a \+ [ b ]sc \+ [ c ]sc =s a \+ ([ b ]sc \+ [ c ]sc).
Proof.
move=> Hb Hc Hbc s.
have Hb_weak : - 2 ^^ 31 <= b < 2 ^^ 31.
  case: Hb.
  case/Zle_0_mult_inv; last first.
    case => /Z_of_nat_neg abs.
    move: (sizeof_gt0 g t); by rewrite abs.
  case=> _ Hb1 Hb2.
  apply Zlt_Zmult_inv in Hb2; last 2 first.
    apply Z_of_nat_lt0. by apply sizeof_gt0.
    exact: expZ_ge0.
  split; [exact: (@leZ_trans Z0) | by []].
have Hc_weak : - 2 ^^ 31 <= c < 2 ^^ 31.
  case: Hc.
  case/Zle_0_mult_inv; last first.
    case => /Z_of_nat_neg abs.
    move: (sizeof_gt0 g t); by rewrite abs.
  case=> _ Hc1 Hc2.
  apply Zlt_Zmult_inv in Hc2; last 2 first.
    apply Z_of_nat_lt0. by apply sizeof_gt0.
    exact: expZ_ge0.
  split; [exact: (@leZ_trans Z0) | by []].
apply eval_add_pA => //.
rewrite /si32_of_phy [oi32_of_i8 _]/= i8_of_i32Ko [s2Z _]/= Z2sK //.
rewrite /si32_of_phy [oi32_of_i8 _]/= i8_of_i32Ko [s2Z _]/= Z2sK //.
rewrite /si32_of_phy [oi32_of_i8 _]/= 2!i8_of_i32Ko [s2Z _]/=.
by rewrite Z2sK // [s2Z _]/= Z2sK.
Qed.

Lemma sequiv_add_e_sc x y :
  - 2 ^^ 31 <= x < 2 ^^ 31 -> - 2 ^^ 31 <= y < 2 ^^ 31 ->
  - 2 ^^ 31 <= x + y < 2 ^^ 31 ->
  ([ x ]sc \+ [ y ]sc : exp sigma (ityp: sint) ) =s [ x + y ]sc .
Proof.
Transparent eval.
move=> Hx Hy xy s /=.
rewrite 2!i8_of_i32K.
suff -> : `( x )s_ 32 `+ `( y )s_ 32 = `(x + y)s_ 32 by done.
apply s2Z_inj.
rewrite Z2sK; last by done.
rewrite s2Z_add; last first.
  rewrite Z2sK; last by done.
  rewrite Z2sK; last by simpl in *; lia.
  simpl in *; lia.
rewrite Z2sK; last by simpl in *; lia.
rewrite Z2sK //; by simpl in *; lia.
Opaque eval.
Qed.

Lemma sequiv_add_e_sc_pos x y : 0 <= x -> 0 <= y -> x + y < 2 ^^ 31 ->
  ([ x ]sc \+ [ y ]sc : exp sigma (ityp: sint) ) =s [ x + y ]sc.
Proof. move=> Hx Hy xy; rewrite sequiv_add_e_sc //; lia. Qed.

Lemma sequiv_add_e_sc_pos3 x y z :
  0 <= x -> 0 <= y -> 0 <= z -> x + y + z < 2 ^^ 31 ->
  ([ x ]sc \+ [ y ]sc \+ [ z ]sc : exp sigma (ityp: sint)) =s [ x + y + z ]sc.
Proof.
move=> Hx Hy Hz xyz.
rewrite (sequiv_add_e_sc x y) //; [ | lia | lia | lia].
rewrite sequiv_add_e_sc_pos //; lia.
Qed.

Lemma sequiv_add_e_sc_pos4 x y z u :
  0 <= x -> 0 <= y -> 0 <= z -> 0 <= u -> x + y + z + u < 2 ^^ 31 ->
  ([ x ]sc \+ [ y ]sc \+ [ z ]sc \+ [ u ]sc : exp sigma (ityp: sint)) =s [ x + y + z + u ]sc.
Proof.
move=> Hx Hy Hz Hu xyzu.
rewrite sequiv_add_e_sc_pos3 //; last by lia.
rewrite sequiv_add_e_sc_pos //; lia.
Qed.

(* might need a bit more hypotheses *)
Lemma sequiv_add_p_cst x : forall (a : (:* (g.-ityp: uchar)).-phy),
  0 <= x < 2 ^^ 31 -> [ phy<=ptr _ (ptr<=phy a `+ `( x )_ ptr_len) ]c =s
  ([a ]c \+ [ x ]sc : exp sigma _).
Proof.
Transparent eval.
case=> //= l Hl Hx s.
have Hl' : size l = sizeof_ptr by rewrite Hl sizeof_ptyp.
rewrite /=.
move: (optr_of_i8_Some _ Hl') => [] x0 Hx0.
rewrite i8_of_i32K.
congr (phy<=ptr).
rewrite Z2sK; last by simpl in *; lia.
rewrite sizeof_ityp /add_prod.
have ->: (Z_of_nat 1%nat) * x = x by case x.
case: (Hx) => /leZP -> _.
rewrite /ptr_of_phy /= Hx0 /=.
erewrite i32_of_i8_bij3; eauto.
Opaque eval.
Qed.

(* see also Ceqpn_add2l' in C_expr.v: less conditions but in one direction *)
Lemma Ceqpn_add2l t (e : exp sigma (:* t)) e1 e2 : forall s H1 H2 H3 H4,
  Z.sgn (Z<=s (i32<=i8 [ e1 ]_s H1)) = Z.sgn (Z<=s (i32<=i8 [ e2 ]_ s H2)) ->
  Z<=nat (sizeof t) * Z.abs (Z<=s (i32<=i8 [ e1 ]_s H3)) < 2 ^^ ptr_len ->
  Z<=nat (sizeof t) * Z.abs (Z<=s (i32<=i8 [ e2 ]_s H4)) < 2 ^^ ptr_len ->
  [e \+ e1 \= e \+ e2 ]_ s = [ e1 \= e2 ]_s.
Proof.
move=> s H1 H2 H3 h4 Hs Hs1 Hs2.
Transparent eval.
rewrite /=.
move He : ([ e ]_s) => [he Hhe].
move He1 : ([ e1 ]_s) => [he1 Hhe1].
move He2 : ([ e2 ]_s) => [he2 Hhe2].
case: ifP => H.
- symmetry.
  move/eqP/phy_of_ptr_inj in H.
  case: ifP; first by done.
  move/eqP => H0; apply False_ind; apply: H0.
  congr (Z<=s _).
  apply add_prod_inj in H; last 4 first.
    by apply sizeof_gt0.
    set hyp := Z<=s _ in Hs1.
    set goa := Z<=s _.
    suff : goa = hyp by move=> ->.
    rewrite /goa /hyp.
    congr (Z<=s).
    apply i32_of_i8_irr.
    by rewrite He1.
    set hyp := Z<=s _ in Hs2.
    set goa := Z<=s _.
    suff : goa = hyp by move=> ->.
    rewrite /goa /hyp.
    congr (Z<=s).
    apply i32_of_i8_irr.
    by rewrite He2.
    clear -Hs He1 He2.
    set lhs_hyp := Z<=s _ in Hs.
    set lhs_goa := Z<=s _.
    set rhs_hyp := Z<=s _ in Hs.
    set rhs_goa := Z<=s _.
    have <- : lhs_hyp = lhs_goa.
      rewrite /lhs_hyp /lhs_goa.
      congr (Z<=s).
      apply i32_of_i8_irr.
      by rewrite He1.
    have <- : rhs_hyp = rhs_goa.
      rewrite /rhs_hyp /rhs_goa.
      congr (Z<=s).
      apply i32_of_i8_irr.
      by rewrite He2.
    done.
  apply s2Z_inj in H.
  move: (i32_of_i8_inj he1 Hhe1 he2 Hhe2 H) => H0.
  subst he1.
  congr (i32<=i8 _ _).
  by apply eq_irrelevance.
- case: ifP; last by [].
  move/eqP/s2Z_inj/i32_of_i8_inj => ?; subst he1.
  move: H.
  suff : Hhe1 = Hhe2 by move=> ->; rewrite eqxx.
  by apply eq_irrelevance.
Opaque eval.
Qed.

(* was eq_p_sem_eq_equiv_spec *)
Lemma Ceqpn_add2l_sc_equiv t (e : exp sigma (:* t)) e1 e2 :
  Z.sgn e1 = Z.sgn e2 ->
  - 2 ^^ 31 <= Z<=nat (sizeof t) * e1 < 2 ^^ 31 ->
  - 2 ^^ 31 <= Z<=nat (sizeof t) * e2 < 2 ^^ 31 ->
  ( e \+ [ e1 ]sc \= e \+ [ e2 ]sc) =s ( ([ e1 ]sc : exp sigma (ityp: sint)) \= [ e2 ]sc).
Proof.
move=> H1 H2 H3 s.
have Htmp : 0 < Z<=nat (sizeof t) by apply/Z_of_nat_lt0/sizeof_gt0.
have He1 : - 2 ^^ 31 <= e1 < 2 ^^ 31.
  eapply Zlt_mult_interval_inv; [by apply Htmp | done].
have He2 : - 2 ^^ 31 <= e2 < 2 ^^ 31.
  eapply Zlt_mult_interval_inv; [by apply Htmp | done].
rewrite Ceqpn_add2l //.
- by rewrite size_sc.
- by rewrite size_sc.
- by rewrite size_sc.
- by rewrite size_sc.
- move=> H6 H7. by rewrite !s2Z_sc.
- move=> H6.
  rewrite s2Z_sc // -(geZ0_norm (Z<=nat (sizeof t))); last exact/Zle_0_nat.
  rewrite -normZM ltZ_norml.
  split; [exact: ltZ_leZ_trans (proj1 H2) | exact: (ltZ_leZ_trans (proj2 H2))].
- move=> H6.
  rewrite s2Z_sc // -(geZ0_norm (Z<=nat (sizeof t))); last exact/Zle_0_nat.
  rewrite -normZM ltZ_norml.
  split; [exact: ltZ_leZ_trans (proj1 H3) | exact: (ltZ_leZ_trans (proj2 H3))].
Qed.

End Cadd_sect.

Lemma sequiv_ge_sym {g} {sigma : g.-env} {t} (e1 e2 : exp sigma (ityp: t)) :
   e1 \>= e2 =s e2 \<= e1.
Proof.
Transparent eval.
move=> s /=.
move H1 : ( [ e1 ]_s ) => [h1 Hh1].
move H2 : ( [ e2 ]_s ) => [h2 Hh2].
by destruct t.
Opaque beval.
Qed.

Lemma sequiv_gt_sym {g} {sigma : g.-env} {t} (e1 e2 : exp sigma (ityp: t)) :
   e1 \> e2 =s e2 \< e1.
Proof.
Transparent eval.
move=> s /=.
move H1 : ( [ e1 ]_s ) => [h1 Hh1].
move H2 : ( [ e2 ]_s ) => [h2 Hh2].
by destruct t.
Opaque eval.
Qed.

Lemma sequiv_sub_e_sc {g} {sigma : g.-env} x y :
  - 2 ^^ 31 <= x < 2 ^^ 31 -> - 2 ^^ 31 <= y < 2 ^^ 31 -> - 2 ^^ 31 <= x - y < 2 ^^ 31 ->
  ([ x ]sc \- [ y ]sc : exp sigma (ityp: sint)) =s [ x - y ]sc.
Proof.
Transparent eval.
move=> Hx Hy xy s /=.
rewrite 2!i8_of_i32K.
Local Open Scope machine_int_scope.
suff -> : `( x )s_ 32 `- `( y )s_ 32 = `(x - y)s_ 32 by [].
apply s2Z_inj.
rewrite Z2sK; last by [].
rewrite s2Z_sub; last first.
  rewrite Z2sK; last by [].
  rewrite Z2sK; last by simpl in *; lia.
  simpl in *; lia.
rewrite Z2sK; last by simpl in *; lia.
rewrite Z2sK //; by simpl in *; lia.
Opaque eval.
Qed.

(** casts *)

Lemma sequiv_intsa_uchar_sc {g} {sigma : g.-env} (a : int 8) :
  (int) ([ a ]pc : exp sigma (g.-ityp: uchar)) =s ([ u2Z a ]sc : exp sigma _).
Proof.
move=> s.
Transparent eval.
apply: mkPhy_irrelevance => /=.
congr (i8<=i32).
apply s2Z_inj.
rewrite Z2sK; last first.
  rewrite /=; split.
  exact: (leZ_trans _ (min_u2Z _)).
  exact: (ltZ_leZ_trans (max_u2Z _)).
rewrite s2Z_u2Z_pos'; last first.
  rewrite (u2Z_zext 24) /=; split; first by apply min_u2Z.
  exact: (ltZ_leZ_trans (max_u2Z _)).
by rewrite (u2Z_zext 24).
Opaque eval.
Qed.

Lemma unsa_sa_i8_to_uchar_uint_to_phy {g} {sigma : g.-env} (a : int 8) :
  (UINT) ( (int) ([ a ]pc : exp sigma (g.-ityp: uchar))) =s ([ zext 24 a ]pc : exp sigma _).
Proof.
move=> s.
Transparent eval.
rewrite /= /unsafe_cast_phy /phy_of_ui32 /=.
by apply mkPhy_irrelevance.
Opaque eval.
Qed.

Lemma int_int_cast {g} {sigma : g.-env} {t H} (e : exp sigma (ityp: t)):
  safe_cast _ sint sint (safe_cast _ _ sint e H) erefl =s
  (safe_cast _ _ sint e H).
Proof. move => s. done. Qed.

(** equivalence between boolean expressions *)

Definition bequiv {g} {sigma : g.-env} (b1 b2 : bexp sigma) := forall s, [ b1 ]b_ s = [ b2 ]b_ s.

Notation "a '=b' b" := (bequiv a b) (at level 72, format "'[' a  '=b'  b ']'", no associativity) : C_expr_scope.

Instance bequiv_equivalence g (sigma : g.-env) : Equivalence (@bequiv _ sigma).
constructor.
move=> s b; reflexivity.
move=> b1 b2 H s; by rewrite H.
move=> b1 b2 b3 H1 H2 s; by rewrite H1 H2.
Qed.

Instance beval_morphism g (sigma : g.-env) :
  Morphisms.Proper (bequiv ==> eq ==> eq) (@beval _ sigma).
Proof. by move => b1 b2 H s1 s2 ->; rewrite H. Qed.

Transparent eval beval.

Instance exp2bexp_morphism g (sigma : g.-env) :
  Morphisms.Proper (sequiv ==> bequiv) (@exp2bexp _ sigma).
Proof. by move => e1 e2 H s /=; rewrite H. Qed.

Instance bneg_morphism g (sigma : g.-env) :
  Morphisms.Proper (bequiv ==> bequiv) (@bneg _ sigma).
Proof. move => b1 b2 H s. by rewrite /= (H s). Qed.

Opaque eval beval.

Section bequiv_prop.

Variables (g : wfctxt) (sigma : g.-env).

Lemma bnegK (b : bexp sigma) : (\~b \~b b) =b b.
Proof. move => s. by rewrite !beval_neg_not negbK. Qed.

Lemma bneq_neg_eq {t} (a b : exp sigma (ityp: t)): \b a \!= b =b \~b \b a \= b.
Proof. move => s; by rewrite beval_neq_not_eq beval_neg_not beval_eq_e_eq. Qed.

Lemma bneg_neq_eq {t} (a b : exp sigma (ityp: t)): (\~b \b a \!= b) =b \b a \= b.
Proof. move => s; by rewrite beval_neg_not beval_neq_not_eq  beval_eq_e_eq negbK. Qed.

Transparent eval beval.

Lemma CgeqNlt {t} (e1 e2 : exp sigma (ityp: t)) : \b e1 \>= e2 =b \~b \b e1 \< e2.
Proof.
move=> s //=.
destruct t; destruct ([ e1 ]_ s); destruct ([ e2 ]_s); rewrite negbK leZNgt';
  case: (_ <? _) => //=; by rewrite is_zero_0 (negbTE not_is_zero_1).
Qed.

Lemma CleqNgt {t} (e1 e2 : exp sigma (ityp: t)): \b e1 \<= e2 =b \~b \b e1 \> e2.
Proof.
move=> s //=.
destruct t; destruct ([ e1 ]_ s); destruct ([ e2 ]_s); rewrite negbK leZNgt';
  case: (_ <? _) => //=; by rewrite is_zero_0 (negbTE not_is_zero_1).
Qed.

Lemma CgtNle t (e1 e2 : exp sigma (ityp: t)) : \b e1 \> e2 =b \~b \b e1 \<= e2.
Proof.
move=> s /=.
destruct t.
- move H1 : ( [ e1 ]_s ) => [h1 Hh1].
  move H2 : ( [ e2 ]_s ) => [h2 Hh2].
  case: ifP.
  + case: ifP.
    * by rewrite ltZNge' => ->.
    * by rewrite not_is_zero_1 is_zero_0.
  + case: ifP.
    * by rewrite not_is_zero_1 is_zero_0.
    * move/negbT; by rewrite -ltZNge' => ->.
- move H1 : ( [ e1 ]_s ) => [h1 Hh1].
  move H2 : ( [ e2 ]_s ) => [h2 Hh2].
  case: ifP.
  + case: ifP.
    * by rewrite ltZNge' => ->.
    * by rewrite not_is_zero_1 is_zero_0.
  + case: ifP.
    * by rewrite not_is_zero_1 is_zero_0.
    * move/negbT; by rewrite -ltZNge' => ->.
- move H1 : ( [ e1 ]_s ) => [h1 Hh1].
  move H2 : ( [ e2 ]_s ) => [h2 Hh2].
  case: ifP.
  + case: ifP.
    * by rewrite ltZNge' => ->.
    * by rewrite not_is_zero_1 is_zero_0.
  + case: ifP.
    * by rewrite not_is_zero_1 is_zero_0.
    * move/negbT; by rewrite -ltZNge' => ->.
- move H1 : ( [ e1 ]_s ) => [h1 Hh1].
  move H2 : ( [ e2 ]_s ) => [h2 Hh2].
  case: ifP.
  + case: ifP.
    * by rewrite ltZNge' => ->.
    * by rewrite not_is_zero_1 is_zero_0.
  + case: ifP.
    * by rewrite not_is_zero_1 is_zero_0.
    * move/negbT; by rewrite -ltZNge' => ->.
- move H1 : ( [ e1 ]_s ) => [h1 Hh1].
  move H2 : ( [ e2 ]_s ) => [h2 Hh2].
  case: ifP.
  + case: ifP.
    * by rewrite ltZNge' => ->.
    * by rewrite not_is_zero_1 is_zero_0.
  + case: ifP.
    * by rewrite not_is_zero_1 is_zero_0.
    * move/negbT; by rewrite -ltZNge' => ->.
Qed.

Lemma Cltn_add2r (a b c : Z) :
  - 2 ^^ 31 <= a < 2 ^^ 31 -> - 2 ^^ 31 <= b < 2 ^^ 31 -> - 2 ^^ 31 <= c < 2 ^^ 31 ->
  - 2 ^^ 31 <= a + c < 2 ^^ 31 -> - 2 ^^ 31 <= b + c < 2 ^^ 31 ->
  (\b ([ a ]sc \+ [ c ]sc : exp sigma (ityp: sint)) \< [ b ]sc \+ [ c ]sc) =b \b [ a ]sc \< ([ b ]sc : exp sigma (ityp: sint)) .
Proof.
move=> Ha Hb Hc Hac Hbc s /=.
rewrite !i8_of_i32K s2Z_add; last by rewrite Z2sK // Z2sK.
rewrite s2Z_add; last by rewrite Z2sK // Z2sK.
rewrite !Z2sK //.
case: ifPn => H.
  rewrite ltZ_add2r' in H.
  by rewrite H.
rewrite -leZNgt' in H.
move/leZP/leZ_add2r/leZP in H.
rewrite leZNgt' in H.
by rewrite (negbTE H).
Qed.

Opaque beval eval.

Lemma Cltn_add2r_pos (a b c : Z) : 0 <= a -> 0 <= b -> 0 <= c ->
  a + c < 2 ^^ 31 -> b + c < 2 ^^ 31 ->
  (\b ([ a ]sc \+ [ c ]sc : exp sigma (ityp: sint)) \< [ b ]sc \+ [ c ]sc) =b
  \b [ a ]sc \< ([ b ]sc : exp sigma (ityp: sint)).
Proof. move=> ? ? ? ? ?; rewrite Cltn_add2r //; lia. Qed.

End bequiv_prop.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand
           Vincent Rahli
           Mark Bickford

*)

Require Export sequents2.
Require Export computation_minus.
Require Export approx_props2.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export per_props_nat.
Require Export per_can.
Require Export per_props_top.
Require Export integer_type.
Require Export cequiv_arith_props2.

(*
   H |- a = b in T

     By ArithExceptionCases

     H |- isexc(u op v)
     H, x : u in Int, y: isexc(v) |- a = b in T
     H, x : isexc(u) |- a = b in T
     H |- u in Base
     H |- v in Base
 *)
Definition rule_arith_exception_cases {o}
           (H : barehypotheses)
           (op: ArithOp )
           (a b T u v: @NTerm o)
           (x y : NVar) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality a b T)))
    [ mk_baresequent H (mk_conclax (mk_isexc (mk_arithop op u v))),
      mk_baresequent (snoc (snoc H (mk_hyp x (mk_member u mk_int)))
                                   (mk_hyp y (mk_isexc v)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent (snoc H (mk_hyp x (mk_isexc u)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent H (mk_conclax (mk_member u mk_base)),
      mk_baresequent H (mk_conclax (mk_member v mk_base))
    ]
    [].

Lemma rule_arith_exception_cases_true {o} :
  forall lib (H : barehypotheses)
         op
         (a b T u v : @NTerm o)
         (x y : NVar),
    rule_true lib (rule_arith_exception_cases H op a b T u v x y).
Proof.
  unfold rule_arith_exception_cases, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  rename Hyp4 into hyp5.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_conclax (mk_equality a b T))) as cs.
  clear hyp1 hyp2 hyp3 hyp4 hyp5.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars u)
          # !LIn x (free_vars v)
          # !LIn x (free_vars T)
          # !LIn x (free_vars b)
          # !LIn x (free_vars a)
          # !LIn x (vars_hyps H)
          # x <> y
          # !LIn y (free_vars u)
          # !LIn y (free_vars v)
          # !LIn y (free_vars T)
          # !LIn y (free_vars b)
          # !LIn y (free_vars a)
          # !LIn y (vars_hyps H)) as vhyps.

  clear hyp1 hyp2 hyp3 hyp4 hyp5.
   dwfseq.
  sp; GC;
  try (complete (discover; allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ nxu vhyps ].
  destruct vhyps as [ nxv vhyps ].
  destruct vhyps as [ nxT vhyps ].
  destruct vhyps as [ nxb vhyps ].
  destruct vhyps as [ nxa vhyps ].
  destruct vhyps as [ nxH vhyps ].
  destruct vhyps as [ nxy vhyps ].
  destruct vhyps as [ nyu vhyps ].
  destruct vhyps as [ nyv vhyps ].
  destruct vhyps as [ nyT vhyps ].
  destruct vhyps as [ nyb vhyps ].
  destruct vhyps as [ nya nyH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.

  lsubst_tac.
  allrw @tequality_mkc_isexc.
  allrw <- @member_isexc_iff.
  applydup hyp0 in hyp1.
  clear hyp0.
  rw <- @member_equality_iff.
  rw @tequality_mkc_equality.

  apply if_raises_exceptionc_arithop in hyp1.
  repndors; exrepnd.

  - vr_seq_true in hyp3.
    pose proof (hyp3 (snoc s1 (x,mkc_axiom)) (snoc s2 (x,mkc_axiom))) as hyp.
    clear hyp3.
    repeat (autodimp hyp hyp').

    { apply hyps_functionality_snoc2; simpl; auto;[].
      introv equ' sim'.
      lsubst_tac.
      apply tequality_mkc_isexc.
      split; intro h; auto. GC;[].

      vr_seq_true in hyp4.

      pose proof (hyp4 s1 s') as hyp; clear hyp4.
      repeat (autodimp hyp hyp');[].
      exrepnd.
      lsubst_tac.
      apply tequality_mkc_member_base in hyp0.
      apply cequiv_stable in hyp0.
      eapply raises_exceptionc_preserves_cequivc;[exact hyp0|]; auto.
    }

    { assert (wf_term (mk_isexc u)) as wit.
      { apply wf_isexc; auto. }
      assert (cover_vars (mk_isexc u) s1) as cvit.
      { apply cover_vars_isexc; auto. }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      apply member_isexc_iff; auto.
    }

    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp3.
    rw @tequality_mkc_equality in hyp0; repnd.
    sp.

  -  vr_seq_true in hyp2.
    pose proof (hyp2 (snoc (snoc s1 (x,mkc_axiom)) (y,mkc_axiom))
                    (snoc (snoc s2 (x,mkc_axiom)) (y,mkc_axiom))) as hyp.
    clear hyp2.
    repeat (autodimp hyp hyp').
     dands.

    { (* Hyp Functionality *)
      apply hyps_functionality_snoc2; simpl; auto.
      -  introv equ' sim'.
        lsubst_tac.
        (* have to use
          rw (@similarity_snoc o) in sim'.
          while goal is still tequality.
          Because after apply tequality_mkc_isexc the
          exrepnd won't destruct the existential.
        *)
        apply (@similarity_snoc o) in sim'. simpl in sim'. exrepnd.
        apply tequality_mkc_isexc; split; auto.
        vr_seq_true in hyp5.
        pose proof (hyp5 s1 s2a) as hyp. clear hyp5.
        repeat (autodimp hyp hyp');
        apply snoc_inj in sim'0; sp; subst; auto.
        lsubst_tac.
        apply tequality_mkc_member_base in p1.
        apply cequiv_stable in p1.
        eapply raises_exceptionc_preserves_cequivc.
        exact p1.
        auto.
     - apply hyps_functionality_snoc2; simpl; auto.
       introv equ' sim'.
        lsubst_tac.
        vr_seq_true in hyp4.
          pose proof (hyp4 s1 s') as hyp; clear hyp4.
          repeat (autodimp hyp hyp');[].
          exrepnd.
         lsubst_tac.
         apply tequality_mkc_member_base in hyp2.
         apply cequiv_stable in hyp2.
         eapply cequiv_member_int; eauto.
    }

    { (* Similarity *)
      assert (wf_term (mk_isexc v)) as wit. apply wf_isexc; auto.
      assert (cover_vars (mk_isexc v) (snoc s1 (x, mkc_axiom))) as cvit.
      { apply cover_vars_isexc; dands; auto.
       apply cover_vars_snoc_weak. auto. }
      assert (wf_term (mk_member u mk_int)) as wit2 by auto.
      assert (cover_vars (mk_member u mk_int) s1) as cvit2.
      { apply cover_vars_member; dands; auto. }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      sim_snoc.
      dands; auto.
      lsubst_tac.
      rw <- @member_member_iff.
      - eapply computes_to_integer_member_int; eauto.
      - lsubst_tac.
      apply member_isexc_iff. auto.
    }

   { (* Functionality and Truth *)
    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp7.
    rw @tequality_mkc_equality in hyp2; repnd.
    sp.
   }
Qed.

(*
   H |- a = b in T

     By minusExceptionCases

     H |- isexc(-t)
     H, x : isexc(t) |- a = b in T
     H |- t in Base
 *)
Definition rule_minus_exception_cases {o}
           (H : barehypotheses)
           (a b T t: @NTerm o)
           (x : NVar) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality a b T)))
    [ mk_baresequent H (mk_conclax (mk_isexc (mk_minus t))),
      mk_baresequent (snoc H (mk_hyp x (mk_isexc t)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent H (mk_conclax (mk_member t mk_base))
    ]
    [].

Lemma rule_minus_exception_cases_true {o} :
  forall lib (H : barehypotheses)
         (a b T t : @NTerm o)
         (x : NVar),
    rule_true lib (rule_minus_exception_cases H a b T t x).
Proof.
 unfold rule_minus_exception_cases, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars t)
          # !LIn x (free_vars T)
          # !LIn x (free_vars b)
          # !LIn x (free_vars a)
          # !LIn x (vars_hyps H)) as vhyps.

  clear hyp1 hyp2 hyp3.
   dwfseq.
  sp; GC;
  try (complete (discover; allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ nxu vhyps ].
  destruct vhyps as [ nxT vhyps ].
  destruct vhyps as [ nxb vhyps ].
  destruct vhyps as [ nxa nxH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.

  lsubst_tac.
  allrw @tequality_mkc_isexc.
  allrw <- @member_isexc_iff.
  applydup hyp0 in hyp1.
  clear hyp0.
  rw <- @member_equality_iff.
  rw @tequality_mkc_equality.

  apply @if_raises_exceptionc_minus  in hyp1.
  apply @if_raises_exceptionc_minus  in hyp4.

 - vr_seq_true in hyp2.
    pose proof (hyp2 (snoc s1 (x,mkc_axiom)) (snoc s2 (x,mkc_axiom))) as hyp.
    clear hyp2.
    repeat (autodimp hyp hyp').

    { apply hyps_functionality_snoc2; simpl; auto;[].
      introv equ' sim'.
      lsubst_tac.
      apply tequality_mkc_isexc.
      split; intro h; auto. GC;[].

      vr_seq_true in hyp3.

      pose proof (hyp3 s1 s') as hyp; clear hyp4.
      repeat (autodimp hyp hyp');[].
      exrepnd.
      lsubst_tac.
      apply tequality_mkc_member_base in hyp0.
      apply cequiv_stable in hyp0.
      eapply raises_exceptionc_preserves_cequivc;[exact hyp0|]; auto.
    }

    { assert (wf_term (mk_isexc t)) as wit.
      { apply wf_isexc; auto. }
      assert (cover_vars (mk_isexc t) s1) as cvit.
      { apply cover_vars_isexc; auto. }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      apply member_isexc_iff; auto.
    }

    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp2.
    rw @tequality_mkc_equality in hyp0; repnd.
    sp.
Qed.

(*
   H |- op x exc(a,b) ~ exc(a,b)

     By exceptionArith

     H |- x in Z
 *)
Definition rule_exception_arith {o}
           (H : barehypotheses)
           (op: ArithOp )
           (x a b : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_cequiv (mk_arithop op x (mk_exception a b)) (mk_exception a b))))
    [
      mk_baresequent H (mk_conclax (mk_member x mk_int))
    ]
    [].

Lemma rule_exception_arith_true3 {o} :
  forall lib (H : barehypotheses)
         op
         (x a b : @NTerm o),
    rule_true3 lib (rule_exception_arith H op x a b).
Proof.
  intros.
  unfold rule_exception_arith, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp as [ws1 hyp1].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (H)
                      ||- (mk_conclax
                             (mk_cequiv (mk_arithop op x (mk_exception a b)) (mk_exception a b)))) as wfc.
  { clear hyp1.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp.
    introv i; allrw in_app_iff; repndors; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.

  lsubst_tac.
  rw @tequality_mkc_cequiv.
  rw @equality_in_mkc_cequiv.
  apply member_if_inhabited in hyp1.
  apply tequality_member_int in hyp0; auto;[].
  clear hyp1.
  unfold equality_of_int in hyp0; exrepnd; spcast.
  dands; spcast; try (apply computes_to_valc_refl; eauto 2 with slow).

  {
    split; introv h; spcast.

    - eapply cequivc_trans;
      [apply implies_cequivc_mkc_arithop;
       [apply computes_to_valc_implies_cequivc;exact hyp1
       |apply cequivc_refl]
      |].
      apply cequivc_arithop_integer_exception.

    - eapply cequivc_trans;
      [apply implies_cequivc_mkc_arithop;
       [apply computes_to_valc_implies_cequivc;exact hyp0
       |apply cequivc_refl]
      |].
      apply cequivc_arithop_integer_exception.
  }

  {
    eapply cequivc_trans;
      [apply implies_cequivc_mkc_arithop;
       [apply computes_to_valc_implies_cequivc;exact hyp0
       |apply cequivc_refl]
      |].
    apply cequivc_arithop_integer_exception.
  }
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall H O L Hprime Oprime Lprime Lprimeprime I Iprime : Universe, ((wd_ Oprime Lprimeprime /\ (wd_ Oprime Lprime /\ (wd_ O H /\ (wd_ O I /\ (wd_ Oprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ O L /\ (wd_ Oprime Lprimeprime /\ (col_ Oprime Lprime Lprimeprime /\ (col_ Oprime Iprime Hprime /\ (col_ O I H /\ col_ O I L))))))))))) -> col_ H O L)).
Proof.
  time tac.
Qed.

End FOFProblem.


Add LoadPath "bezier-functions".

Require Import recursive.
Require Import auxiliary.
Require Import QArith.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.

Lemma bezier_curve_recursive_symm_fstdegree :
  forall (P0 P1 : point) (q : Q),
    calc_bezier_recursive (P0 :: [P1]) q == calc_bezier_recursive (rev (P0 :: [P1])) (1 - q).
Proof.
  intros P0 P1 q.
  unfold calc_bezier_recursive. unfold rev. simpl.
  destruct P0 as [x0 y0]. destruct P1 as [x1 y1].
  unfold "==". simpl. split.
  { ring. }
  { ring. }
Qed.

Theorem bezier_curve_recursive_symm : forall (b : bezier_curve) (q : Q),
  calc_bezier_recursive b q == calc_bezier_recursive (rev b) (1 - q).
Proof.
  intros b Qed.
  induction b as [h| h b'].
  {
    unfold calc_bezier_recursive. unfold rev. simpl.
    destruct h as [xh yh]. unfold "==". simpl.
    split.
    { ring. }
    { ring. }
  }
  {
    unfold calc_bezier_recursive in IHb'. unfold rev in IHb'. simpl.
    unfold calc_bezier_recursive. unfold rev. simpl.
    admit.
  }
Admitted.


From isla Require Import opsem.

Definition a7418 : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 39%Z (Val (Val_Symbolic 38%Z) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 44%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (ZeroExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffc%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 48%Z (Unop (Extract 63%N 0%N) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop Concat [Manyop Concat [Manyop Concat [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Bvnot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 48%Z) Mk_annot) (Unop (Extract 63%N 0%N) (Val (Val_Bits (BV 128%N 0x3f%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Val (Val_Symbolic 48%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (SignExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (SignExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffffffffffffffffffc%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
  Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
  Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
  Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
  Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
  Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  tnil
.


Require Import propInv5.
Local Open Scope Z.

Definition _timer1 :=36000.
Definition _timer0 := _timer1-1.
Definition _logvar := ON.
Definition _hands0 :=
 (make (of_Z (_timer1+1)) ON).

Definition _hands1 := _hands0.[of_Z _timer1 <- _logvar].
Definition _dryer0 := make (of_Z (_timer1+1)) ON.
Definition _dryer1 := _dryer0.[of_Z _timer1 <- _dryer0.[of_Z (_timer1-1)]].
Definition _ctrlState0 := (make (of_Z (_timer1+1)) ctrlDrying).
Definition _ctrlState1 := _ctrlState0.[of_Z _timer1 <- _ctrlState0.[of_Z (_timer1-1)]].
Definition _ctrlTimer0 :=0.
Definition _ctrlTimer1 := _ctrlTimer0 + 1.
Definition _dryer2 := _dryer1.[of_Z _timer1 <- ON].
Definition _ctrlState2 := _ctrlState1.[of_Z _timer1 <- ctrlDrying].
Definition _ctrlTimer2 := 0.

Theorem proof5_5 :
 exists hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 ctrlState2 ctrlTimer2
(logvar : bool),
 ~((startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 logvar) /\
    ctrlState1.[of_Z timer1]<>ctrlWaiting /\ ctrlState1.[of_Z timer1]=ctrlDrying /\ hands1.[of_Z timer1]=ON /\ ctrlTimer2=0 /\
 ctrlState2=ctrlState1.[of_Z timer1 <- ctrlDrying] /\ ctrlTimer2<10
 ->
    (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1)).

Proof.
exists _hands0.
exists _hands1.
exists _dryer0.
exists _dryer1.
exists _ctrlState0.
exists _ctrlState1.
exists _ctrlTimer0.
exists _ctrlTimer1.
exists _timer0.
exists _timer1.
exists _ctrlState2.
exists _ctrlTimer2.
exists _logvar.
unfold not.
intros.
assert (Hcond :
 (startnewloop _hands0 _hands1 _dryer0 _dryer1 _ctrlState0 _ctrlState1 _ctrlTimer0 _ctrlTimer1 _timer0 _timer1 _logvar) /\
    _ctrlState1.[of_Z _timer1]<>ctrlWaiting /\ _ctrlState1.[of_Z _timer1]=ctrlDrying /\ _hands1.[of_Z _timer1]=ON /\
     _ctrlTimer2=0 /\  _ctrlState2=_ctrlState1.[of_Z _timer1 <- ctrlDrying] /\ _ctrlTimer2<10).

split.
split.
split.
(*proving propInv for timer0*)
unfold propInv5.
intros.
unfold _timer0 in H0.
unfold _timer1 in H0.
elimtype False.
auto with zarith.
(*proving extraInv for timer0*)
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
unfold _timer0.
unfold _timer1.
auto with zarith.
split.
unfold _ctrlTimer0.
auto with zarith.
split.
intros.
right.
unfold _ctrlState0.
apply get_make.
intros.
split.
auto with zarith.
split.
unfold _hands0.
apply get_make.
split.
unfold _dryer0.
apply get_make.
intros.
elimtype False.
unfold _ctrlTimer0 in H1.
auto with zarith.
split.
symmetry.
apply Zeq_plus_swap.
reflexivity.
repeat split.
repeat split.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
rewrite get_make.
discriminate.
auto.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
rewrite get_make.
reflexivity.
auto.

(*proving negating requirement*)
apply H in Hcond.
inversion_clear Hcond.
unfold propInv5 in H0.
specialize (H0 (_timer1-(36000-1))).
assert (Hpremise : (0<(_timer1-(36000-1)) /\ (_timer1-(36000-1))<=(_timer1-(36000-1)) /\
 _dryer1.[of_Z (_timer1-(36000-1))]=ON)).
unfold _timer1.
auto with zarith.
apply H0 in Hpremise.
elim Hpremise.
intros.
inversion_clear H2.
inversion_clear H4.
inversion_clear H5.
replace _dryer1.[of_Z x] with _dryer0.[of_Z x] in H6.
unfold _dryer0 in H6.
rewrite get_make in H6.
contradict H6.
discriminate.
auto.
Qed.