Require Import String Ascii List ZArith little_w_string.

Import syntax str AB A D L.

Inductive lex_state : Type :=
  Start | In_num | In_id | In_spec.

Inductive token : Type :=
  T_id (_ : string) | T_num (_ : Z) | T_variables | T_in | T_end
| T_semicolon | T_assign | T_lt | T_plus | T_skip | T_while
| T_do | T_done | T_open | T_close | T_open_B | T_close_B
| T_minus | T_comma | T_bang | T_conj | T_open_S | T_close_S.

Open Scope Z_scope.
Open Scope char_scope.
Open Scope string_scope.

Inductive char_category : Type :=
 Digit | Alpha | Space | Other.

Fixpoint Z_of_rev_string (s:string) : Z :=
 match s with
   "" => 0
 | String a tl => (Z_of_nat (nat_of_ascii a) -
                   Z_of_nat (nat_of_ascii "0"%char))+10*Z_of_rev_string tl
 end.

Definition T_num_of_rev_string (s:string) : token :=
  T_num (Z_of_rev_string s).

Fixpoint rev_string_aux (s acc:string) {struct s}: string :=
 match s with "" => acc | String a s' => rev_string_aux s' (String a acc) end.

Definition rev_string (s:string) := rev_string_aux s "".

Definition string_token (rev_buf :string) : token :=
  let buf := rev_string rev_buf in
  if string_dec buf "variables" then
     T_variables
  else if string_dec buf "in" then
     T_in
  else if string_dec buf "end" then
     T_end
  else if string_dec buf "while" then
     T_while
  else if string_dec buf "do" then
     T_do
  else if string_dec buf "done" then
     T_done
  else if string_dec buf "skip" then
     T_skip
  else T_id buf.

Fixpoint special_tokens (rev_buf:string) (acc:list token) {struct rev_buf}:
  option (list token) :=
  match rev_buf with
    "" => Some acc
  | String ";" tl => special_tokens tl (T_semicolon::acc)
  | String "=" (String ":" tl) => special_tokens tl (T_assign::acc)
  | String "<" tl => special_tokens tl (T_lt::acc)
  | String "+" tl => special_tokens tl (T_plus::acc)
  | String "(" tl => special_tokens tl (T_open::acc)
  | String ")" tl => special_tokens tl (T_close::acc)
  | String "{" tl => special_tokens tl (T_open_B::acc)
  | String "}" tl => special_tokens tl (T_close_B::acc)
  | String "[" tl => special_tokens tl (T_open_S::acc)
  | String "]" tl => special_tokens tl (T_close_S::acc)
  | String "-" tl => special_tokens tl (T_minus::acc)
  | String "," tl => special_tokens tl (T_comma::acc)
  | String "\" (String "/" tl) => special_tokens tl (T_conj::acc)
  | String "!" tl => special_tokens tl (T_bang::acc)
  | _ => None
  end.

Definition Z_of_ascii (a:ascii) := Z_of_nat(nat_of_ascii a).

Definition is_digit (a:ascii) : bool :=
  match Z.compare (Z_of_ascii a) (Z_of_ascii "0"%char) with
    Lt => false
  | Eq => true
  | Gt => match Z.compare (Z_of_ascii a) (Z_of_ascii "9"%char) with
      Gt => false
    | _ =>  true
    end
  end.

Fact example_is_digit : is_digit "8" = true.
Proof refl_equal true.

Definition is_alpha (a:ascii) : bool :=
  match Z.compare (Z_of_ascii a) (Z_of_ascii "A"%char) with
    Lt => false
  | Eq => true
  | Gt => match Z.compare (Z_of_ascii a) (Z_of_ascii "Z"%char) with
      Gt => match Z.compare (Z_of_ascii a) (Z_of_ascii "_"%char) with
        Eq => true
      | _ => match Z.compare (Z_of_ascii a) (Z_of_ascii "a"%char) with
          Lt => false
        | Eq => true
        | Gt => match Z.compare (Z_of_ascii a) (Z_of_ascii "z"%char) with
            Gt => false
          | _ => true
          end
        end
      end
    | _ => true
    end
  end.

Definition is_space (a:ascii) : bool :=
  if ascii_dec a " " then true
  else if ascii_dec a "010" then true
  else if ascii_dec a "013" then true
  else if ascii_dec a "009" then true
  else false.

Definition cat_of_char (a:ascii) : char_category :=
  if is_digit a then
     Digit
  else if is_alpha a then
     Alpha
  else if is_space a then
     Space
  else Other.

Fixpoint tokenize (s:string)(st:lex_state)(rev_buf:string) {struct s}
    :list token :=
  match s with
    "" =>
      match st with
        Start => nil
      | In_num => T_num_of_rev_string rev_buf::nil
      | In_id => string_token rev_buf::nil
      | In_spec => match special_tokens rev_buf nil with
                     Some ts => ts | None => nil
                   end
      end
  | String a s' =>
      match st with
        Start =>
          match cat_of_char a with
            Digit =>
            tokenize s' In_num (String a "")
          | Alpha =>
             tokenize s' In_id (String a "")
          | Space =>
             tokenize s' Start rev_buf
          | Other =>
            tokenize s' In_spec (String a "")
          end
      | In_num =>
          match cat_of_char a with
            Digit =>
            tokenize s' In_num (String a rev_buf)
          | Alpha =>
            T_num (Z_of_rev_string rev_buf)::
            tokenize s' In_id (String a "")
          | Space =>
            T_num (Z_of_rev_string rev_buf)::tokenize s' Start ""
          | Other =>
            T_num (Z_of_rev_string rev_buf)::tokenize s' In_spec (String a "")
          end
      | In_id =>
          match cat_of_char a with
            Digit =>
            tokenize s' In_id (String a rev_buf)
          | Alpha =>
             tokenize s' In_id (String a rev_buf)
          | Space =>
             string_token rev_buf::tokenize s' Start rev_buf
          | Other =>
             string_token rev_buf::tokenize s' In_spec (String a "")
          end
      | In_spec =>
          match cat_of_char a with
            Digit =>
            match special_tokens rev_buf nil with
              Some ts => (ts++tokenize s' In_num (String a ""))%list
            | None => nil
            end
          | Alpha =>
            match special_tokens rev_buf nil with
              Some ts => (ts++tokenize s' In_id (String a ""))%list
            | None => nil
            end
          | Space =>
            match special_tokens rev_buf nil with
              Some ts => (ts++tokenize s' Start "")%list
            | None => nil
            end
          | Other =>
            tokenize s' In_spec (String a rev_buf)
          end
      end
  end.

Fixpoint parse_variables (l:list token) :
  option ((list (string*Z))*list token) :=
  match l with
    T_id s::T_minus::T_num n::T_in::tl => Some((s,-n)::nil, tl)
  | T_id s::T_num n::T_in::tl => Some((s,n)::nil, tl)
  | T_id s::T_minus::T_num n::T_semicolon::tl =>
    match parse_variables tl with
      Some(l,r) => Some((s,-n)::l,r)
    | None => None
    end
  | T_id s::T_num n::T_semicolon::tl =>
    match parse_variables tl with
      Some(l,r) => Some((s,n)::l,r)
    | None => None
    end
  | _ => None

  end.

Definition parse_right_expr (f:list token -> nat -> option(aexpr*list token)):
  list token -> nat -> aexpr -> option (aexpr*list token) :=
  fix p_r_e (l:list token) (n:nat)(acc: aexpr) {struct n} :
      option (aexpr*list token) :=
    match n with
      0%nat => None
    | S p =>
      match l with
        T_plus::T_minus::T_num n::tl => p_r_e tl p (aplus acc (anum (-n)))
      | T_plus::t_atom::tl =>
        match t_atom with
          T_num n => p_r_e tl p (aplus acc (anum n))
        | T_id s => p_r_e tl p (aplus acc (avar s))
        | T_open => match f tl p with
                      Some(e,T_close::tl') => p_r_e tl' p (aplus acc e)
                    | _ => None
                    end
        | _ => None
        end
      | _ => Some(acc, l)
      end
    end.

Fixpoint parse_expr (l:list token)(n:nat){struct n}
   : option(aexpr*list token) :=
  match n with
    0%nat => None
  | S p =>
    match l with
      T_num n::tl => parse_right_expr parse_expr tl p (anum n)
    | T_minus::T_num n::tl => parse_right_expr parse_expr tl p (anum (-n))
    | T_id s::tl => parse_right_expr parse_expr tl p (avar s)
    | T_open::tl => match parse_expr tl p with
                      Some(e,T_close::tl') =>
                      parse_right_expr parse_expr tl' p e
                    | _ => None
                    end
    | _ => None
    end
  end.

Fixpoint parse_expr_list(l:list token)(n:nat) {struct n}:
  (list aexpr)*list token :=
  match n with
    0%nat => (nil,l)
  | S p =>
    match parse_expr l n with
      Some(e,tl) =>
      match tl with
        T_comma::tl =>
        let (l,tl) := parse_expr_list tl p in (e::l,tl)
      | _ => (e::nil, tl)
      end
    | None => (nil, l)
    end
  end.

Definition parse_bexpr (l:list token) (n:nat) : option(bexpr * list token) :=
  match parse_expr l n with
    Some(e1, T_lt::l') =>
    match parse_expr l' n with
      Some (e2, l'') => Some (blt e1 e2, l'')
    | _ => None
    end
  | _ => None
  end.

Fixpoint parse_elem_assert (l:list token) (n:nat) {struct n}:
  option(assert*list token) :=
match parse_bexpr l n with
  Some(e, tl) => Some(a_b e, tl)
| None =>
  match n with
    0%nat => None
  | S p =>
    match l with
      T_id s::T_open::tl =>
      let (l, tl) := parse_expr_list tl n in
      match tl with
        T_close::tl => Some(pred s l, tl)
      | _ => None
      end
    | T_bang::l =>
      match parse_elem_assert l p with
        Some(a, l) => Some(a_not a, l)
      | _ => None
      end
    | _ => None
    end
  end
end.

Fixpoint parse_assert (l:list token)(n:nat) {struct n}:
  option(assert*list token) :=
match n with
  0%nat => None
| S p =>
  match parse_elem_assert l p with
    Some(a1, T_conj::tl) =>
    match parse_assert tl p with
      Some(a2, tl) => Some(a_conj a1 a2, tl)
    | None => None
    end
  | Some(a, tl) => Some(a, tl)
  | None => None
  end
end.

Definition parse_elem_instr
   (parse_instr:list token -> nat -> option(instr*list token))
   (l:list token)(n:nat) :option(instr*list token) :=
 match l with
   T_skip::tl => Some(skip, tl)
 | T_id var::T_assign::tl =>
   match parse_expr tl n with
     Some(e,tl) => Some(assign var e, tl)
   | None => None
   end
 | T_while::tl =>
   match parse_bexpr tl n with
     Some(b,T_do::tl) =>
     match parse_instr tl n with
       Some(i,T_done::tl) =>
       Some(while b i, tl)
     | _ => None
     end
   | _ => None
   end
 | T_open_B::tl =>
   match parse_instr tl n with
     Some(i,T_close_B::tl) => Some(i,tl)
   | _ => None
   end
 | _ => None
 end.

Definition parse_elem_a_instr
   (parse_instr:list token -> nat -> option(a_instr*list token)) :=
fix peai (l:list token)(n:nat){struct n} : option(a_instr*list token):=
 match n with
   O%nat => None
 | S p =>
   match l with
     T_skip::tl => Some(a_skip, tl)
   | T_open_S::tl =>
     match parse_assert tl n with
       Some(a,T_close_S::tl) =>
       match peai tl p with
         Some(i, tl) => Some(prec a i, tl)
       | None => None
       end
     | _ => None
     end
   | T_id var::T_assign::tl =>
     match parse_expr tl n with
       Some(e,tl) => Some(a_assign var e, tl)
     | None => None
     end
   | T_while::tl =>
     match parse_bexpr tl n with
       Some(b,T_do::T_open_S::tl) =>
       match parse_assert tl n with
         Some(a,T_close_S::tl) =>
         match parse_instr tl n with
           Some(i,T_done::tl) =>
           Some(a_while b a i, tl)
         | _ => None
         end
       | _ =>  None
       end
     | _ => None
     end
   | T_open_B::tl =>
     match parse_instr tl n with
       Some(i,T_close_B::tl) => Some(i,tl)
     | _ => None
     end
   | _ => None
   end
 end.

Fixpoint parse_a_instr (l:list token)(n:nat){struct n} :
  option(a_instr*list token) :=
  match n with
    0%nat => None
  | S p =>
    match parse_elem_a_instr parse_a_instr l p with
      Some(i,tl) as it =>
      match tl with
        T_semicolon::tl =>
        match parse_a_instr tl p with
          Some(i', tl) =>
          Some(a_sequence i i', tl)
        | None => None
        end
      | _ => it
      end
    | _ => None
    end
  end.

Fixpoint parse_instr (l:list token) (n:nat) {struct n} :
  option(instr*list token) :=
  match n with
    0%nat => None
  | S p =>
    match parse_elem_instr parse_instr l p with
      Some(i,tl) as it =>
      match tl with
        T_semicolon::tl =>
        match parse_instr tl p with
          Some(i', tl) =>
          Some(sequence i i', tl)
        | None => None
        end
      | _ => it
      end
    | _ => None
    end
  end.

Definition parse_program (l:list token) :
   option((list(string*Z))*instr) :=
   match l with
     T_variables::tl =>
     match parse_variables tl with
       Some(l,r) =>
        match parse_instr r (List.length r) with
          Some (i, T_end::nil) => Some(l,i)
        | _ => None
        end
     | None => None
     end
   | _ => None
   end.

Definition parse_a (s:string) :=
   match tokenize s Start "" with
     T_variables::tl =>
     match parse_variables tl with
       Some(l,r) =>
        match parse_a_instr r (List.length r) with
          Some (i, T_end::nil) => Some(l,i)
        | _ => None
        end
     | None => None
     end
   | _ => None
   end.

Definition parse (s : string) : option((list(string*Z))*instr) :=
  parse_program (tokenize s Start "").

Definition parse_instr' (s:string) :=
   let l := tokenize s Start "" in
   match parse_a_instr l (List.length l) with
     Some (i, nil) => i
   | _ => a_skip
   end.

Definition parse_instr'' (s:string) := un_annot (parse_instr' s).

Definition string_of_Z_aux (f:positive -> Z -> string -> string) :=
  fun (p:positive)(x:Z)(acc:string) =>
    match x with
      0 => if string_dec acc "" then "0" else acc
  | _ => let (q,r) := Z.div_eucl x 10 in
          f p q (String (ascii_of_nat (nat_of_ascii "0"%char + Z.abs_nat r))
                   acc)
  end.

Fixpoint string_of_Z_aux2 (p:positive)(x:Z)(acc:string){struct p} : string :=
  match p with
    xH => "Bad arguments for string_of_Z"
  | xO p => string_of_Z_aux string_of_Z_aux2 p x acc
  | xI p => string_of_Z_aux string_of_Z_aux2 p x acc
  end.

Definition string_of_Z (x:Z) : string :=
  match x with
    0 => "0"
  | Zpos p => string_of_Z_aux2 (xI (xI p)) x ""
  | Zneg p => String "-" (string_of_Z_aux2 (xI (xI p)) (Zpos p) "")
  end.

Definition eol := String "010" "".

Fixpoint string_of_env (l:list(string*Z)) : string :=
  match l with
  | (s,n)::nil => s ++ " " ++ string_of_Z n
  | (s,n)::tl =>
    s ++ " " ++ string_of_Z n ++ ";" ++ eol ++ string_of_env tl
  | nil => ""
  end.

Fixpoint string_of_aexpr (e:aexpr) : string :=
  match e with
    anum x => string_of_Z x
  | avar a => a
  | aplus e1 ((aplus _ _) as e2) => string_of_aexpr e1 ++ "+(" ++
                                     string_of_aexpr e2 ++ ")"
  | aplus e1 e2 => string_of_aexpr e1 ++ "+" ++ string_of_aexpr e2
  end.

Definition string_of_bexpr (e:bexpr) :string :=
  match e with
    blt e1 e2 => string_of_aexpr e1 ++ "<" ++ string_of_aexpr e2
  end.

Fixpoint string_of_instr (i:instr) :string :=
  match i with
    skip => "skip"
  | sequence ((sequence _ _) as i1) i2 =>
     "{" ++ string_of_instr i1 ++ "};" ++ eol ++ string_of_instr i2
  | sequence i1 i2 =>
    string_of_instr i1 ++ ";" ++ eol ++ string_of_instr i2
  | assign x e => x ++ ":=" ++ string_of_aexpr e
  | while b i => "while " ++ string_of_bexpr b ++ " do" ++ eol ++
                  string_of_instr i ++ eol ++ "done" ++ eol
  end.

Fixpoint string_of_list (l:list aexpr) : string :=
  match l with
    nil => ""
  | e::nil => string_of_aexpr e
  | e::tl => string_of_aexpr e ++ "," ++ string_of_list tl
  end.

Fixpoint string_of_assert (a:assert) :string :=
  match a with
    a_b b => string_of_bexpr b
  | a_not a => "not " ++ string_of_assert a
  | a_conj a1 a2 => string_of_assert a1 ++ "&" ++ string_of_assert a2
  | pred s l => s ++ "(" ++ string_of_list l ++ ")"
  end.

Fixpoint string_of_a_instr (i:a_instr) :string :=
match i with
  a_skip => "skip"
  | a_sequence ((a_sequence _ _) as i1) i2 =>
     "{" ++ string_of_a_instr i1 ++ "};" ++ eol ++ string_of_a_instr i2
  | a_sequence i1 i2 =>
    string_of_a_instr i1 ++ ";" ++ eol ++ string_of_a_instr i2
  | a_assign x e => x ++ ":=" ++ string_of_aexpr e
  | a_while b a i => "while " ++ string_of_bexpr b ++ " do" ++ eol ++
      "[" ++ string_of_assert a ++ "]" ++ eol ++
                  string_of_a_instr i ++ eol ++ "done" ++ eol
  | prec a i => "[" ++ string_of_assert a ++ "]" ++ eol ++ string_of_a_instr i
  end.

Definition interp (n:nat) (s:string) : string :=
   match parse s with
     Some(r,i) =>
     match f_star n r i with
       Some (l,skip) => "Complete computation" ++ eol ++
                        string_of_env l
     | Some (l,i) => "Incomplete computation" ++ eol ++
                      "variables " ++ string_of_env l ++ " in" ++
                      eol ++ string_of_instr i ++ "end"
     | None => "An error occurred while executing"
     end
   | None => "An error occurred while parsing"
   end.

Definition PP (s:string) := True.

Ltac pretty_hyp_curses id id1 :=
  match type of id with
    exec ?r ?i ?r' => idtac "ok";
    let res := eval vm_compute in
         ("execution in state " ++ eol ++ string_of_env r ++ eol ++
                "of instruction" ++ eol ++ String "027" "[0;31;48m" ++
                string_of_instr i ++ String "027" "[0;30;48m" ++ eol ++
                "terminates and yields" ++ eol ++ string_of_env r') in
    (assert (id1 : PP res ); [unfold PP; trivial| idtac])
  end.

Ltac pretty_hyp id :=
  match type of id with
    exec ?r ?i ?r' => idtac "ok";
    let res := eval vm_compute in
         ("execution in state " ++ eol ++ string_of_env r ++ eol ++
                "of instruction" ++ eol ++ string_of_instr i ++ eol ++
                "terminates and yields" ++ eol ++ string_of_env r') in
    (assert (PP res ); [unfold PP; trivial| idtac])
  end.

Definition parse_assert' (s:string) :=
  let l := tokenize s Start "" in
  match parse_assert l (List.length l) with
    Some(a,tl) => a
  | None => pred "true" nil
  end.

Ltac parse_it :=
  match goal with
    |- context[parse_assert' ?x]=>
    let v := eval vm_compute in (parse_assert' x) in
       change (parse_assert' x) with v; parse_it
  | |- context[parse_instr' ?x] =>
    let v := eval vm_compute in (parse_instr' x) in
      change (parse_instr' x) with v; parse_it
  | |- _ => idtac "parse_done"
  end.

Ltac expand_semantics :=
  cbv beta iota zeta delta [str.string_dec string_dec string_rec
  string_rect sumbool_rec sumbool_rect Ascii.ascii_rec Ascii.ascii_rect
  Ascii.ascii_dec Bool.bool_dec bool_rec bool_rect eq_rec_r eq_rec eq_rect
  sym_eq].


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                         notacc_white_ancestor.v                          *)
(****************************************************************************)

Section notacc_white_ancestor.

Require Export reachable.
Require Export lemma_step.
Require Export notfree_notacc.
Require Export notacc_white_nogrey.
Require Export Peano_dec.

Notation Reachable := (reachable node) (only parsing).
Notation Step := (step (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Stream := (stream state) (only parsing).
Notation Stream_formula := (stream_formula state) (only parsing).
Notation Trace := (trace (fun (a : label) (s t : state) => transition s t a))
  (only parsing).

Definition notacc_white_exgrey_reach (s : state) (n : node) : Prop :=
  ~ accessible node (hp s) rt n /\
  mk s n = white /\
  (exists g : nat, card_color grey (mk s) g /\ g <> 0) /\
  (forall m : node,
   reachable node (hp s) m n -> mk s m = white \/ mk s m = free).

Definition notacc_white_reach (s : state) (n : node) : Prop :=
  ~ accessible node (hp s) rt n /\
  mk s n = white /\
  (forall m : node,
   reachable node (hp s) m n -> mk s m = white \/ mk s m = free).

Lemma add_notacc_white_reach :
 forall (s t : state) (n : node),
 nogrey_accn_imp_blackn s ->
 notacc_white_exgrey_reach s n -> add_edge s t -> notacc_white_reach t n.

intros s t n H_inv H addedge; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; split.
eapply add_notaccess_notaccest.
eexact notacc_n_s.
eexact addedge.
split.
 eapply add_white_nogrey.
 eexact mksn.
eexact notacc_n_s.
 eexact addedge.
intro m; intro H; eapply add_ancestor_col.
eexact notacc_n_s.
eexact H_anc.
eexact addedge.
eexact H.

Qed.

Hint Resolve add_notacc_white_reach.

Lemma remove_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> remove_edge s t -> notacc_white_reach t n.

intros s t n H removeedge; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; split; eauto.
Qed.

Hint Resolve remove_notacc_white_reach.

Lemma alloc_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> alloc s t -> notacc_white_reach t n.

intros s t n H alloc; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; split.
apply alloc_notacces_t with (s := s); try assumption.
split; [ rewrite mksn; discriminate | assumption ].
split.
apply alloc_whites_whitet with (s := s); assumption.
intros m H_reach; apply alloc_ancestor_col with (s := s) (n := n);
 try assumption.
apply alloc_notacces_t with (s := s); try assumption.
split; [ rewrite mksn; discriminate | assumption ].
Qed.

Hint Resolve alloc_notacc_white_reach.

Lemma gccall_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> gc_call s t -> notacc_white_reach t n.

intros s t n H gccall; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; elim gccall; clear gccall.

(* 1st case impossible no grey *)
intros ctls ctlt heap H_col H_init; elim H_grey; clear H_grey.
intros g H; elim H; clear H.
intros H_grey gdifO.
absurd (exists g : nat, card_color grey (mk s) g /\ g = 0).
intro H; elim H; clear H.
intros g' H; elim H; clear H.
intros H_grey' g'eqO; absurd (g' = 0); auto.
cut (g' = g);
 [ intro g'eqg; rewrite g'eqg; assumption
 | apply unicity_card with (M := mk s) (P := fun c : color => c = grey);
    assumption ].
exists 0; split; auto.
constructor.
intro m; elim (H_col m); intro mksm; rewrite mksm; discriminate.

(* 2nd case : a grey is blackened  *)
intros ctls ctlt heap grey_node; split.
rewrite heap; assumption.
split;
 [ apply grey_white with (s := s); auto
 | intros m H_reach_m; apply grey_ancestor_col with (s := s) (n := n); auto ].

(* grey_white : a white node remains white
   grey_ancestor_col: an ancestor which is white or free does not change *)

(* 3rd case g cannot be 0 *)
intros ctls ctlt heap H_col m mksm upd_col; elim H_grey; clear H_grey.
intros g H; elim H; clear H.
intros H_grey gdifO;
 absurd (exists g : nat, card_color grey (mk s) g /\ g = 0).
intro H; elim H; clear H.
intros g' H; elim H; clear H.
intros H_grey' g'eqO; absurd (g' = 0); auto.
cut (g' = g);
 [ intro g'eqg; rewrite g'eqg; assumption
 | apply unicity_card with (M := mk s) (P := fun c : color => c = grey);
    assumption ].
exists 0; split; [ constructor; auto | auto ].
Qed.

Hint Resolve gccall_notacc_white_reach.

Lemma mark_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> mark_node s t -> notacc_white_reach t n.

intros s t n H marknode; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; split; eauto.
Qed.

Hint Resolve mark_notacc_white_reach.

Lemma gcstop_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> gc_stop s t -> notacc_white_reach t n.

intros s t n H gcstop; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; split; eauto.
Qed.

Hint Resolve gcstop_notacc_white_reach.

Lemma gcfree_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> gc_free s t -> notacc_white_reach t n.

intros s t n H gcfree; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; elim gcfree; clear gcfree.
intros ctls ctlt H_col; elim H_grey; clear H_grey.
intros g H; elim H; clear H.
intros H_grey gdifO;
 absurd (exists g : nat, card_color grey (mk s) g /\ g = 0).
intro H; elim H; clear H.
intros g' H; elim H; clear H.
intros H_grey' g'eqO; absurd (g' = 0); auto.
cut (g' = g);
 [ intro g'eqg; rewrite g'eqg; assumption
 | apply unicity_card with (M := mk s) (P := fun c : color => c = grey);
    assumption ].
exists 0; split; [ constructor; auto | auto ].
Qed.

Hint Resolve gcfree_notacc_white_reach.

Lemma gcfree1_notacc_white_reach :
 forall (s t : state) (n : node),
 sweep_no_greys s ->
 notacc_white_exgrey_reach s n -> gc_free1 s t -> notacc_white_reach t n.

unfold sweep_no_greys in |- *; intros s t n H_sweep H gcfree1; elim H;
 clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; elim gcfree1; clear gcfree1.
intros ctls ctlt; elim H_grey; clear H_grey.
intros g H; elim H; clear H.
intros H_grey gdifO;
 absurd (exists g : nat, card_color grey (mk s) g /\ g = 0).
intro H; elim H; clear H.
intros g' H; elim H; clear H.
intros H_grey' g'eqO; absurd (g' = 0); auto.
cut (g' = g);
 [ intro g'eqg; rewrite g'eqg; assumption
 | apply unicity_card with (M := mk s) (P := fun c : color => c = grey);
    assumption ].
exists 0; split; [ constructor; auto | auto ].
Qed.

Hint Resolve gcfree1_notacc_white_reach.

Lemma gcend_notacc_white_reach :
 forall (s t : state) (n : node),
 notacc_white_exgrey_reach s n -> gc_end s t -> notacc_white_reach t n.

intros s t n H gcend; elim H; clear H.
intros notacc_n_s H; elim H; clear H.
intros mksn H; elim H; clear H.
intros H_grey H_anc; split; eauto.
Qed.

Hint Resolve gcend_notacc_white_reach.

Lemma step_notacc_white_reach :
 forall (s t : state) (n : node),
 sweep_no_greys s ->
 nogrey_accn_imp_blackn s ->
 notacc_white_exgrey_reach s n ->
 step (fun (a : label) (s t : state) => transition s t a) s t ->
 notacc_white_reach t n.

intros s t n H_sweep H_inv H_n step; elim step; intro a; case a; intro trans;
 inversion_clear trans; eauto.
Qed.

Hint Resolve step_notacc_white_reach.

Definition notacc_white_exgrey_reach_formula (n : node) :
  stream_formula state :=
  fun str =>
  state2stream_formula
    (fun s : state =>
     ~ accessible node (hp s) rt n /\
     mk s n = white /\
     (exists g : nat, card_color grey (mk s) g /\ g <> 0) /\
     (forall m : node,
      reachable node (hp s) m n -> mk s m = white \/ mk s m = free)) str.

Definition notacc_white_reach_formula (n : node) :
  stream_formula state :=
  fun str =>
  state2stream_formula
    (fun s : state =>
     ~ accessible node (hp s) rt n /\
     mk s n = white /\
     (forall m : node,
      reachable node (hp s) m n -> mk s m = white \/ mk s m = free) /\
     card_color grey (mk s) 0) str.

Lemma until_no_grey :
 forall (n : node) (str : stream state),
 trace (fun (a : label) (s t : state) => transition s t a) str ->
 Eventually
   (state2stream_formula (fun s : state => card_color grey (mk s) 0)) str ->
 always
   (state2stream_formula
      (fun s : state => exists w : nat, card_color grey (mk s) w)) str ->
 always (state2stream_formula (fun s : state => sweep_no_greys s)) str ->
 always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
   str ->
 notacc_white_exgrey_reach_formula n str ->
 until (fun str => notacc_white_exgrey_reach_formula n str)
   (fun str => notacc_white_reach_formula n str) str.

intros n str H_trace H; generalize H_trace.
elim H; clear H H_trace str.
intros str H_card H_trace H_always_grey H_always_sweep H_always_inv H_n.
elim H_n; clear H_n.

(* base case *)
intros notacc_n H; elim H; clear H.
intros mkhdn H; elim H; clear H.
intros H_grey H_white.
constructor 1; split; auto.

(* induction step *)
intros s str H_eventually H_ind H_trace H_always_grey H_always_sweep
 H_always_inv H_n.
elim H_n; clear H_n.
intros notacc_n H; elim H; clear H.
intros mkhdn H; elim H; clear H.
intros H_grey H_white.
inversion H_always_grey; clear H0 H s0 str0.
elim H1; clear H1; simpl in |- *; intros g H_card.
constructor 2.
split; auto.

(* 2nd goal of constructor 2 *)

inversion H_trace; inversion H_always_grey; inversion H_always_sweep;
 inversion H_always_inv.
clear H13 H12 str3 s3 H9 H8 s2 str2 H5 H4 str1 s1 H0 H s0 str0.
simpl in H1; inversion H1.
apply H_ind; try assumption.
unfold notacc_white_exgrey_reach_formula in |- *;
 unfold state2stream_formula in |- *.
rewrite <- H; split; auto.
cut (notacc_white_reach (head_str str) n).
intro H_def; elim H_def; clear H_def.
intros notacc_hd_n H'; elim H'; clear H'.
intros mhdn H_reach.
inversion H2.
rewrite H8 in H4; rewrite H8; clear H5 H8 str0 s0.
elim H4; clear H4.
intros g' H_grey'.
elim (eq_nat_dec g' 0).
intro g'eq0; rewrite g'eq0 in H_grey'; constructor 1; split; auto.
intro g'dif0; apply H_ind; try assumption.
unfold notacc_white_exgrey_reach_formula in |- *;
 unfold state2stream_formula in |- *; simpl in |- *;
 split; auto.
split; auto.
split; auto.
exists g'; split; auto.
apply step_notacc_white_reach with (s := s); auto.
split; auto.
Qed.

Hint Resolve until_no_grey.

Lemma equivalent_def :
 forall (n : node) (str : stream state),
 notacc_white_reach_formula n str -> notacc_white_nogrey_formula n str.

intros n str H; elim H; clear H.
intros notacc_n H; elim H; clear H.
intros mkhdn H; elim H; clear H.
intros H_reach H_grey; split; auto.
Qed.

Hint Resolve equivalent_def.

Lemma until_no_grey_without_reach :
 forall (n : node) (str : stream state),
 trace (fun (a : label) (s t : state) => transition s t a) str ->
 Eventually
   (state2stream_formula (fun s : state => card_color grey (mk s) 0)) str ->
 always
   (state2stream_formula
      (fun s : state => exists w : nat, card_color grey (mk s) w)) str ->
 always (state2stream_formula (fun s : state => sweep_no_greys s)) str ->
 always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
   str ->
 notacc_white_exgrey_reach_formula n str ->
 until (fun str => notacc_white_exgrey_reach_formula n str)
   (fun str => notacc_white_nogrey_formula n str) str.

intros n str H_trace H_always_ev H_always_card H_always_sweep H_always_inv
 H_n.
apply
 until_implies_until_stream
  with
    (P := fun str => notacc_white_exgrey_reach_formula n str)
    (Q := fun str => notacc_white_reach_formula n str);
 eauto.
Qed.

Hint Resolve until_no_grey_without_reach.

Lemma notacc_white_nogrey_eventually_free :
 forall (n : node) (str : stream state),
 trace (fun (a : label) (s t : state) => transition s t a) str ->
 Eventually
   (state2stream_formula (fun s : state => card_color grey (mk s) 0)) str ->
 always
   (Eventually
      (state2stream_formula (fun s : state => card_color white (mk s) 0)))
   str ->
 always
   (state2stream_formula
      (fun s : state => exists w : nat, card_color grey (mk s) w)) str ->
 always (state2stream_formula (fun s : state => sweep_no_greys s)) str ->
 always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
   str ->
 notacc_white_exgrey_reach_formula n str ->
 Eventually (state2stream_formula (fun s : state => mk s n = free)) str.

intros n str H_trace H_grey H_always_white H_always_ex_grey H_always_sweep
 H_always_inv H_n.
cut
 (until (fun str => notacc_white_exgrey_reach_formula n str)
    (fun str => notacc_white_nogrey_formula n str) str);
 eauto.
intro H_until; generalize H_trace H_always_sweep H_always_inv H_always_white.
clear H_always_inv H_always_sweep H_always_ex_grey H_always_white H_grey
 H_trace H_n.
elim H_until; clear H_until.
clear str.
intros str H_n H_trace H_sweep H_nogrey H_white.
inversion H_white.
rewrite H1.
apply white_notacc_nogrey_until_eventually_free; auto.
rewrite <- H1; assumption.

(* Induction Step*)
clear str.
intros s str H_n H_until H_ind H_trace H_always_sweep H_always_inv
 H_always_white.
inversion H_trace; inversion H_always_sweep; inversion H_always_inv;
 inversion H_always_white.
constructor 2; apply H_ind; auto.
Qed.

End notacc_white_ancestor.

Hint Resolve notacc_white_nogrey_eventually_free.


Require Import Reals.

Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_solve.
Require Import List.

Require Import RL.hr.term.
Require Import RL.hr.hseq.
Require Import RL.hr.p_hseq.
Require Import RL.hr.apply_logical_rule.
Require Import RL.hr.lambda_prop_tools.
Require Import RL.hr.hr.
Require Import RL.hr.semantic.
Require Import RL.hr.can_elim.
Require Import RL.hr.completeness.
Require Import RL.hr.soundness.

Require Import RL.Utilities.riesz_logic_List_more.
Require Import RL.Utilities.riesz_logic_Nat_more.
Require Import RL.Utilities.Rpos.
Require Import RL.Utilities.polynomials.
Require Import RL.Utilities.pol_continuous.
Require Import RL.Utilities.Lim_seq_US.
Require Import RL.Utilities.R_complements.

Require Import Lra.
Require Import Lia.

Require Import Coquelicot.Continuity.
Require Import Coquelicot.Hierarchy.
Require Import Coquelicot.Rcomplements.
Local Open Scope R_scope.

(* begin hide *)
(* Preliminary tools and results used for the different versions of the lambda property,
   e.g, to deal with parametrized hypersequent *)

(* Multiply every sequent by a new variable *)
Fixpoint mul_p_hseq_new_var_aux G i :=
  match G with
  | nil => nil
  | T :: G => (seq_mul (Poly_var i) T) :: (mul_p_hseq_new_var_aux G (S i))
  end.
Definition mul_p_hseq_new_var G := mul_p_hseq_new_var_aux G (S (max_var_weight_p_hseq G)).

Definition val_add_vec val i L := upd_val_vec val (seq i (length L)) L.

Definition eval_p_hseq_with_coeff_aux G val L i := (map (eval_p_sequent (val_add_vec val i L)) (mul_p_hseq_new_var_aux G i)).

Definition eval_p_hseq_with_coeff G val L := eval_p_hseq_with_coeff_aux G val L (S (max_var_weight_p_hseq G)).

Lemma eval_mul_p_hseq_new_var_aux : forall G L n val i,
    length G = length L ->
    (max_var_weight_p_hseq G < i)%nat ->
    Forall_inf (fun x => prod (0 <= x) (x <= 1)) L ->
    sum_weight_var n (eval_p_hseq_with_coeff_aux G val L i) = sum_weight_var_with_coeff n (map (eval_p_sequent val) G) (map R_to_oRpos L).
Proof.
  unfold eval_p_hseq_with_coeff_aux; unfold val_add_vec.
  induction G; intros L n val i Hlen Hlt Hborned; simpl; destruct L; simpl; try reflexivity; try now inversion Hlen.
  inversion Hborned; subst.
  unfold R_to_oRpos; fold R_to_oRpos.
  case (R_order_dec r); intros H.
  2:{ clear - H H0.
      exfalso.
      apply R_blt_lt in H.
      destruct H0; lra. }
  - simpl in Hlen.
    apply eq_add_S in Hlen.
    assert (max_var_weight_p_hseq G < S i)%nat.
    { simpl in Hlt; lia. }
    specialize (IHG L n (upd_val val i r) (S i) Hlen H1 X).
    rewrite IHG; simpl.
    rewrite eval_p_hseq_upd_val_lt.
    2:{ destruct a; simpl in *; lia. }
    rewrite eval_p_sequent_upd_val_vec_lt_max_var.
    2:{ destruct a; [ simpl; apply Forall_inf_seq_gt; lia | ].
        rewrite max_var_weight_p_seq_seq_mul; simpl in *; try lia;
          [ | intros H2; inversion H2].
        destruct p; simpl in *; apply Forall_inf_seq_gt; lia. }
    rewrite sum_weight_var_eval_p_sequent_seq_mul.
    simpl.
    rewrite upd_val_eq.
    rewrite eval_p_sequent_upd_val_lt; try reflexivity.
    simpl in Hlt; lia.
  - simpl in Hlen.
    apply eq_add_S in Hlen.
    assert (max_var_weight_p_hseq G < S i)%nat.
    { simpl in Hlt; lia. }
    subst; specialize (IHG L n (upd_val val i 0) (S i) Hlen H1 X).
    rewrite IHG; simpl.
    rewrite eval_p_hseq_upd_val_lt.
    2:{ destruct a; simpl in *; lia. }
    rewrite eval_p_sequent_upd_val_vec_lt_max_var.
    2:{ destruct a; [ simpl; apply Forall_inf_seq_gt; lia | ].
        rewrite max_var_weight_p_seq_seq_mul; simpl in *; try lia;
          [ | intros H2; inversion H2].
        destruct p; simpl in *; apply Forall_inf_seq_gt; lia. }
    rewrite sum_weight_var_eval_p_sequent_seq_mul.
    simpl.
    rewrite upd_val_eq.
    rewrite eval_p_sequent_upd_val_lt; try nra.
    simpl in Hlt; lia.
Qed.

Lemma eval_mul_p_hseq_new_var : forall G L n val,
    length G = length L ->
    Forall_inf (fun x => prod (0 <= x) (x <= 1)) L ->
    sum_weight_var n (eval_p_hseq_with_coeff G val L) = sum_weight_var_with_coeff n (map (eval_p_sequent val) G) (map R_to_oRpos L).
Proof.
  intros; apply eval_mul_p_hseq_new_var_aux; try assumption; lia.
Qed.

Lemma well_defined_mul_new_var_aux : forall G L val i,
    (max_var_weight_p_hseq G < i)%nat ->
    length G = length L ->
    p_hseq_well_defined val G ->
    Forall_inf (fun x => 0 <= x) L ->
    Forall_inf (p_seq_well_defined (val_add_vec val i L)) (mul_p_hseq_new_var_aux G i).
Proof.
  induction G; intros L val i Hvm Hlen Hwd Hall; try apply Forall_inf_nil.
  destruct L; try now inversion Hlen.
  inversion Hwd; subst; simpl.
  change (val_add_vec val i (r :: L)) with
      (val_add_vec (upd_val val i r) (S i) L).
  apply Forall_inf_cons.
  - apply p_seq_well_defined_seq_mul.
    + simpl; unfold val_add_vec.
      rewrite upd_val_vec_not_in.
      2:{ apply not_In_inf_seq; lia. }
      rewrite upd_val_eq.
      inversion Hall; subst; apply H0.
    + apply p_seq_well_defined_upd_val_vec.
      * apply forall_Forall_inf.
        intros x Hin.
        apply In_inf_nth with _ _ _ 0%nat in Hin as [j Hlt Heq].
        rewrite seq_length in Hlt.
        rewrite <- Heq.
        rewrite seq_nth; simpl in *; lia.
      * change (upd_val val i r) with (upd_val_vec val (i :: nil) (r :: nil)).
        apply p_seq_well_defined_upd_val_vec; try assumption.
        apply Forall_inf_cons; [ | apply Forall_inf_nil].
        simpl in *; lia.
  - apply IHG; simpl in *; try lia; [ | inversion Hall; subst; assumption].
    apply p_hseq_well_defined_upd_val; try assumption.
    simpl in *; lia.
Qed.

Lemma well_defined_mul_new_var : forall G L val,
    length G = length L ->
    p_hseq_well_defined val G ->
    Forall_inf (fun x => 0 <= x) L ->
    Forall_inf (p_seq_well_defined (val_add_vec val (S (max_var_weight_p_hseq G)) L)) (mul_p_hseq_new_var G).
Proof.
  unfold mul_p_hseq_new_var.
  intros; apply well_defined_mul_new_var_aux; try assumption.
  lia.
Qed.

Fixpoint max_list_oRpos (L : list (option Rpos)) :=
  match L with
  | nil => 0
  | None :: L => max_list_oRpos L
  | Some r :: L => if (max_list_oRpos L <? projT1 r)
                   then projT1 r
                   else max_list_oRpos L
  end.

Lemma max_list_oRpos_pos :
  forall L,
    (Exists_inf (fun x => x <> None) L) ->
    0 < max_list_oRpos L.
Proof.
  induction L; intros Hex; inversion Hex; subst.
  - destruct a; [|contradiction ].
    destruct r.
    simpl.
    clear - e; apply R_blt_lt in e.
    case_eq (max_list_oRpos L <? x); intros; try assumption.
    apply R_blt_nlt in H.
    lra.
  - destruct a.
    + destruct r; simpl.
      clear Hex; apply R_blt_lt in e.
      specialize (IHL X).
      case_eq (max_list_oRpos L <? x); intros; try assumption.
    + apply IHL; apply X.
Qed.

Lemma max_list_oRpos_bpos :
  forall L,
    (Exists_inf (fun x => x <> None) L) ->
    (0 <? max_list_oRpos L) = true.
Proof.
  intros.
  apply R_blt_lt.
  apply max_list_oRpos_pos.
  apply X.
Qed.

Definition max_list_oRpos_Rpos (L : list (option Rpos)) (Hex : Exists_inf (fun x => x <> None) L) := existT (fun x => 0 <? x = true) (max_list_oRpos L) (max_list_oRpos_bpos L Hex).

Definition oRpos_div_Rpos (o : option Rpos) (r : Rpos) :=
  match o with
  | None => None
  | Some r' => Some (time_pos r' (inv_pos r))
  end.

Lemma list_oRpos_div_nth_Some :
  forall L r i r1,
    (i < length L)%nat ->
    nth i L None = Some r1 ->
    nth i (map (fun x => oRpos_div_Rpos x r) L) None = Some (time_pos r1 (inv_pos r)).
Proof.
  induction L; intros r i r1 Hlen Heq; try now inversion Hlen.
  destruct i.
  - destruct a; inversion Heq.
    simpl.
    reflexivity.
  - simpl in Hlen.
    apply lt_S_n in Hlen.
    simpl in Heq.
    specialize (IHL r i r1 Hlen Heq).
    destruct a; simpl; apply IHL.
Qed.

Lemma list_oRpos_div_nth_None :
  forall L r i,
    (i < length L)%nat ->
    nth i L None = None ->
    nth i (map (fun x => oRpos_div_Rpos x r) L) None = None.
Proof.
  induction L; intros r i Hlen Heq; try now inversion Hlen.
  destruct i.
  - destruct a; inversion Heq.
    simpl.
    reflexivity.
  - simpl in Hlen.
    apply lt_S_n in Hlen.
    simpl in Heq.
    specialize (IHL r i Hlen Heq).
    destruct a; simpl; apply IHL.
Qed.

Lemma list_oRpos_max_nth :
  forall (L :list (option Rpos)) (Hex : Exists_inf (fun x => x <> None) L),
    { i : _ &
          prod (i < length L)%nat
               ((nth i L None = Some (max_list_oRpos_Rpos L Hex))) }.
Proof.
  unfold max_list_oRpos_Rpos.
  intros L Hex.
  remember (max_list_oRpos_bpos L Hex) as H.
  clear HeqH Hex.
  induction L; [exfalso; apply R_blt_lt in H; simpl in *; lra | ].
  destruct a.
  2:{ simpl in H.
      specialize (IHL H) as [i [Hlen Heq]].
      split with (S i).
      repeat split; [ simpl; lia | apply Heq]. }
  simpl in H.
  case_eq (max_list_oRpos L <? projT1 r); intros H'.
  - split with 0%nat.
    repeat split; [ simpl; lia | ].
    simpl.
    f_equal.
    destruct r; simpl.
    apply Rpos_eq; simpl.
    simpl in H'; rewrite H'; reflexivity.
  - assert (H0 := H).
    rewrite H' in H0.
    specialize (IHL H0) as [i [Hlen Heq]].
    split with (S i).
    repeat split; [ simpl; lia | ].
    simpl.
    rewrite Heq.
    f_equal; apply Rpos_eq; simpl.
    rewrite H'; reflexivity.
Qed.

Lemma list_oRpos_div_max_exist_1 :
  forall (L : list (option Rpos)) (Hex : Exists_inf (fun x => x <> None) L),
    Exists_inf (fun x => x = Some One) (map (fun x => oRpos_div_Rpos x (max_list_oRpos_Rpos L Hex)) L).
Proof.
  intros L Hex.
  destruct (list_oRpos_max_nth L Hex) as [i [Hlen Heq]].
  apply exists_Exists_inf with (nth i (map (fun x => oRpos_div_Rpos x (max_list_oRpos_Rpos L Hex)) L) None).
  - apply nth_In_inf.
    rewrite map_length.
    apply Hlen.
  - rewrite list_oRpos_div_nth_Some with _ _ _ (max_list_oRpos_Rpos L Hex); try assumption.
    f_equal.
    apply inv_pos_r.
Qed.

Lemma list_oRpos_max_correct :
  forall (L : list (option Rpos)) rmax,
    max_list_oRpos L <= rmax ->
    Forall_inf (fun x => {r & x <> None -> prod (x = Some r) (projT1 r <= rmax)}) L.
Proof.
  induction L; intros rmax Hle; simpl in *; [apply Forall_inf_nil | apply Forall_inf_cons].
  - destruct a.
    + split with r.
      intros _; split; [ reflexivity | ].
      case_eq (max_list_oRpos L <? projT1 r); intros H; rewrite H in Hle; (apply R_blt_lt in H + apply R_blt_nlt in H); try lra.
    + split with One; intros H; contradiction.
  - apply IHL.
    destruct a; simpl in Hle; try assumption.
    case_eq (max_list_oRpos L <? projT1 r); intros H; rewrite H in Hle; (apply R_blt_lt in H + apply R_blt_nlt in H); try lra.
Qed.

Lemma list_oRpos_div_max_all_le_1 :
  forall (L : list (option Rpos)) (r : Rpos),
    max_list_oRpos L <= (projT1 r) ->
    Forall_inf (fun x => {r & x <> None -> prod (x = Some r) (projT1 r <= 1)}) (map (fun x => oRpos_div_Rpos x r) L).
Proof.
  intros L r Hle.
  assert (H := list_oRpos_max_correct L (projT1 r) Hle).
  revert r Hle H.
  induction L; intros r Hle Hall; [ apply Forall_inf_nil | ].
  simpl; apply Forall_inf_cons.
  - destruct a.
    2:{ split with One; intros; contradiction. }
    split with (time_pos r0 (inv_pos r)).
    intros _.
    inversion Hall; subst.
    destruct H0 as [r' f].
    assert (Some r0 <> None) as temp by (intros H; inversion H).
    specialize (f temp); clear temp.
    destruct f as [Htemp Hle'].
    inversion Htemp; subst.
    split.
    + reflexivity.
    + simpl.
      destruct r'; destruct r; simpl.
      simpl in *.
      apply R_blt_lt in e0.
      apply Rmult_le_reg_r with x0; try assumption.
      rewrite Rmult_assoc.
      rewrite Rinv_l.
      2:{ lra. }
      lra.
  - apply IHL; [ | inversion Hall; assumption].
    destruct a; simpl in Hle; try assumption.
    case_eq (max_list_oRpos L <? projT1 r0); intros H; rewrite H in Hle; (apply R_blt_lt in H + apply R_blt_nlt in H); simpl in *; lra.
Qed.

Lemma list_oRpos_div_sum_eq :
  forall (L : list (option Rpos)) r G n,
    sum_weight_var_with_coeff n G (map (fun x => oRpos_div_Rpos x r) L) = (sum_weight_var_with_coeff n G L) / (projT1 r).
Proof.
  intros L r G n.
  revert L; induction G; intros L; destruct L; simpl; try lra.
  specialize (IHG L).
  destruct o; simpl; try lra.
  destruct r0; destruct r; simpl in *; lra.
Qed.

Lemma concat_with_coeff_div : forall G L r, concat_with_coeff_mul G (map (fun x : option Rpos => oRpos_div_Rpos x r) L) = hseq.seq_mul (inv_pos r) (concat_with_coeff_mul G L).
Proof.
  induction G; intros L r; destruct L; try reflexivity.
  specialize (IHG L r).
  destruct o; simpl; rewrite IHG; try reflexivity.
  rewrite hseq.seq_mul_app.
  f_equal.
  rewrite hseq.seq_mul_twice.
  f_equal.
  destruct r; destruct r0; apply Rpos_eq; simpl; nra.
Qed.

Lemma concat_with_coeff_mul_p_hseq_new_var_aux : forall G L i val,
    (max_var_weight_p_hseq G < i)%nat ->
    length G = length L ->
    concat (map (eval_p_sequent (val_add_vec val i (map oRpos_to_R L))) (mul_p_hseq_new_var_aux G i)) = concat_with_coeff_mul (map (eval_p_sequent val) G) L.
Proof.
  induction G; intros L i val Hlt Hlen; destruct L; try reflexivity; [ inversion Hlen | ].
  simpl in Hlen.
  apply eq_add_S in Hlen.
  destruct o.
  - simpl.
    rewrite eval_p_sequent_seq_mul_pos with _ _ r _.
    2:{ unfold val_add_vec.
        simpl; rewrite upd_val_vec_not_in; [ rewrite upd_val_eq; reflexivity | ].
        apply not_In_inf_seq; lia. }
    replace (eval_p_sequent (val_add_vec val i (projT1 r :: map oRpos_to_R L)) a)
      with (eval_p_sequent val a).
    2:{ symmetry; unfold val_add_vec; apply eval_p_sequent_upd_val_vec_lt_max_var.
        simpl in Hlt; apply Forall_inf_seq_gt; lia. }
    f_equal.
    change (val_add_vec val i (projT1 r :: map oRpos_to_R L)) with
        (val_add_vec (upd_val val i (projT1 r)) (S i) (map oRpos_to_R L)).
    rewrite (IHG L (S i) (upd_val val i (projT1 r))); simpl in *; try lia.
    f_equal.
    apply eval_p_hseq_upd_val_lt.
    lia.
  - simpl.
    change (val_add_vec val i (0 :: map oRpos_to_R L)) with
        (val_add_vec (upd_val val i 0) (S i) (map oRpos_to_R L)).
    rewrite eval_p_sequent_seq_mul_0.
    2:{ unfold val_add_vec.
        simpl.
        rewrite upd_val_vec_not_in.
        - rewrite upd_val_eq; reflexivity.
        - apply not_In_inf_seq; lia. }
    rewrite (IHG L (S i) (upd_val val i 0)); simpl in *; try lia.
    f_equal.
    apply eval_p_hseq_upd_val_lt.
    lia.
Qed.

(* end hide *)

(** * Lambda property *)
(** ** Different statements of the lambda property *)
(** Lambda property *)
Definition def_lambda_prop G :=
  { L &
    prod (length L = length G)
         ((Exists_inf (fun x => x <> None) L) *
          (forall n, sum_weight_var_with_coeff n G L = 0))}.

(** lambda property with where the t_i are in [0,1] and not only in R_{>0} *)
Definition def_lambda_prop_one G :=
  { L &
    prod (length L = length G)
         ((Exists_inf (fun x => x = Some One) L) *
          (Forall_inf (fun x => {r & x <> None -> prod (x  = Some r) (projT1 r <= 1)}) L) *
          (forall n, sum_weight_var_with_coeff n G L = 0))}.

Definition p_def_lambda_prop_one G val :=
  { L &
    prod (length L = length G)
         ((Exists_inf (fun x => x = 1) L) *
          (Forall_inf (fun x => prod (0 <= x) (x <= 1)) L) *
          (forall n, eval_Poly (val_add_vec val (S (max_var_weight_p_hseq G)) L) (p_sum_weight_var n (mul_p_hseq_new_var G)) = 0))}.

(** ** Proofs that those formulations are equivalent *)
Lemma def_lambda_prop_one_implies_reg :
  forall G,
    def_lambda_prop_one G ->
    def_lambda_prop G.
Proof.
  intros G [L [Hlen [[Hex Hall] Hsum]]].
  split with L.
  repeat split; try assumption.
  clear - Hex.
  induction L; inversion Hex; subst.
  - left.
    intros H; inversion H.
  - specialize (IHL X).
    right; apply IHL.
Qed.

Lemma def_lambda_prop_reg_implies_one :
  forall G,
    def_lambda_prop G ->
    def_lambda_prop_one G.
Proof.
  intros G [L [Hlen [Hex Hsum]]].
  split with (map (fun x => oRpos_div_Rpos x (max_list_oRpos_Rpos L Hex)) L).
  repeat split.
  - rewrite map_length; apply Hlen.
  - apply list_oRpos_div_max_exist_1.
  - apply list_oRpos_div_max_all_le_1.
    apply Rle_refl.
  - intros n.
    rewrite list_oRpos_div_sum_eq.
    rewrite Hsum.
    lra.
Qed.

Lemma def_lambda_prop_one_reg_implies_p :
  forall G val,
    def_lambda_prop_one (map (eval_p_sequent val) G) ->
    p_def_lambda_prop_one G val.
Proof.
  intros G val [L [Hlen [[Hex Hall] Hsum]]].
  split with (map oRpos_to_R L).
  repeat split.
  - rewrite map_length; rewrite map_length in Hlen; lia.
  - apply Exists_inf_exists in Hex as [x Hinx Heqx].
    apply (In_inf_nth _ _ None) in Hinx as [i Hlti Heqi].
    apply exists_Exists_inf with (nth i (map oRpos_to_R L) 0).
    + apply nth_In_inf.
      rewrite map_length; lia.
    + change 0 with (oRpos_to_R None).
      rewrite map_nth.
      rewrite Heqi; rewrite Heqx; reflexivity.
  - clear - Hall.
    induction L; [ apply Forall_inf_nil | ].
    inversion Hall; subst.
    specialize (IHL X).
    simpl; apply Forall_inf_cons; try assumption.
    destruct H0 as [r H0].
    destruct a; [ | simpl; split; lra].
    assert (Some r0 <> None) by now auto.
    specialize (H0 H); clear H.
    destruct H0 as [H0 H0'].
    inversion H0; subst.
    destruct r as [r Hr].
    simpl in *.
    split ; [ clear - Hr; apply R_blt_lt in Hr; lra | assumption ].
  - replace L with (map R_to_oRpos (map oRpos_to_R L)) in Hsum.
    2:{ rewrite map_map.
        rewrite map_ext with _ _ _ (fun x => x) _; [ | apply R_to_oRpos_oRpos_to_R].
        apply map_id. }
    intros n; specialize (Hsum n);
      rewrite <- eval_mul_p_hseq_new_var in Hsum.
    + unfold val_add_vec.
      rewrite p_sum_weight_var_sem.
      apply Hsum.
    + rewrite map_length; rewrite map_length in Hlen; lia.
    + clear - Hall.
      induction L; [ apply Forall_inf_nil | ].
      inversion Hall; subst.
      specialize (IHL X).
      simpl; apply Forall_inf_cons; try assumption.
      destruct H0 as [r H0].
      destruct a; [ | simpl; split; lra].
      assert (Some r0 <> None) by now auto.
      specialize (H0 H); clear H.
      destruct H0 as [H0 H0'].
      inversion H0; subst.
      destruct r as [r Hr].
      simpl in *.
      split ; [ clear - Hr; apply R_blt_lt in Hr; lra | assumption ].
Qed.

Lemma def_lambda_prop_one_p_implies_reg :
  forall G val,
    p_def_lambda_prop_one G val ->
    def_lambda_prop_one (map (eval_p_sequent val) G).
Proof.
  intros G val [L [Hlen [[Hex Hall] Hsum]]].
  split with (map R_to_oRpos L).
  repeat split.
  - rewrite ? map_length; lia.
  - apply Exists_inf_exists in Hex as [x Hinx Heqx].
    apply (In_inf_nth _ _ 0) in Hinx as [i Hlti Heqi].
    apply exists_Exists_inf with (nth i (map R_to_oRpos L) None).
    + apply nth_In_inf.
      rewrite map_length; lia.
    + replace None with (R_to_oRpos 0).
      2:{ clear.
          unfold R_to_oRpos.
          case (R_order_dec 0); intros e; try reflexivity; exfalso; apply R_blt_lt in e; lra. }
      rewrite map_nth.
      rewrite Heqi; rewrite Heqx.
      clear.
      unfold R_to_oRpos.
      case (R_order_dec 1); intros e; [ | exfalso; clear -e; apply R_blt_lt in e; lra | exfalso; lra ].
      f_equal.
      apply Rpos_eq; reflexivity.
  - clear - Hall.
    induction L; [ apply Forall_inf_nil | ].
    inversion Hall; subst.
    specialize (IHL X).
    simpl; apply Forall_inf_cons; try assumption.
    destruct H0 as [H0 H1].
    remember (R_to_oRpos a).
    revert Heqo.
    unfold R_to_oRpos.
    case (R_order_dec a); intros e; [ | exfalso; clear -e H0; apply R_blt_lt in e; lra | ]; intros Heqo;
      [ | split with One; intros H'; subst; contradiction].
    destruct o; inversion Heqo.
    split with s; subst.
    intros _; split; [f_equal; apply Rpos_eq; reflexivity | apply H1].
  - intros n; specialize (Hsum n);
      rewrite <- eval_mul_p_hseq_new_var.
    + rewrite p_sum_weight_var_sem in Hsum.
      apply Hsum.
    + lia.
    + apply Hall.
Qed.

Lemma lambda_prop :
  forall G,
    hseq_is_atomic G ->
    HR_T_M G ->
    def_lambda_prop G.
Proof.
  intros G Hat pi.
  destruct (lambda_prop G Hat pi) as [L [Hlen [Hex Hsum]]].
  split with L.
  repeat split; assumption.
Qed.

Lemma lambda_prop_inv :
  forall G,
    hseq_is_atomic G ->
    def_lambda_prop G ->
    HR_T_M G.
Proof.
  intros G Hat [L [Hlen [Hex Hsum]]].
  apply lambda_prop_inv; try assumption.
  split with L.
  repeat split; try assumption.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (plus lv0 lv1) (Succ lv2)) (plus (plus lv2 lv0) lv3)).
Admitted.
QuickChick conj24synthconj6.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj21synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (plus lv1 (mult lv1 lv0)) lv3)).
Admitted.
QuickChick conj21synthconj4.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal29.

Set Printing Depth 1000.
Definition lfind_eval  x:=
qreva x Nil.

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Nil).


(*|
###############################
Induction proofs on ``MSet``\ s
###############################

:Link: https://stackoverflow.com/q/47572526
|*)

(*|
Question
********

I'm trying to use MSet library in a Coq development and I need a
``smap`` function, which is absent from the library, but can be
implemented using ``fold``, as usual.

In the following `gist
<https://gist.github.com/rodrigogribeiro/1bb47d5a07e91e27384175fdb2710e34>`__,
I've put a simplification of what I'm working on, full of axioms, just
to get straight to the point.

My problem is to prove a property of the following ``smap`` function:

.. coq:: none
|*)

Require Import MSets.MSetRBT MSets.MSetProperties.

Axiom Exp : Set.

Module ExpOT <: Orders.OrderedType.
  Definition t := Exp.
  Definition eq := @eq Exp.
  Definition eq_equiv : Equivalence eq.
  Admitted.
  Axiom lt : t -> t -> Prop.
  Definition lt_strorder : StrictOrder lt.
  Admitted.
  Definition lt_compat : Proper (eq ==> eq ==> iff) lt.
  Admitted.
  Axiom compare : t -> t -> comparison.
  Definition compare_spec : forall e e',
      CompareSpec (eq e e') (lt e e') (lt e' e) (compare e e').
  Admitted.
  Definition eq_dec : forall (e e' : Exp), {e = e'} + {e <> e'}.
  Admitted.
End ExpOT.

Module Import MSet := MSetRBT.Make ExpOT.
Module Import MSetDec := MSetDecide.WDecideOn ExpOT MSet.
Module Import MSetProps := MSetProperties.WPropertiesOn ExpOT MSet.

(*||*)

Definition smap (f : Exp -> Exp) s :=
  MSet.fold (fun a ac => MSet.add (f a) ac) MSet.empty s.

(*|
Which uses ``fold`` from Coq MSet library. The property that I want to
show is:
|*)

Lemma smap_lemma : forall s f e,
    In e (smap f s) -> exists e', In e' s /\ e = f e'.
Proof.
  induction s using set_induction; intros; try fsetdec.
Abort. (* .none *)

(*|
Which is intended to show that if an element ``e`` in the set ``smap f
s``, then exists another element ``e'`` in ``s``, s.t. ``e = f e'``.
My difficulty is to prove the inductive case, since the induction
hypothesis produced by ``set_induction`` does not seems useful at all.

Could someone provide me any clues on how should I proceed?

----

**A:** A note about sets don't include a ``smap`` operation is because
it only makes sense as such if the mapped function is injective and
order-preserving. For all other cases, you are talking about "the
image of a set under f", which has slightly different properties.
|*)

(*|
Answer
******

First, I think there is a problem in your definition of ``smap``. You
must swap ``MSet.empty`` and ``s``, otherwise you can prove:
|*)

Lemma smap_trivial : forall f s, smap f s = s.
Proof.
  intros. reflexivity.
Qed.

(*|
With the right definition, you can use the ``fold_rec`` lemma that is
adapted to this kind of goal.
|*)


(** * SfLib: Software Foundations Library <https://www.cis.upenn.edu/~bcpierce/sf/current/index.html> *)

(*

Copyright (c) 2016

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

*)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** Some proofs are taken from the GitHub page of
    BlindFS and Haklabbeograd **)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct b; simpl in H.
  apply H.
  inversion H.
Qed.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  intro n.
  induction n as [|n'].
  destruct m. reflexivity. reflexivity.
  destruct m. reflexivity. simpl. apply IHn'.
Qed.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.
Qed.

Theorem false_beq_nat: forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
  intros.
  destruct (beq_nat n n') eqn:eq.
  unfold not in H. apply beq_nat_true in eq.
  apply H in eq. inversion eq.
  reflexivity.
Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.
Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
  intros n E.
  induction E  as [ | n' E' ].
  unfold not.
  intros contra. inversion contra.
  unfold not.
  intros ES.
  inversion ES.
  unfold not in IHE'.
  apply IHE' in H0.
  inversion H0.
Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  intros.
  induction n.
  apply le_n.
  apply le_S. apply IHn.
Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros.
  induction H. apply le_n.
  apply le_S. apply IHle.
Qed.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
Proof.
  intros n.
  induction n.
  intros. apply O_le_n.
  intros.
  simpl in H. destruct m.
  inversion H. apply n_le_m__Sn_le_Sm.
  apply IHn. apply H.
Qed.

Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o.
Proof.
  intros.
  induction H0. apply H.
  apply le_S. apply IHle.
Qed.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros.
  inversion H. apply le_n.
  apply le_trans with (n:=S n).
  apply le_S. apply le_n. apply H1.
Qed.

Theorem le_ble_nat : forall n m,
  n <= m ->
  ble_nat n m = true.
Proof.
  intros n m.
  generalize n.
  induction m.
  intros. inversion H. reflexivity.
  intros. destruct n0. reflexivity.
  simpl. apply IHm. apply Sn_le_Sm__n_le_m.
  apply H.
Qed.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
Proof.
  intros.
  unfold not.
  intros.
  apply le_ble_nat in H0. rewrite H in H0.
  inversion H0.
Qed.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.
Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  intros X R x y z G H.
  multi_cases (induction G) Case.
    Case "multi_refl". assumption.
    Case "multi_step".
      apply multi_step with y. assumption.
      apply IHG. assumption.
Qed.

(**  Identifiers and polymorphic partial maps. *)

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra.
     inversion contra. apply Hneq. apply H0.
Qed.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  intros. destruct (eq_id_dec x y).
  apply ex_falso_quodlibet. unfold not in H. apply H. apply e.
  reflexivity.
Qed.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

(** $Date: 2014-12-31 12:04:02 -0500 (Wed, 31 Dec 2014) $ *)


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import Def.
Require Import UcoPreservation.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section SafetyPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  Variable T_evs S_evs : Events.
  Variable T_end S_end : Endstates.

  Local Definition trace__S := @trace S_evs S_end.
  Local Definition finpref__S := @finpref S_evs S_end.
  Local Definition trace__T := @trace T_evs T_end.
  Local Definition finpref__T := @finpref T_evs T_end.

  Local Definition prop__S := prop trace__S.
  Local Definition Safety__S := @Safety S_evs S_end.
  Local Definition prop__T := prop trace__T.
  Local Definition Safety__T := @Safety T_evs T_end.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "W ↓" := (cmp W) (at level 50).

  Variable σ : prop__T -> prop__S.
  Variable τ : prop__S -> prop__T.

  Local Definition σP := σP compilation_chain
                            Source_Semantics Target_Semantics
                            σ.

  Definition Cl_τP := τP compilation_chain
                         Source_Semantics Target_Semantics
                         (Cl ∘ τ).

  Theorem σSafetyP_Cl_τTP :
    (Adjunction_law τ σ) ->
    ( (forall W (π__T : prop__T), Safety π__T -> σP W π__T) <->
      (forall W (π__S : prop__S), Cl_τP W π__S)).
  Proof.
    move => H_adj.
    setoid_rewrite <- (@uco_adjuncts _ _ _ _ _ _ _ σ τ safety_uco).
    rewrite -Safety_Cl_prop.
    reflexivity.
    assumption.
  Qed.

End SafetyPreservation.


Require Import Game.
Require Import BaseGame.
Require Import TurnGame.

(* --------------------------------------------------------
     Nothing to do here but count...
     Don't judge, you've played it too !.
   -------------------------------------------------------- *)
Definition counting_game : Game :=
  mkGame
    True
    nat
    0
    (fun s p => unit)
    (fun s dec => S s).

Lemma counting_is_strong_turned : is_strong_turned_game counting_game.
Proof.
  compute.
  exists id.
  split.
  auto.
  intros.
  compute.
  auto.
Qed.

Lemma couting_turned_based : is_turned_game counting_game.
Proof.
  exact (strong_turned_is_turned counting_game counting_is_strong_turned).
Qed.


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.AsciiOpt.
Require Import
        Bedrock.Word
        Coq.Strings.Ascii
        Coq.Strings.String.

Section String.
  (* this has an exact idential structure to _FixList_ *)
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Fixpoint format_string (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    match xs with
    | EmptyString => ret (mempty, ce)
    | String x xs' => `(b1, env1) <- format_ascii x ce;
                      `(b2, env2) <- format_string xs' env1;
                      ret (mappend b1 b2, env2)
    end%comp.

    Fixpoint encode_string (xs : string) (ce : CacheFormat) : B * CacheFormat :=
    match xs with
    | EmptyString => (mempty, ce)
    | String x xs' => let (b1, env1) := encode_ascii x ce in
                      let (b2, env2) := encode_string xs' env1 in
                          (mappend b1 b2, env2)
    end.

  Fixpoint decode_string (s : nat) (b : B) (cd : CacheDecode) : Hopefully (string * B * CacheDecode) :=
    match s with
    | O => Ok (EmptyString, b, cd)
    | S s' => `(x, b1, e1) <- decode_ascii b cd;
              `(xs, b2, e2) <- decode_string s' b1 e1;
              Ok (String x xs, b2, e2)
    end.

  Local Opaque format_ascii.
  Local Opaque encode_ascii.

  Theorem String_decode_correct
          {P : CacheDecode -> Prop}
    : forall sz
             (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))),
      CorrectDecoder
        monoid
        (fun ls => length ls = sz)
        (fun ls => length ls = sz)
        eq
        format_string (decode_string sz) P
        format_string.
  Proof.
    split.
    { intros env env' xenv l l' ext ? Eeq Ppred Penc.
      subst.
      generalize dependent env.
      revert env' xenv l' env_OK.
      induction l.
      { intros.
        inversion Penc; subst; clear Penc.
        rewrite mempty_left; eexists _, _; intuition eauto.
        simpl; eauto.
      }
      { intros.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I Penc) as [? [? [? xenv_OK] ] ].
      simpl. rewrite <- mappend_assoc, H; simpl.
      split_and; subst.
      destruct (IHl _ _ _ H4 _ H1 Penc') as [? [? ?] ].
      split_and; unfold id in *.
      rewrite H3; simpl; eexists _, _;
        subst; intuition eauto.
      simpl; unfold Bind2; eauto.
      }
    }
    { induction sz; simpl; intros.
      { simpl; injections; repeat eexists; simpl; eauto using mempty_left. }
      { destruct (decode_ascii t env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_string sz b c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 (Ascii_decode_correct P_OK)) in Heqh; eauto;
          destruct Heqh as [? [? ?] ]; destruct_ex; intuition; subst;
            eapply IHsz in Heqh0; eauto; destruct Heqh0 as [? [? ?] ];
              destruct_ex; intuition; subst.
        unfold id in *; simpl.
        eexists _, _; simpl; intuition eauto.
        simpl; computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        rewrite mappend_assoc; reflexivity.
      }
    }
  Qed.

  Definition decode_string_with_term_char
           (term_char : Ascii.ascii)
           (b : B) (cd : CacheDecode)
    : Hopefully (string * B * CacheDecode).
    refine (Fix well_founded_lt_b
           (fun _ => CacheDecode -> Hopefully (string * B * CacheDecode))
      (fun b rec cd =>
         (`(a, b1, e1) <- Decode_w_Measure_lt decode_ascii b cd _;
      If ascii_dec a term_char Then
        Ok (EmptyString, proj1_sig b1, e1)
      Else
      (`(xs, b2, e2) <- rec _ (proj2_sig b1) e1;
      Ok (String a xs, b2, e2)))) b cd).
    exact ascii_decode_lt.
  Defined.

  Definition format_string_with_term_char
             (term_char : Ascii.ascii)
             (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    format_string (xs ++ (String term_char EmptyString)) ce.

  Theorem String_decode_with_term_char_correct
          {P : CacheDecode -> Prop}
    : forall term_char (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))),
      CorrectDecoder
        monoid
        (fun s => forall s1 s2, s <> s1 ++ String term_char s2)%string
        (fun s => forall s1 s2, s <> s1 ++ String term_char s2)%string
        eq
        (format_string_with_term_char term_char)
        (decode_string_with_term_char term_char) P
        (format_string_with_term_char term_char).
  Proof.
    split.
    { intros env env' xenv s s' ext ? Eeq Ppred Penc.
      subst.
      generalize dependent env.
      revert env' xenv s' env_OK.
      induction s.
      { unfold id in *; intros.
        unfold format_string_with_term_char in Penc.
        unfold decode_string_with_term_char.
        simpl in Penc; unfold Bind2 in *; computes_to_inv; subst; simpl in *.
        rewrite mempty_right in Penc''; inversion Penc''; subst.
        destruct v; simpl in *.
        eapply Ascii_decode_correct in Penc; eauto.
        unfold id in *.
        destruct_ex; split_and.
        eexists _, _; rewrite Init.Wf.Fix_eq.
        eapply Decode_w_Measure_lt_eq in H0; destruct_ex.
        rewrite H0; simpl.
        subst; destruct (ascii_dec x x); simpl; try congruence.
        intuition eauto.
        unfold format_string_with_term_char; simpl; unfold Bind2;
          repeat computes_to_econstructor; eauto.
        simpl;rewrite mempty_right; eauto.
        simpl.
        intros.
        repeat (apply functional_extensionality; intros; f_equal).
        rewrite H3.
        eauto.
      }
      { intros.
        unfold format_string_with_term_char in Penc;
          unfold decode_string_with_term_char.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I Penc) as [? [? [? xenv_OK] ] ].
      simpl.
      unfold format_string_with_term_char in IHs.
      simpl in Penc'; eapply IHs in Penc'.
      destruct Penc'; intuition.
      subst.
      destruct_ex; split_and.
      eexists _, _; rewrite Init.Wf.Fix_eq.
      eapply Decode_w_Measure_lt_eq in H; destruct_ex.
      rewrite <- mappend_assoc, H; simpl.
      destruct (ascii_dec x term_char); simpl.
      - elimtype False.
        subst; eapply (Ppred "")%string; simpl; reflexivity.
      - intuition.
        unfold decode_string_with_term_char in H1.
        rewrite H1; simpl; subst; eauto.
        unfold format_string_with_term_char; simpl; unfold Bind2;
          computes_to_econstructor; eauto.
        subst; computes_to_econstructor; eauto.
        subst; eauto.
        eauto.
      - intros; repeat (apply functional_extensionality; intros; f_equal).
        rewrite H7; reflexivity.
      - unfold id in *; unfold not; intros; eapply (Ppred (String a s1) s2); simpl; congruence.
      - intuition eauto.
      - intuition eauto.
      }
    }
    { unfold decode_string_with_term_char, format_string_with_term_char;
        intros env env' xenv' data bin;
        revert env env' xenv' data.
      eapply (@well_founded_induction _ _ well_founded_lt_b) with
      (a := bin); intros.
      rewrite Coq.Init.Wf.Fix_eq in H2; auto; simpl.
      apply DecodeBindOpt2_inv in H2;
        destruct H2 as [? [? [? [? ?] ] ] ]; injections; subst.
      destruct (decode_ascii x env') as [ [ [? ?] ?] | ] eqn: ? .
      - destruct (Decode_w_Measure_lt_eq _ _ _ ascii_decode_lt Heqh).
        rewrite H4 in H2; injections.
        destruct (ascii_dec x0 term_char) eqn: ?; simpl in H3.
        + injections.
          eapply (proj2 (Ascii_decode_correct P_OK)) in Heqh; eauto;
            destruct Heqh as [? [? ?] ]; destruct_ex; intuition; subst.
          simpl.
          eexists _, _; intuition.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          simpl; rewrite mempty_right; eauto.
          destruct s1; simpl in *; discriminate.
          eauto.
        + eapply (proj2 (Ascii_decode_correct P_OK)) in Heqh; eauto;
            destruct Heqh as [? [? ?] ]; destruct_ex.
          symmetry in H3; apply DecodeBindOpt2_inv in H3;
            destruct H3 as [? [? [? [? ?] ] ] ]; injections; subst.
          eapply H in H3; intuition.
          destruct_ex; intuition; subst; eauto.
          eexists _, _; intuition.
          simpl.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          simpl; rewrite mappend_assoc; eauto.
          unfold id in *; destruct s1; simpl in *; injections; intros; congruence.
          simpl; eauto.
          simpl; eauto.
      - eapply isError, Decode_w_Measure_lt_eq' in Heqh.
        rewrite H2 in Heqh; inversion Heqh.
      - intros; repeat (apply functional_extensionality; intros; f_equal).
        rewrite H3; reflexivity.
    }
  Qed.

  Theorem decode_string_lt
    : forall len (lt_len : lt 0 len)
             (b3 : B)
             (cd0 : CacheDecode)
             (a : string) (b' : B)
             (cd' : CacheDecode),
      decode_string len b3 cd0 = Ok (a, b', cd') -> lt_B b' b3.
  Proof.
    induction len; simpl; intros; try lia.
    destruct (decode_ascii b3 cd0) as [ [ [? ?] ?] | ] eqn: ? ;
      simpl in *; try discriminate.
    eapply ascii_decode_lt in Heqh.
    destruct (decode_string len b c) as [ [ [? ?] ?] | ] eqn: ? ;
      simpl in *; try discriminate.
    injections.
    inversion lt_len; subst; simpl in *.
    - injections; eauto.
    - eapply IHlen in Heqh0; eauto; unfold lt_B in *; lia.
  Qed.

End String.


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 A B C I J K : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ I B /\ (wd_ I C /\ (wd_ K A /\ (wd_ K B /\ (wd_ A C /\ (wd_ I J /\ (wd_ J K /\ (wd_ J A /\ (wd_ J C /\ (wd_ I K /\ (col_ K A B /\ (col_ J A C /\ (col_ I B C /\ col_ A B C))))))))))))))) -> col_ A J I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Algebra.Functor Algebra.Applicative Algebra.SetoidCat Algebra.SetoidCat.ListUtils Algebra.SetoidCat.PairUtils Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Algebra.SetoidUtils Algebra.Monad Tactics Utils Algebra.Lens.Lista Algebra.Lens.Matrixp Lens Algebra.Monoid MaybeLens ListaLens Pointed.

Require Import SetoidClass List Coq.Classes.RelationClasses Coq.Arith.PeanoNat Coq.Arith.Compare_dec.

Inductive MatrixRowsLens := matrixRowsLens.

Program Instance MatrixRowsLensS : Setoid MatrixRowsLens.

Definition _MatrixRowsLens_set {A} {AS : Setoid A} {AP : Pointed A} (_ : MatrixRowsLens) (r :  lista (maybe (lista A))) (m : matrixp A) :=
  match m with
    | matrixpCons _  r' => matrixpConsS @  r
  end
.

Instance _MatrixRowsLens_set_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv ==> equiv ==> equiv) (@_MatrixRowsLens_set A AS AP ).
Proof.
  autounfold. intros. destruct x1, y1. unfold _MatrixRowsLens_set.  rewritesr.
Qed.

Definition MatrixRowsLens_set {A} {AS : Setoid A} {AP} := injF3 (@_MatrixRowsLens_set A AS AP) _.

Definition _MatrixRowsLens_view {A} {AS : Setoid A} {AP : Pointed A} (_ : MatrixRowsLens) := rows.

Instance _MatrixRowsLens_view_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv) (@_MatrixRowsLens_view A AS AP ).
Proof.
  autounfold. intros.  destruct x, y. unfold _MatrixRowsLens_view. reflexivity.
Qed.

Definition MatrixRowsLens_view {A} {AS : Setoid A} {AP} := injF (@_MatrixRowsLens_view A AS AP) _.

Instance MatrixRowsLens_Settable A (AS : Setoid A) (AP : Pointed A) : @Settable (matrixp A) (lista (maybe (lista A))) _ _ MatrixRowsLens _.
Proof.
  split.
  exact MatrixRowsLens_set.
Defined.

Instance MatrixRowsLens_PreLens A (AS : Setoid A) (AP : Pointed A) : @PreLens (matrixp A) (lista (maybe (lista A))) _ _ MatrixRowsLens _ _.
Proof.
  exists MatrixRowsLens_view.
  intros. destruct a.  simpl set.  unfold MatrixRowsLens_set, _MatrixRowsLens_set. normalize. unfold MatrixRowsLens_view, _MatrixRowsLens_view. normalize.  unfold rows, _rows. normalize. reflexivity. Defined.

Instance MatrixRowsLens_Lens A (AS : Setoid A) (AP : Pointed A) : @Lens (matrixp A) (lista (maybe (lista A))) _ _ MatrixRowsLens _ _ _.
Proof.
  split.
  intros. destruct a.  simpl. reflexivity.
  intros. destruct a.  simpl. reflexivity.
Qed.

Definition matrixCellPreview ri ci := matrixRowsLens >>>? listaNthLens ri >>>? maybePreview >>>? listaNthLens ci.

Existing Instance ComposeP_Preview.
Existing Instance Lens_Preview.

Definition _MatrixCellPreview_set {A} {AS : Setoid A} {AP : Pointed A} ri ci  :  AS ~> matrixpS  AS ~~> matrixpS AS :=
        set @ (matrixCellPreview ri ci)
.

Instance _MatrixCellPreview_set_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv ==> equiv) (@_MatrixCellPreview_set A AS AP).
Proof.
  autounfold. intros.   rewrite H, H0. reflexivity.
Qed.

Definition MatrixCellPreview_set {A} {AS : Setoid A} AP := injF2 (@_MatrixCellPreview_set A AS AP) _.

Existing Instance Preview_Maybe_Settable.
Existing Instance Preview_PreLens.
Set Printing Implicit.
Definition _MatrixCellPreview_preview {A} {AS : Setoid A} {AP : Pointed A} ri ci: matrixpS AS ~>  maybeS AS :=
  preview @ (matrixRowsLens >>>? listaNthLens ri >>>? maybePreview >>>? listaNthLens ci).

Instance _MatrixCellPreview_preview_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv ==> equiv) (@_MatrixCellPreview_preview A AS AP).
Proof.
  autounfold. intros.  rewritesr.
Qed.

Definition MatrixCellPreview_preview {A} {AS : Setoid A} {AP : Pointed A} := injF2 (@_MatrixCellPreview_preview A AS AP ) _.

Definition matrixRowPreview ri := matrixRowsLens >>>? listaNthLens ri >>>? maybePreview.

Definition _MatrixRowPreview_set {A} {AS : Setoid A} {AP : Pointed A} ri  :  listaS AS ~> matrixpS  AS ~~> matrixpS AS :=
        set @ (matrixRowPreview ri)
.

Instance _MatrixRowPreview_set_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv) (@_MatrixRowPreview_set A AS AP).
Proof.
  autounfold. intros.   rewrite H. reflexivity.
Qed.

Definition MatrixRowPreview_set {A} {AS : Setoid A} AP := injF (@_MatrixRowPreview_set A AS AP) _.

Definition _MatrixRowPreview_preview {A} {AS : Setoid A} {AP : Pointed A} ri: matrixpS AS ~>  maybeS (listaS AS) :=
  preview @ (matrixRowPreview ri).

Instance _MatrixRowPreview_preview_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv) (@_MatrixRowPreview_preview A AS AP).
Proof.
  autounfold. intros.  rewritesr.
Qed.

Definition MatrixRowPreview_preview {A} {AS : Setoid A} {AP : Pointed A} := injF (@_MatrixRowPreview_preview A AS AP ) _.

Definition matrixMaybeRowLens ri := matrixRowsLens >>>? listaNthLens ri.

Definition _MatrixMaybeRowLens_set {A} {AS : Setoid A} {AP : Pointed A} ri  :  maybeS (listaS AS) ~> matrixpS  AS ~~> matrixpS AS :=
        set @ (matrixMaybeRowLens ri)
.

Instance _MatrixMaybeRowLens_set_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv) (@_MatrixMaybeRowLens_set A AS AP).
Proof.
  autounfold. intros.   rewrite H. reflexivity.
Qed.

Definition MatrixMaybeRowLens_set {A} {AS : Setoid A} AP := injF (@_MatrixMaybeRowLens_set A AS AP) _.

Definition _MatrixMaybeRowLens_view {A} {AS : Setoid A} {AP : Pointed A} ri: matrixpS AS ~>  maybeS (listaS AS) :=
  view @ (matrixRowPreview ri).

Instance _MatrixMaybeRow_view_Proper A (AS : Setoid A) AP : Proper (equiv ==> equiv) (@_MatrixMaybeRowLens_view A AS AP).
Proof.
  autounfold. intros.  rewritesr.
Qed.

Definition MatrixMaybeRowLensP_view {A} {AS : Setoid A} {AP : Pointed A} := injF (@_MatrixMaybeRowLens_view A AS AP ) _.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Theory.Monad.
Require Import Category.Theory.Adjunction.
Require Import Category.Adjunction.Natural.Transformation.
Require Import Category.Instance.Sets.

Generalizable All Variables.

Section AdjunctionMonad.

Context {C : Category}.
Context {D : Category}.
Context {F : D ⟶ C}.
Context {U : C ⟶ D}.

(* Every adjunction gives rise to a monad. However, for the reverse direction,
   just knowing that the monad is formed from the product of two functors is
   not enough information, since one could always just compose [Id] to some
   monad [M], and this would not give an adjoint. *)

Theorem Adjunction_Monad : F ⊣ U → @Monad D (U ◯ F).
Proof.
  intros.
  unshelve econstructor; simpl; intros.
  - apply (to (adj[X])); simpl.
    exact id.
  - apply fmap.
    apply (from (adj[X])); simpl.
    exact id.
  - rewrite <- to_adj_nat_r.
    rewrite <- to_adj_nat_l.
    cat.
  - simpl.
    rewrite <- !fmap_comp.
    apply fmap_respects.
    rewrite <- from_adj_nat_r.
    rewrite <- from_adj_nat_l.
    cat.
  - rewrite <- !fmap_comp; simpl.
    rewrite <- from_adj_nat_l.
    rewrite id_left.
    destruct X, adj; simpl in *.
    rewrite iso_from_to.
    exact fmap_id.
  - rewrite <- to_adj_nat_r; simpl.
    rewrite id_right.
    destruct X, adj; simpl in *.
    rewrite iso_to_from.
    reflexivity.
  - rewrite <- !fmap_comp; simpl.
    apply fmap_respects.
    rewrite <- from_adj_nat_r.
    rewrite <- from_adj_nat_l.
    cat.
Qed.

Theorem Adjunction_Nat_Monad : F ∹ U → @Monad D (U ◯ F).
Proof.
  intros.
  unshelve econstructor; simpl; intros.
  - exact (transform[unit] _).
  - exact (fmap (transform[counit] _)).
  - symmetry.
    apply (naturality[unit]).
  - rewrite <- !fmap_comp.
    apply fmap_respects.
    symmetry.
    apply (naturality[counit]).
  - rewrite <- !fmap_comp.
    srewrite (@counit_fmap_unit); cat.
  - simpl.
    srewrite (@fmap_counit_unit); cat.
  - rewrite <- !fmap_comp.
    srewrite (naturality[counit]); cat.
Qed.

End AdjunctionMonad.


Require Import VST.msl.Extensionality.
Require Import VST.msl.sepalg.
Require Import VST.msl.ageable.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.base.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.
Require Import VST.msl.subtypes.
Require Import VST.msl.subtypes_sl.
Require Import VST.msl.predicates_rec.

(* Given a separation algebra on type [A], we can make a separation logic
   with predicates of type  [pred A].  But the type   [B -> pred A] is also
   a natural separation logic.  These typeclasses automagically extend
   the separation-logic operators to the pointwise-function case.
   At present, this is just the beginnings of an experiment with this idea;
   don't expect it to work well enough to be useful.
   Andrew Appel, August 2012, following an approach suggested by Rob Dockins
*)

Class StarOp A := {  starOp : A -> A -> A }.

Instance baseStarOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{AgeA: Age_alg A}
 : StarOp (pred A) := {| starOp := sepcon |}.

Instance funStarOp (B: Type)(A: Type)(StarA: StarOp A) : StarOp (B -> A) :=
   {| starOp := fun (P Q : B -> A) (b : B) =>  starOp (P b) (Q b) |}.

Notation "P '*' Q" := (starOp P Q) : pred.
(* Opaque baseStarOp *)

Class DerivesOp A := {  derivesOp : A -> A -> Prop }.

Instance baseDerivesOp {A}{agA: ageable A}
 : DerivesOp (pred A) := {| derivesOp := @derives A agA|}.

Instance funDerivesOp (B: Type)(A: Type)(DerivesA: DerivesOp A) : DerivesOp (B -> A)
 := {| derivesOp := fun (P Q : B -> A)  => forall b, derivesOp (P b) (Q b) |}.
Notation "P '|--' Q" := (derivesOp P%pred Q%pred).
(* Opaque baseDerivesOp. *)

Class WandOp A := {  wandOp : A -> A -> A }.

Instance baseWandOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{AgeA: Age_alg A}
 : WandOp (pred A) := {| wandOp := wand |}.

Instance funWandOp (B: Type)(A: Type)(WandA: WandOp A) : WandOp (B -> A) :=
   {| wandOp := fun (P Q : B -> A) (b : B) =>  wandOp (P b) (Q b) |}.

Notation "P '-*' Q" := (wandOp P Q) : pred.
(* Opaque baseWandOp *)

Class EmpOp A := { Emp: A}.

Instance baseEmpOp {A}{agA: ageable A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AgeA: Age_alg A}
  : EmpOp (pred A) := {| Emp := @emp A JA PA SA agA AgeA |}.

Instance funEmpOp  (B: Type)(A: Type)(EmpA: EmpOp A) : EmpOp (B -> A) :=
   {| Emp := fun (b : B) =>  Emp  |}.

Section Test.
Variable environ: Type.
Variables (rmap : Type)
      (Join_rmap: Join rmap) (Perm_rmap: @Perm_alg rmap Join_rmap)
      (Sep_rmap: @Sep_alg rmap Join_rmap)
      (Canc_rmap: @Canc_alg rmap Join_rmap)
      (Disj_rmap: @Disj_alg rmap Join_rmap)
      (ag_rmap: ageable rmap)
      (Age_rmap: @Age_alg rmap Join_rmap ag_rmap).
Existing Instance  Join_rmap.
Existing Instance  Perm_rmap.
Existing Instance  Sep_rmap.
Existing Instance  Canc_rmap.
Existing Instance  Disj_rmap.
Existing Instance  ag_rmap.
Existing Instance  Age_rmap.

Lemma test1: forall (P : environ -> pred rmap) (Q: pred rmap),
   P * Emp |-- P.
Proof.
 intros.
  intro. simpl; rewrite sepcon_emp.
auto.
Qed.

End Test.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Definition irred e : Prop := forall b, ~(step e b).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "t ->** r" := (steps t r) (at level 68).

Lemma stars_one:
forall a b, step a (e_exp b) -> steps a (e_exp b).
Proof.
eauto using steps.
Qed.

Lemma stars_trans:
forall a b, steps a (e_exp b) -> forall c, steps b (e_exp c) -> steps a (e_exp c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Hint Resolve stars_one stars_trans : core.

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : term => fv_term x) in
  constr:(A `union` B `union` C `union` D `union` F `union` G).

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred v.
Proof.
  introv.
  unfold irred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros;
  try solve[inverts* H;destruct E; unfold fill in H0; inverts* H0];
  try solve[inverts* H;destruct E; unfold fill in H0; inverts* H0;
  inverts* H3;destruct E; unfold fill in H; inverts* H];
  try solve[inverts* H3;destruct E; unfold fill in H; inverts* H].
Qed.

Lemma step_not_walue: forall (v:exp),
    walue v -> irred v.
Proof.
  introv wal.
  unfold irred.
  inductions wal; intros.
  - forwards*: step_not_value H.
  - unfold not;intros;
    try solve[inverts* H0;destruct E; unfold fill in H1; inverts* H1].
Qed.


Inductive three :=
| One
| Two
| Three
.

Theorem t : forall t, t = One \/ t = Two \/ t = Three.


Goal { Tm · τ  = h0 · Si ̅ ¹ · m }.

assert(eq : { Tm = TSi · Tσ }).
{ admit. }
etrans.
{
  apply cancel_postcomposition.
  apply eq.
}
clear eq.
assert(eq : { Tσ · τ  = hx · Sτ · σ }).
{ admit. }
etrans.
{
  repeat rewrite assoc'.
  apply cancel_precomposition.
  repeat rewrite assoc.
  apply eq.
}
repeat rewrite assoc.
clear eq.
assert(eq : { TSi · hx = h0 · STi }).
{ admit. }
etrans.
{
  do 2 apply cancel_postcomposition.
  apply eq.
}
...

asert(eq : { STi · Sτ = Si ̅ ¹ · Si }).
{ admit. }
etrans.
{
  apply cancel_postcomposition.
  repeat rewrite assoc'.
  apply cancel_precomposition.
  repeat rewrite assoc.
  apply eq.
}
repeat rewrite assoc.
clear eq.
assert(eq : { Si · σ = m }).
{ admit. }
etrans.
{
  repeat rewrite assoc'.
  do 2 apply cancel_precomposition.
  repeat rewrite assoc.
  apply eq.
}
repeat rewrite assoc.
clear eq.
 apply idpath.
Qed.


From Coq Require Import Lia.
From OLlibs Require Import List_Type.
From Quantifiers Require Import foformulas_ext nj1_frl.

Set Implicit Arguments.

Section Proofs.

Context {vatom : DecType} {tatom fatom : Type}.

Notation term := (@term vatom tatom nat).
Notation formula := (@formula vatom tatom fatom Nocon Nocon Icon FQcon nat).
Notation frl := (fqtf frl_con).
Notation closed t := (tvars t = nil).
Notation rclosed r := (forall n, closed (r n)).
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").
Notation "⇑" := fup.
Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "l ⇈" := (map (fun F => F↑) l) (at level 8, format "l ⇈").

Notation "'ε' k" := (evar k) (at level 5, format "ε k").

Implicit Type A : formula.

(* Suggested by Dominik Kirst *)
Lemma frli_fresh k x l A : list_max (map eigen_max (A :: l)) < k ->
  prove l A[evar k//x] -> prove l (frl x A).
Proof.
intros Hmax pi; apply denormalization, rfrli; apply normalization in pi.
remember (fun n => if Nat.eqb n k then evar 0 else evar (S n) : term) as rk.
assert (rclosed rk) as Hc by (now intros n; rewrite Heqrk; destruct (n =? k)).
assert (map (esubs rk) (A :: l) = map (fun F => F↑) (A :: l)) as Hrkfup.
{ apply map_ext_in_inf; intros a Hin.
  apply esubs_ext_max; intros n Hle.
  apply list_max_lt_inf in Hmax; [ | intros Hl; inversion Hl ].
  apply (in_inf_map eigen_max), (Forall_inf_forall Hmax) in Hin.
  assert (n <> k) as Hneq by lia.
  now subst rk; apply Nat.eqb_neq in Hneq; rewrite_all Hneq. }
apply (rnpesubs rk) in pi; auto.
rewrite subs_esubs in pi; auto.
injection Hrkfup; intros Hl HA; rewrite Hl, HA in pi.
now subst rk; simpl in pi; rewrite Nat.eqb_refl in pi.
Qed.

Lemma frli_gentzen x l A :
  { k & list_max (map eigen_max (A :: l)) < k & prove l A[evar k//x] -> prove l (frl x A) }.
Proof. exists (S (list_max (map eigen_max (A :: l)))); [ | apply frli_fresh ]; lia. Qed.

(*
Notation "x ∉ A" := (~ In x (freevars A)) (at level 30).
Example gentzen_simulation x l A : x ∉ A -> prove l A -> prove l (frl x A).
Proof.
intros Hf pi.
destruct (frli_gentzen x l A) as [k Hfresh Hfrl]; apply Hfrl; clear Hfrl.
now rewrite nfree_subs.
Qed.
*)

End Proofs.