Require Import floyd.proofauto.
Require Import floyd.library.
Require Import progs.list_dt.  Import LsegSpecial.
Require Import progs.queue2.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_elem := Tstruct _elem noattr.
Definition t_struct_fifo := Tstruct _fifo noattr.

Instance QS: listspec _elem _next (fun sh => malloc_token sh (sizeof t_struct_elem)).
Proof. eapply mk_listspec; reflexivity. Defined.

Lemma isnil: forall {T: Type} (s: list T), {s=nil}+{s<>nil}.
Proof. intros. destruct s; [left|right]; auto. intro Hx; inv Hx. Qed.

Lemma field_at_list_cell:
  forall sh i v p,
  data_at sh t_struct_elem (i,v) p
  = list_cell QS sh i p *
  field_at sh t_struct_elem [StructField _next] v p.
Proof.
intros.
unfold_data_at 1%nat.
f_equal.
unfold field_at, list_cell.
autorewrite with gather_prop.
f_equal.
apply ND_prop_ext.
rewrite field_compatible_cons; simpl.
intuition.
left; auto.
Qed.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH n:Z
   PRE [ _n OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh n p * memory_block Tsh n p).

Definition fifo (contents: list val) (p: val) : mpred :=
  (EX ht: (val*val), let (hd,tl) := ht in
      !! is_pointer_or_null hd && !! is_pointer_or_null tl &&
      data_at Tsh t_struct_fifo (hd, tl) p * malloc_token Tsh (sizeof t_struct_fifo) p *
      if isnil contents
      then (!!(hd=nullval) && emp)
      else (EX prefix: list val, EX last: val,
              !!(contents = prefix++last::nil)
            &&  (lseg QS Tsh prefix hd tl
                   * malloc_token Tsh (sizeof t_struct_elem) tl
                   * data_at Tsh t_struct_elem (last, nullval) tl)))%logic.

Definition fifo_new_spec :=
 DECLARE _fifo_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ (tptr t_struct_fifo) ]
    EX v:val, PROP() LOCAL(temp ret_temp v) SEP (fifo nil v).

Definition fifo_put_spec :=
 DECLARE _fifo_put
  WITH q: val, contents: list val, p: val, last: val
  PRE  [ _Q OF (tptr t_struct_fifo) , _p OF (tptr t_struct_elem) ]
          PROP () LOCAL (temp _Q q; temp _p p)
          SEP (fifo contents q;
                 malloc_token Tsh (sizeof t_struct_elem) p;
                 data_at Tsh t_struct_elem (last,Vundef) p)
  POST [ tvoid ]
          PROP() LOCAL() SEP (fifo (contents++(last :: nil)) q).

Definition fifo_empty_spec :=
 DECLARE _fifo_empty
  WITH q: val, contents: list val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
     PROP() LOCAL (temp _Q q) SEP(fifo contents q)
  POST [ tint ]
      PROP ()
      LOCAL(temp ret_temp (if isnil contents then Vtrue else Vfalse))
      SEP (fifo (contents) q).

Definition fifo_get_spec :=
 DECLARE _fifo_get
  WITH q: val, contents: list val, first: val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
       PROP() LOCAL (temp _Q q) SEP (fifo (first :: contents) q)
  POST [ (tptr t_struct_elem) ]
      EX p:val,
       PROP ()
       LOCAL(temp ret_temp p)
       SEP (fifo contents q;
              malloc_token Tsh (sizeof t_struct_elem) p;
              data_at Tsh t_struct_elem (first,Vundef) p).

Definition make_elem_spec :=
 DECLARE _make_elem
  WITH i: int
  PRE  [ _data OF tint ]
        PROP() LOCAL(temp _data (Vint i)) SEP()
  POST [ (tptr t_struct_elem) ]
    EX p:val,
       PROP()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh (sizeof t_struct_elem) p;
              data_at Tsh t_struct_elem (Vint i, Vundef) p).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Gprog : funspecs :=
  ltac:(with_library prog
    [surely_malloc_spec; fifo_new_spec; fifo_put_spec;
     fifo_empty_spec; fifo_get_spec; make_elem_spec;
     main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     n.
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (malloc_token Tsh n p * memory_block Tsh n p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. inv H0.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma memory_block_fifo:
 forall p,
  field_compatible t_struct_fifo nil p ->
  memory_block Tsh 8 p = field_at_ Tsh t_struct_fifo nil p.
Proof.
 intros.
 change 8 with (sizeof t_struct_fifo).
 rewrite memory_block_data_at_; auto.
Qed.

Lemma fifo_isptr: forall al q, fifo al q |-- !! isptr q.
Proof.
intros.
 unfold fifo.
 if_tac; entailer; destruct ht; entailer!.
Qed.

Hint Resolve fifo_isptr : saturate_local.

Lemma body_fifo_empty: semax_body Vprog Gprog f_fifo_empty fifo_empty_spec.
Proof.
start_function.
unfold fifo.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* h = Q->head; *)
forward. (* return (h == NULL); *)
unfold fifo.
Exists (hd,tl).
destruct (isnil contents).
* entailer!.
  apply andp_right; auto with valid_pointer.
* Intros prefix last.
  Exists prefix last.
  assert_PROP (isptr hd). {
    destruct prefix; entailer.
    rewrite @lseg_cons_eq by auto. Intros y.
    entailer.
 }
 destruct hd; try contradiction.
 entailer!. simpl sizeof. entailer!.
Qed.

Lemma body_fifo_new: semax_body Vprog Gprog f_fifo_new fifo_new_spec.
Proof.
  start_function.
  forward_call (* Q = surely_malloc(sizeof ( *Q)); *)
     (sizeof t_struct_fifo).
    simpl; computable.
  Intros q.
  assert_PROP (field_compatible t_struct_fifo [] q).
   entailer!.
  rewrite memory_block_fifo by auto.
  forward. (* Q->head = NULL; *)
  forward. (* Q->tail = NULL; *)
  forward. (* return Q; *)
  Exists q. unfold fifo. Exists (nullval,nullval).
  rewrite if_true by auto.
  simpl sizeof.
  entailer!.
Qed.

Lemma body_fifo_put: semax_body Vprog Gprog f_fifo_put fifo_put_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* p->next = NULL; *)
forward. (*   h = Q->head; *)
forward_if
  (PROP() LOCAL () SEP (fifo (contents ++ last :: nil) q))%assert.
* if_tac; entailer.  (* typechecking clause *)
* (* then clause *)
  subst.
  forward. (* Q->head=p; *)
  forward. (* Q->tail=p; *)
  entailer.
  unfold fifo.
  destruct (isnil contents).
  + subst. Exists (p,p).
     simpl. rewrite if_false by congruence.
     Exists (@nil val) last.
      rewrite @lseg_nil_eq by auto.
      entailer!.
   + Intros prefix last0.
      destruct prefix;
      entailer!.
      rewrite @lseg_cons_eq by auto. simpl.
      Intros y.
      entailer!.
* (* else clause *)
  forward. (*  t = Q->tail; *)
  destruct (isnil contents).
  + Intros. contradiction H; auto.
  + Intros prefix last0.
     forward. (*  t->next=p; *)
     forward. (* Q->tail=p; *)
     entailer!.
     unfold fifo. Exists (hd, p).
     rewrite if_false by (clear; destruct prefix; simpl; congruence).
     Exists  (prefix ++ last0 :: nil) last.
     entailer.
     fold (data_at Tsh t_struct_elem (last0,p) tl).
     rewrite (field_at_list_cell Tsh last0 p).
     unfold_data_at 2%nat.
     unfold_field_at 3%nat.
     simpl sizeof.
     match goal with
     | |- _ |-- _ * _ * (_ * ?AA) => remember AA as A
     end.     (* prevent it from canceling! *)
     cancel. subst A.
     eapply derives_trans;
        [ | apply (lseg_cons_right_neq QS Tsh prefix hd last0 tl nullval p ); auto].
     simpl sizeof.  cancel.
* (* after the if *)
     forward. (* return ; *)
Qed.

Lemma body_fifo_get: semax_body Vprog Gprog f_fifo_get fifo_get_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
rewrite if_false by congruence.
Intros prefix last.
forward.  (*   h = Q->head; *)
destruct prefix; inversion H; clear H.
+
   rewrite @lseg_nil_eq by auto.
   Intros.
   subst_any.
   forward. (*  n=h->next; *)
   forward. (* Q->head=n; *)
   forward. (* return p; *)
   unfold fifo. Exists tl (nullval, tl).
   rewrite if_true by congruence.
   entailer!. simpl sizeof. unfold_data_at 1%nat. unfold_data_at 1%nat. cancel.
+ rewrite @lseg_cons_eq by auto.
    Intros x.
    simpl @valinject. (* can we make this automatic? *)
    subst_any.
    forward. (*  n=h->next; *)
    forward. (* Q->head=n; *)
    forward. (* return p; *)
    Exists hd. unfold fifo. Exists (x, tl).
    rewrite if_false by (destruct prefix; simpl; congruence).
    Exists prefix last.
    entailer!.
    rewrite field_at_list_cell. simpl sizeof. cancel.
Qed.

Lemma body_make_elem: semax_body Vprog Gprog f_make_elem make_elem_spec.
Proof.
start_function.
forward_call (*  p = surely_malloc(sizeof ( *p));  *)
  (sizeof t_struct_elem).
 simpl; computable.
 Intros p.
 assert_PROP (field_compatible t_struct_elem [] p). entailer!.
 rewrite memory_block_data_at_ by auto.
forward.  (*  p->data=i; *)
simpl.
forward. (* return p; *)
Exists p.
entailer!.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_call (* Q = fifo_new(); *)  tt.
Intros q.

forward_call  (*  p = make_elem(1); *)
     (Int.repr 1).
Intros p'.
forward_call (* fifo_put(Q,p);*)
    ((q, @nil val),p', Vint (Int.repr 1)).

forward_call  (*  p = make_elem(2); *)
     (Int.repr 2).
Intros p2.
simpl app.
 forward_call  (* fifo_put(Q,p); *)
    (((q,[Vint (Int.repr 1)]),p2), Vint (Int.repr 2)).
simpl app.
forward_call  (*   p' = fifo_get(Q); p = p'; *)
    ((q,[Vint (Int.repr 2)]), Vint (Int.repr 1)).
Intros p3.
forward. (*   i = p->data;  *)
forward_call (*  free(p); *)
   (p3, sizeof t_struct_elem).
 assert_PROP (field_compatible t_struct_elem [] p3) by entailer!.
 rewrite memory_block_data_at_ by auto.
 cancel.
 forward. (* return i; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma ret_temp_make_ext_rval:
  forall gx ret p,
   locald_denote (temp ret_temp p) (make_ext_rval gx ret) ->
    p = force_val ret.
Proof.
  intros.
  hnf in H.
  rewrite retval_ext_rval in H. auto.
Qed.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
semax_func_cons body_free.
semax_func_cons body_exit.
semax_func_cons body_surely_malloc.
semax_func_cons body_fifo_new.
semax_func_cons body_fifo_put.
semax_func_cons body_fifo_empty.
semax_func_cons body_fifo_get.
semax_func_cons body_make_elem.
semax_func_cons body_main.
Qed.


Global
Set Primitive Projections.
Global
Unset Printing Primitive Projection Parameters.

Global
Set Universe Polymorphism.

Global
Set Default Goal Selector "!".

From Ltac2 Require Import Ltac2.

Set Default Proof Mode "Classic".

Require Import Coq.Unicode.Utf8.
Require Import Coq.Lists.List.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Module Import Bundle.
  #[universes(cumulative)]
  Record bundle A := suprema {
    s: Type ;
    π: s → A ;
  }.

  Arguments suprema [A s].
  Arguments s [A].
  Arguments π [A].

  Coercion s: bundle >-> Sortclass.
  Coercion π: bundle >-> Funclass.

  Notation "'sup' x .. y , P" := {| π x := .. {| π y := P |} .. |}
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' 'sup'  x .. y ']' , '/' P ']'").
End Bundle.

Module Import Span.

  #[universes(cumulative)]
  Record span A B := {
    s: Type ;
    π1: s → A ;
    π2: s → B ;
  }.

  Arguments s [A B].
  Arguments π1 [A B].
  Arguments π2 [A B].

  Coercion s: span >-> Sortclass.

  Module Export SpanNotations.
    Reserved Notation "'SPAN' x , P ———— Q" (x ident, at level 90, format "'SPAN' x , '//' P '//' ———— '//' Q").
    Reserved Notation "'SPAN' x : A , P ———— Q" (x ident, at level 90, format "'SPAN' x : A , '//' P '//' ———— '//' Q").
    Reserved Notation "'SPAN' ( x : A ) , P ———— Q" (x ident, at level 90, format "'SPAN' ( x : A ) , '//' P '//' ———— '//' Q").

    Notation "'SPAN' x , P ———— Q" := {| π1 x := P ; π2 x := Q |} .
    Notation "'SPAN' x : A , P ———— Q" := {| π1 (x : A) := P ; π2 (x : A) := Q |} .
    Notation "'SPAN' ( x : A ) , P ———— Q" := {| π1 (x : A) := P ; π2 (x : A) := Q |} .
  End SpanNotations.
End Span.

Module Import Logic.
  Import List.ListNotations.

  (* FIXME have an or for results as well ? *)
  Definition axiom C := span C C.

  Definition axiom_scheme C := bundle (axiom C).
  Definition theory C := bundle (axiom_scheme C).

  (* FIXME make category *)
  Inductive syn {K} {th: theory K}: K → K → Type :=
  | syn_id {A}: syn A A
  | syn_compose {A B C}: syn B C → syn A B → syn A C

  | syn_axiom rule args C D:
      (∀ ix, syn C (π1 (th rule args) ix)) →
      (∀ ix, syn (π2 (th rule args) ix) D) →
      syn C D
  .
End Logic.

Module Import Sanity.
  #[universes(cumulative)]
  Class Propositional := {
    P: Type ;

    true: P ;
    and: P → P → P ;

    false: P ;
    or: P → P → P ;
  }.

  Infix "∧" := and.
  Infix "∨" := or.

  Variant idx :=
  | bang
  | absurd
  | inl | inr | fanin
  | fst | snd | fanout.

  Definition propositional `{Propositional}: theory P := sup ix,
    match ix with
    | bang => sup A,
              SPAN (_: True),
               A
               ————
               true

    | absurd => sup A,
                SPAN (_: True),
                  false
                  ————
                  A

    | fanin => sup '(A, B),
                SPAN b:bool,
                      A ∨ B
                      ————
                      if b then A else B

    | inl => sup '(A, B),
             SPAN _:True,
                   A
                   ————
                   A ∨ B
    | inr => sup '(A, B),
             SPAN _:True,
                   B
                   ————
                   A ∨ B

    | fanout => sup '(A, B),
                SPAN b:bool,
                      (if b then A else B)
                      ————
                      A ∧ B

    | fst => sup '(A, B),
             SPAN _:True,
                   A ∧ B
                   ————
                   A

    | snd => sup '(A, B),
             SPAN _:True,
                   A ∧ B
                   ————
                   B
    end
    .

  Section sanity.
    Context `{Propositional}.

    Definition free := @syn _ propositional.

    Definition bang' C: free C true := @syn_axiom _ propositional
                                                  bang C
                                                  C true
                                                  (λ _, syn_id)
                                                  (λ _, syn_id).

    Definition inl' A B: free A (A ∨ B) := @syn_axiom _ propositional
                                                      inl (A, B)
                                                      A (A ∨ B)
                                                      (λ _, syn_id) (λ _, syn_id).
    Definition inr' A B: free B (A ∨ B) := @syn_axiom _ propositional
                                                      inr (A, B)
                                                      B (A ∨ B)
                                                      (λ _, syn_id)
                                                      (λ _, syn_id).

    #[program]
    Definition fanin' C A B (f: free A C) (g: free B C) :=
      @syn_axiom _ propositional
                 fanin (A, B)
                 (A ∨ B) C
                 (λ _, syn_id) _.

    Next Obligation.
      destruct ix.
      - apply f.
      - apply g.
    Defined.

    #[program]
     Definition fanout' C A B (f: free C A) (g: free C B): free C (A ∧ B) :=
      @syn_axiom _ propositional
                 fanout (A, B)
                 C (A ∧ B)
                 _ (λ _, syn_id).
    Next Obligation.
      destruct ix.
      - apply f.
      - apply g.
    Defined.

    Definition fst' A B: free (A ∧ B) A := @syn_axiom _ propositional
                                                      fst (A, B)
                                                      (A ∧ B) A
                                                      (λ _, syn_id) (λ _, syn_id).
    Definition snd' A B: free (A ∧ B) B := @syn_axiom _ propositional
                                                      snd (A, B)
                                                      (A ∧ B) B
                                                      (λ _, syn_id) (λ _, syn_id).
  End sanity.

  Instance as_Prop: Propositional := {
    P := Prop ;

    true := True ;
    and := Logic.and ;

    false := False ;
    or := Logic.or ;
  }.

  Definition eval_Prop [A B: @P as_Prop]: free A B → A → B.
    intros f.
    induction f.
    - intro x.
      apply x.
    - intro x.
      apply (IHf1 (IHf2 x)).
    - destruct rule.
      all: cbn in *.
      + intro x.
        apply H0.
        all: auto.
      + intro x.
        set (H' := H I x).
        contradiction.
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        left.
        apply (H I x).
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        right.
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        refine (_ (H Datatypes.false x)).
        * intro x'.
          destruct x'.
          -- apply (H0 Datatypes.true H1).
          -- apply (H0 Datatypes.false H1).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 Datatypes.false).
        split.
        * apply (H Datatypes.true x).
        * apply (H Datatypes.false x).
  Defined.

  Instance as_Set: Propositional := {
    P := Set ;

    true := unit ;
    and := prod ;

    false := Empty_set ;
    or := sum ;
  }.

  Definition eval_Set [A B: @P as_Set]: free A B → A → B.
    intros f.
    induction f.
    - intro x.
      apply x.
    - intro x.
      apply (IHf1 (IHf2 x)).
    - destruct rule.
      all: cbn in *.
      + intro x.
        apply (H0 I tt).
      + intro x.
        set (H' := H I x).
        contradiction.
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        left.
        apply (H I x).
      + intro x.
        destruct args as [P Q].
        cbn in *.
        apply (H0 I).
        right.
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        refine (_ (H Datatypes.false x)).
        * intro x'.
          destruct x' as [p|q].
          -- apply (H0 Datatypes.true p).
          -- apply (H0 Datatypes.false q).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 I).
        apply (H I x).
      + destruct args as [P Q].
        cbn in *.
        intro x.
        apply (H0 Datatypes.false).
        split.
        * apply (H Datatypes.true x).
        * apply (H Datatypes.false x).
  Defined.

  Example foo `{Propositional}: free true (true ∧ true) := fanout' _ _ _ (bang' _) (bang' _).

  Definition foo' := eval_Set foo.
End Sanity.

(* FIXME do the same thing but with bundles ? *)
Module Import Hoas.
  #[universes(cumulative)]
  Class Lam := {
    tm: Type ;
    ty: Type ;

    pt: ty ;
    exp: ty → ty → ty ;

    lam: ty → (tm → tm) → tm ;
    app: tm → tm → tm ;
  }.
End Hoas.

Module Import Spec.
  Import List.ListNotations.

  Variant type_query `{Lam} := ofty (_:tm) (_: ty).

  Module Export SpecNotations.
    Infix "∈" := ofty (at level 40).
  End SpecNotations.

  Open Scope logic_scope.

  Variant index := app_rule | lam_rule.
  Definition stlc `{Lam}: theory type_query := {|
    dom := index ;
    proj x :=
      match x with
      | app_rule => FREE (A, B, f, x) ,
                      app f x ∈ B ⊢ [
                           f ∈ exp A B ;
                           x ∈ A ]
        (*
       Not sure how I'm going to handle variables, not correct at all here,
       Also not sure how I'm going to handle evaluating expressions
         *)
      | lam_rule => FREE (A, B, f, x) ,
                      lam A f ∈ exp A B ⊢ [
                           x ∈ A ;
                           f x ∈ B]
      end
   |}.
End Spec.

Module Import Sanity.
  Import List.ListNotations.

  Section sanity.
    Context `{Lam}.

    Definition free := @syn _ stlc.

    Definition foo x A: free [ x ∈ A ; x ∈ A ] [].
      apply (syn_weaken nil).
    Defined.
  End sanity.
End Sanity.

Module Import Lattice.
  #[universes(cumulative)]
  Class Lattice := {
    S: Type ;

    top: S ;
    bot: S ;

    meet: S → S → S ;
    join: S → S → S ;
  }.

  Definition meet_all `{Lattice}: list S → S := List.fold_right meet top.
  Definition join_all `{Lattice}: list S → S := List.fold_right join bot.

  Module Export LatticeNotations.
    Declare Scope lattice_scope.
    Delimit Scope lattice_scope with lattice.
    Bind Scope lattice_scope with S.

    Notation "⊤" := top : lattice_scope.
    Notation "⊥" := bot : lattice_scope.

    Infix "∧" := meet : lattice_scope.

    Notation "⋀" := meet_all : lattice_scope.
    Notation "⋁" := join_all : lattice_scope.

    Coercion S: Lattice >-> Sortclass.
  End LatticeNotations.
End Lattice.

(* FIXME implement a Lattice algebra using bundles and interpret
everything categorically *)
Module Import Pred.
  #[program]
   Definition predicate_logic A: Lattice := {|
    S := A → Prop ;

    top _ := True ;
    bot _ := False ;

    meet P Q x := P x ∧ Q x ;
    join P Q x := P x ∨ Q x ;
  |}.
End Pred.

Module Import Sanity.
  Local Set Implicit Arguments.

  Definition ofty `{Lam} A B f x := check stlc app_rule (A, B, f, x).
  Check ofty.
  Definition ofty `{Lam} i v x A :=
    let (H, T) := chk (predicate_logic _) (simplify pred_stlc) {| ix := i ; val := v |}  in
    H (x ∈ A) → T (x ∈ A).
  Definition foo `{Lam} A: ofty (lam A (λ x, x)) (exp A A).
    exists lam_rule.
    intro.
    cbn in *.
    destruct .

  Definition bar `{Lam} := foo 0 I.
  #[program]
   Definition bar `{Lam} := foo 1 _.
  Next Obligation.
    cbn.
  (* Definition foo `{Lam}: oftype (λ x, x = P ∈ T) (λ x, x = P ∈ T) *)
    cbn.
    eexists.
    Unshelve.
    2: {
      cbn.
      left.
      exists.
    }
    cbn.
    reflexivity.
  Qed.
End Sanity.

Module Import Foo.
  Definition type_Lattice := {|
    S := Set ;

    top := True ;
    bot := False ;

    meet P Q := P * Q ;
    join P Q := P + Q ;
  |}.
  Definition oftype `{Lam} (p: any_head rules) :=
      let (H, T) := chk type_Lattice (λ q, {x: type_query | q = x}) rules p in
      T → H.

  Definition bar `{Lam} : any_head rules.
    cbn.
    left.
    exists.
  Defined.

  Definition foo `{Lam}: oftype bar.
    cbn.
    intros.
    exists (P ∈ T).
    reflexivity.
  Defined.
End Foo.


Require Import Arith List.
Import List.ListNotations.
Require Import Eqdep FunctionalExtensionality Coq.Program.Tactics.
Require Import Coq.Init.Specif.
Require Import Coq.Logic.JMeq.

Require Import TPipStaticM2.
Require Import TRInductM2.
Require Import DetermM2.
(* Require Import Test3. *)

Module Reflect (IdT: IdModType) <: IdModType.
(* Export IdT. *)

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module DeterminismC := Determinism IdT.
Export DeterminismC.

Definition MM (S A : Type) : Type := S -> A * S.

Definition ret {S A : Type} (a : A) : MM S A :=
  fun s => (a , s).

Definition bind {S A B : Type} (m : MM S A)(f : A -> MM S B) : MM S B :=
fun s => match m s with
    | (a, s') => f a s'
    end.

(*************************************************************************)

Definition VTyp_Trans (t: VTyp) : Type :=
  vtypExt t.

Definition PTyp1_Trans (pt: PTyp) : list Type :=
  match pt with
      PT ts => map vtypExt ts
  end.

Fixpoint TList_Trans (ts: list VTyp) : Type :=
  match ts with
      | nil => unit
      | (t::ts') => (VTyp_Trans t) * (TList_Trans ts')
  end.

Definition valTC_Trans (tenv: valTC) : Type := TList_Trans (map snd tenv).

(*
Fixpoint valTC_Trans (tenv: valTC) : Type :=
  match tenv with
      | nil => unit
      | (t::ts) => (VTyp_Trans (snd t)) * (valTC_Trans ts)
  end.
*)

Definition PTyp_Trans (pt: PTyp) : Type :=
  match pt with
      PT ts => TList_Trans ts
  end.

Fixpoint tlist2type (ts: list Type) : Type :=
  match ts with
    | nil => unit
    | (t::ts') => t * tlist2type ts'
  end.

Inductive IsTypeList1 : list Type -> Type :=
  | IsTLN1 : IsTypeList1 nil
  | IsTLC1 : forall (ts: list Type) (t: Type),
              IsTypeList1 ts -> IsTypeList1 (t::ts).

Program Fixpoint listTypTrA (xts: list Type) (ps : tlist2type xts) :
  list Value := _.

Next Obligation.
  dependent induction xts.
  exact nil.
  inversion ps; subst.
  apply IHxts in X0.
  exact (cst a X::X0).
(*  Show Proof. *)
Defined.

Program Fixpoint listTypTrB (xts: list VTyp) (ps : TList_Trans xts) :
  list Value := _.

Next Obligation.
  dependent induction xts.
  exact nil.
  inversion ps; subst.
  apply IHxts in X0.
  exact (cst (VTyp_Trans a) X::X0).
Defined.

Program Fixpoint listTypTr (xts: list VTyp) (ps : TList_Trans xts) :
  list Value := _.

Next Obligation.
  revert ps.
  induction xts.
  intros.
  exact nil.
  intros.
  simple inversion ps; subst.
  intros.
  apply IHxts in X0.
  exact (cst (VTyp_Trans a) X::X0).
Defined.

Lemma listTypTrL1 (t: VTyp) (ts: list VTyp)
                   (v: VTyp_Trans t) (pv: TList_Trans ts) :
  listTypTr (t::ts) (v,pv) = (cst (vtypExt t) v) :: (listTypTr ts pv).

unfold VTyp_Trans in v.
unfold vtypExt in v.
unfold vtypExt.
simpl.
unfold VTyp_Trans.
unfold vtypExt.
simpl.
cut (listTypTr_obligation_1 ts pv = listTypTr ts pv).
intros.
rewrite H.
reflexivity.
revert pv.
induction ts.
intros.
reflexivity.
intros.
simpl.
reflexivity.
Defined.

Inductive IsTypeList : list Type -> list Value -> Type :=
  | IsTLN : IsTypeList nil nil
  | IsTLC : forall (ts: list Type) (vs: list Value) (t: Type) (v: t),
              IsTypeList ts vs -> IsTypeList (t::ts) (cst t v::vs).

Definition valTC2_Trans (tenv: valTC) : list (Id * Type) :=
  map (fun (x: Id * VTyp) => (fst x, VTyp_Trans (snd x))) tenv.

Definition valTC1_Trans (tenv: valTC) : list Type :=
  map (fun (x: Id * VTyp) => (VTyp_Trans (snd x))) tenv.

Fixpoint valTC_TransA (tenv: valTC) : Type :=
  match tenv with
      | nil => unit
      | (t::ts) => (VTyp_Trans (snd t)) * (valTC_TransA ts)
  end.

Definition FTyp_Trans1 (ft: FTyp) : Type :=
  match ft with
    | FT tenv t => valTC_Trans tenv -> MM W (VTyp_Trans t)
  end.

Definition FTyp_Trans (ft: FTyp) : Type :=
   valTC_Trans (extParType ft) -> MM W (VTyp_Trans (extRetType ft)).
Definition funTC2_Trans (tenv: funTC) : list (Id * Type) :=
  map (fun (x: Id * FTyp) => (fst x, FTyp_Trans (snd x))) tenv.

Definition funTC1_Trans (tenv: funTC) : list Type :=
  map (fun (x: Id * FTyp) => (FTyp_Trans (snd x))) tenv.

Fixpoint funTC_Trans (tenv: funTC) : Type :=
  match tenv with
      | nil => unit
      | (t::ts) => (FTyp_Trans (snd t)) * (funTC_Trans ts)
  end.

Definition Value_Trans (v: Value) :  projT1 v := cstExt v.

(*********************)

Definition valTyp (v: Value) : Type := projT1 v.

Definition vList_Typ_Trans (ls: list Value) : Type :=
      tlist2type (map valTyp ls).

Program Fixpoint vList_Trans (ls: list Value) : vList_Typ_Trans ls
        (*  tlist2type (map valTyp ls) *)
  := _.
Next Obligation.
  induction ls.
  simpl.
  exact tt.
  simpl.
  split.
  exact (Value_Trans a).
  exact IHls.
Defined.

Definition valEnv_Typ_Trans (env: valEnv) : Type :=
    vList_Typ_Trans (map snd env).

Definition valEnv_Trans (env: valEnv) :
  valEnv_Typ_Trans env := vList_Trans (map snd env).

Lemma WT_Value_Trans (v: Value) (t: VTyp) :
   ValueTyping v t -> valTyp v = VTyp_Trans t.
  intros.
  inversion H; subst.
  unfold valTyp.
  unfold VTyp_Trans.
  unfold vtypExt.
  auto.
Defined.

Lemma WT_valEnv_Trans_eq (tenv: valTC) (env: valEnv) :
  EnvTyping env tenv ->
              valTC_Trans tenv = valEnv_Typ_Trans env.
  intros.
  dependent induction X.
  compute.
  reflexivity.
  assert (valTC_Trans ((k, v2) :: ls2) =
          prod (VTyp_Trans v2) (valTC_Trans ls2)).
  reflexivity.
  assert (valEnv_Typ_Trans ((k, v1) :: ls1) =
          prod (valTyp v1) (valEnv_Typ_Trans ls1)).
  reflexivity.
  rewrite H.
  rewrite H0.
  rewrite IHX.
  eapply WT_Value_Trans in r.
  rewrite r.
  auto.
Defined.

Lemma WT_valEnv_Trans (tenv: valTC) (env: valEnv) :
  EnvTyping env tenv -> valTC_Trans tenv.
intros.
assert (valEnv_Typ_Trans env).
exact (valEnv_Trans env).
rewrite (WT_valEnv_Trans_eq tenv env).
exact X0.
exact X.
Defined.

(**********************)

Definition E_Trans0 :=
    fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
          (e: Exp) (t: VTyp) (ET: ExpTyping ftenv tenv fenv e t) =>
        MM W (VTyp_Trans t).

Definition F_Trans0 := fun (f: Fun) (ft: FTyp)
               (ET: FunTyping f ft) => FTyp_Trans ft.

Definition Q_Trans0 :=
    fun (ftenv: funTC) (fenv: funEnv) (q: QFun) (ft: FTyp)
                (ET: QFunTyping ftenv fenv q ft) =>
                        FTyp_Trans ft.

Definition P_Trans0 :=
    fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ps: Prms) (ts: PTyp)
                (ET: PrmsTyping ftenv tenv fenv ps ts) =>
       MM W (PTyp_Trans ts).

Definition ExpTypingTrans0_rect :=
  ExpTyping_str_rect
           F_Trans0 Q_Trans0 E_Trans0 P_Trans0.

(************************************)

Definition E_Trans :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
          (e: Exp) (t: VTyp) (ET: ExpTyping ftenv tenv fenv e t) =>
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (VTyp_Trans t).

Definition F_Trans :=
  fun (f: Fun) (ft: FTyp)
               (FT: FunTyping f ft) =>
 (* forall env: valEnv,
       EnvTyping env (extParType ft) -> *)
       FTyp_Trans ft.

Definition Q_Trans :=
  fun (ftenv: funTC) (fenv: funEnv) (q: QFun) (ft: FTyp)
                          (QT: QFunTyping ftenv fenv q ft) =>
  FEnvTyping fenv ftenv ->
(*  forall env: valEnv,
       EnvTyping env (extParType ft) ->  *)
       FTyp_Trans ft.

Definition P_Trans :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ps: Prms) (ts: PTyp)
                (ET: PrmsTyping ftenv tenv fenv ps ts) =>
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (PTyp_Trans ts).

Definition ExpTypingTrans_rect :=
  ExpTyping_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Definition FunTypingTrans_rect :=
  ExpTypingF_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Definition ParTypingTrans_rect :=
  ExpTypingP_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Definition QFunTypingTrans_rect :=
  ExpTypingQ_str_rect
           F_Trans Q_Trans E_Trans P_Trans.

Lemma envTypingListTT (fps : valTC) (t0 : TList_Trans (map snd fps)):
  EnvTyping (mkVEnv fps (listTypTr (map snd fps) t0)) fps.
Proof.
    unfold mkVEnv.
    dependent induction fps.
    constructor.
    destruct a.
    rewrite map_cons.

    assert (listTypTr (map snd ((i, v) :: fps)) t0 =
            listTypTr (snd (i, v) :: (map snd fps)) t0).
    simpl.
    reflexivity.

    rewrite H.

    assert (listTypTr (snd (i, v) :: (map snd fps)) t0 =
            listTypTr (v :: (map snd fps)) t0).
    simpl.
    reflexivity.

    rewrite H0 at 1.

    assert (fst (i,v) = i).
    auto.

    rewrite H1.

    destruct t0.

    rewrite listTypTrL1.

    simpl.
    constructor.
    constructor.
    simpl.
    reflexivity.
    simpl.
    constructor.

    assert (EnvTyping (interleave (map fst fps)
                                  (listTypTr (map snd fps) t)) fps).
    eapply IHfps.
    unfold EnvTyping in X.
    exact X.
Defined.

Program Fixpoint Exp_Trans
        (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t: VTyp) (ET: ExpTyping ftenv tenv fenv e t) :
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (VTyp_Trans t) := _
with Fun_Trans
               (f: Fun) (ft: FTyp)
               (ET: FunTyping f ft) :
(*  forall env: valEnv,
       EnvTyping env (extParType ft) ->  *)
       FTyp_Trans ft := _
with QFun_Trans
                (ftenv: funTC) (fenv: funEnv) (q: QFun) (ft: FTyp)
                (ET: QFunTyping ftenv fenv q ft) :
  FEnvTyping fenv ftenv ->
(*  forall env: valEnv,
       EnvTyping env (extParType ft) ->  *)
       FTyp_Trans ft := _
with Prms_Trans
                (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ps: Prms) (ts: PTyp)
                (ET: PrmsTyping ftenv tenv fenv ps ts) :
  FEnvTyping fenv ftenv ->
  forall env: valEnv,
        EnvTyping env tenv ->
        MM W (PTyp_Trans ts) := _.

Next Obligation.

  revert X0.
  revert env.
  revert X.
  revert ET.
  revert e t.
  eapply ExpTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X0)) tenv0).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X1)) tenv0).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv0 x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv0 ftenvP ftenv0 m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv0 k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - (* PS *)
    unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

Next Obligation.

  revert ET.
  revert f ft.
  eapply FunTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X0)) tenv).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X1)) tenv).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv ftenvP ftenv m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

Next Obligation.

  revert X0.
  revert env.
  revert X.
  revert ET.
  revert ps ts.
  eapply ParTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X0)) tenv0).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv0 (listTypTr (map snd tenv0) X1)) tenv0).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv0 x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv0 ftenvP ftenv0 m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv0 k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

Next Obligation.

  revert X.
  revert ET.
  revert q ft.
  eapply QFunTypingTrans_rect.

  - (* forall2_nil *)
    unfold Par_SSL.
    intros.
    constructor.
  - (* forall2_cons *)
    unfold Par_SSL.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs_nil *)
    unfold Par_SSA.
    constructor.
  - (* matchenvs_cons *)
    unfold Par_SSA.
    intros.
    econstructor.
    exact X0.
    exact X.
  - (* matchenvs2_split *)
    unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    assumption.
    assumption.
    exact X.
    exact X0.
    exact X1.
  - (* funz *)
    unfold E_Trans, F_Trans.
    unfold FTyp_Trans.
    intros.
    specialize (X m).
    unfold valTC_Trans in X0.
    assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X0)) tenv).
    + apply envTypingListTT.
    + apply X in X1.
      exact X1.
  - (* funs *)
    unfold E_Trans, F_Trans.
    intros.
    unfold FTyp_Trans.
    intros.
    assert (FEnvTyping fenv' ftenv').
    + rewrite h1.
      rewrite h2.
      eapply updateFEnvLemma.
      exact m.
      exact k2.
    + specialize (X X2).
      (* unfold FTyp_Trans in X0. *)
      unfold valTC_Trans in X1.
      assert (EnvTyping (mkVEnv tenv (listTypTr (map snd tenv) X1)) tenv).
      * apply envTypingListTT.
      * apply X in X3.
        exact X3.
  - (* QF *)
    unfold Q_Trans, F_Trans.
    intros.
    exact X.
  - (* FVar *)
    unfold Par_SSB, Q_Trans, F_Trans.
    intros.
    destruct ft.
    inversion X; subst; clear X.
    exact X3.
  - (* modify *)
    unfold E_Trans.
    intros.
    simpl.
    destruct XF.
    unfold MM.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      simpl in H0.
      destruct v.
      destruct v.
      simpl in H0.
      clear k.
      clear H.
      clear H1.
      rewrite H0 in v.
      intros.
      exact (b_eval0 X1 v, b_exec0 X1 v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t:=vtyp T1) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f.
      clear v.
      clear H0.
      rewrite H in v0.
      intros.
      exact (b_eval0 X0 v0, b_exec0 X0 v0).
      exact X2.
  - (* return *)
    unfold E_Trans.
    intros.
    simpl.
    inversion k; subst.
    + inversion H; subst.
      subst T.
      destruct v.
      destruct v.
      simpl in H0.
      unfold VTyp_Trans.
      unfold vtypExt.
      clear k H H1.
      rewrite H0 in v.
      exact (ret v).
    + inversion X1; subst.
      eapply ExRelValT with (x0:=x) (t0:=t) in X0.
      destruct X0.
      destruct x0.
      destruct v0.
      inversion v; subst.
      subst T.
      simpl in H.
      clear f v H0.
      rewrite H in v0.
      exact (ret v0).
      exact X2.
  - (* bindn *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1 env X2).
    exact (bind X (fun _ => X0)).
  - (* binds *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X1 env X2).
    specialize (X0 X1).
    unfold MM.
    intros.
(**)
    unfold MM in X.
    apply X in X3.
    destruct X3.
    eapply (updateVEnvLemma env tenv x
                            (cst (VTyp_Trans t1) v) t1) in X2.
    specialize (X0 (updateE env x (cst (VTyp_Trans t1) v))).
    rewrite h in X0.
    apply X0 in X2.
    apply (X2 w).
    unfold VTyp_Trans.
    unfold vtypExt.
    constructor.
    simpl.
    reflexivity.
    constructor.
  - (* bindms *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (overrideFEnvLemma
                                  fenvP fenv0 ftenvP ftenv0 m2 X0).
    intro.
    rewrite h2 in X.
    rewrite h3 in X.
    specialize (X X2).
    specialize (overrideVEnvLemma envP env tenvP tenv k1 X1).
    intros.
    rewrite h1 in X.
    apply X in X3.
    exact X3.
  - (* apply *)
    unfold E_Trans, Q_Trans, P_Trans.
    intros.
    specialize (X X1).
    specialize (X0 X1 env X2).
    simpl in X.
    inversion k2; subst.
    unfold env2ptyp in H3.
    inversion H3; subst.
    simpl in X0.
    unfold MM; intros.
    unfold MM in X0.
    specialize (X0 X4); clear X4.
    destruct X0.
    clear H3.
    specialize (X t0).

    unfold MM in X.
    apply (X w).

  - (* val *)
    unfold E_Trans.
    intros.
    simpl.
    unfold VTyp_Trans.
    unfold vtypExt.
    inversion k.
    subst T.
    rewrite <- H.
    exact (ret (cstExt v)).
  - (* ifthenelse *)
    unfold E_Trans.
    intros.
    simpl.
    specialize (X X2 env X3).
    specialize (X0 X2 env X3).
    specialize (X1 X2 env X3).

    unfold MM; intro.
    unfold MM in X.
    specialize (X X4).
    destruct X.
    simpl in v.
    destruct v.
    exact (X0 w).
    exact (X1 w).
  - unfold Par_SSL, P_Trans.
    unfold E_Trans.
    intros.
    simpl.
    induction X.
    simpl.
    exact (ret tt).
    simpl.
    specialize (p0 X0 env X1).
    inversion m; subst.
    specialize (IHX X3).
    unfold MM; intro.
    specialize (p0 X4).
    destruct p0.
    specialize (IHX w).
    destruct IHX.
    exact (v, t, w0).
Defined.

End Reflect.


Require Import VST.floyd.proofauto.
Require Import VST.progs.append.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sh: share)
            (contents: list val) (x: val) : mpred :=
 match contents with
 | h::hs =>
              EX y:val,
                data_at sh t_struct_list (h,y) x * listrep sh hs y
 | nil => !! (x = nullval) && emp
 end.

Arguments listrep sh contents x : simpl never.

Lemma listrep_local_facts:
  forall sh contents p,
     listrep sh contents p |--
     !! (is_pointer_or_null p /\ (p=nullval <-> contents=nil)).
Proof.
intros.
revert p; induction contents;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sh contents p,
   sepalg.nonidentity sh ->
   listrep sh contents p |-- valid_pointer p.
Proof.
 destruct contents; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma listrep_null: forall sh contents,
    listrep sh contents nullval = !! (contents=nil) && emp.
Proof.
destruct contents; unfold listrep; fold listrep.
autorewrite with norm. auto.
apply pred_ext.
Intros y. entailer. destruct H; contradiction.
Intros. discriminate.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition append_spec :=
 DECLARE _append
  WITH sh : share, x: val, y: val, s1: list val, s2: list val
  PRE [ tptr t_struct_list , tptr t_struct_list]
     PROP(writable_share sh)
     PARAMS (x; y) GLOBALS()
     SEP (listrep sh s1 x; listrep sh s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     RETURN (r)
     SEP (listrep sh (s1++s2) r).

Definition Gprog : funspecs :=   ltac:(with_library prog [ append_spec ]).

Module Proof1.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null.  Intros.  subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep at 1; fold listrep.
 Intros.  contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      ( EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP ()
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (listrep sh (a::s1b++s2) t -* listrep sh (s1++s2) x;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists v s1' x u.
   subst s1. entailer!. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1.
   destruct s1b; unfold listrep at 3; fold listrep. Intros. contradiction.
   Intros z.
   forward.
   forward.
   Exists (v,s1b,u0,z). unfold fst, snd.
   simpl app.
   entailer!.
   rewrite sepcon_comm.
   apply RAMIF_PLAIN.trans''.
   apply wand_sepcon_adjoint.
   forget (v::s1b++s2) as s3.
   unfold listrep; fold listrep; Exists u0; auto.
+ (* after the loop *)
   clear v s1' Heqs1.
   forward.
   forward.
   rewrite (proj1 H2 (eq_refl _)).
   Exists x.
   simpl app.
   clear.
   entailer!.
   unfold listrep at 3; fold listrep. Intros.
   pull_right (listrep sh (a :: s2) t -* listrep sh (s1 ++ s2) x).
   apply modus_ponens_wand'.
   unfold listrep at 2; fold listrep. Exists y; cancel.
Qed.

End Proof1.

Module Proof2.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. Intros; subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep; fold listrep. Intros; contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val,  EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists (@nil val) v s1' x u.  entailer!.
   unfold lseg. apply allp_right; intro. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1. subst s1.
   destruct s1b; unfold listrep; fold listrep. Intros; contradiction.
   Intros z.
   forward.
   forward.
   Exists (s1a++[a],v,s1b,u0,z). unfold fst, snd.
   rewrite !app_ass. simpl app.
   entailer!.
   unfold lseg.
   rewrite sepcon_comm.
   clear.
   apply RAMIF_Q.trans'' with (cons a).
   extensionality cts; simpl; rewrite app_ass; reflexivity.
   apply allp_right; intro. apply wand_sepcon_adjoint.
   unfold listrep at 2; fold listrep; Exists u0.  apply derives_refl.
 + (* after the loop *)
   forward. forward.
   Exists x. entailer!.
   destruct H3 as [? _]. specialize (H3 (eq_refl _)). subst s1b.
   unfold listrep at 1.  Intros. autorewrite with norm.  rewrite H0. rewrite app_ass. simpl app.
   unfold lseg.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply allp_sepcon1 | ]. apply allp_left with (a::s2).
   rewrite sepcon_comm.
   eapply derives_trans; [ | apply modus_ponens_wand].
   apply sepcon_derives; [ | apply derives_refl].
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof2.

Module Proof3.  (*************** inductive lseg *******************)

Fixpoint lseg (sh: share)
            (contents: list val) (x z: val) : mpred :=
 match contents with
 | h::hs => !! (x<>z) &&
              EX y:val,
                data_at sh t_struct_list (h,y) x * lseg sh hs y z
 | nil => !! (x = z /\ is_pointer_or_null x) && emp
 end.

Arguments lseg sh contents x z : simpl never.

Lemma lseg_local_facts:
  forall sh contents p q,
     lseg sh contents p q |--
     !! (is_pointer_or_null p /\ is_pointer_or_null q /\ (p=q <-> contents=nil)).
Proof.
intros.
apply derives_trans with (lseg sh contents p q && !! (is_pointer_or_null p /\
        is_pointer_or_null q /\ (p = q <-> contents = []))).
2: entailer!.
revert p; induction contents; intros; simpl; unfold lseg; fold lseg.
entailer!.
intuition.
Intros y. Exists y.
eapply derives_trans.
apply sepcon_derives.
apply derives_refl.
apply IHcontents.
entailer!.
intuition congruence.
Qed.

#[export] Hint Resolve lseg_local_facts : saturate_local.

Lemma lseg_valid_pointer:
  forall sh contents p ,
   sepalg.nonidentity sh ->
   lseg sh contents p nullval |-- valid_pointer p.
Proof.
 destruct contents; unfold lseg; fold lseg; intros. entailer!.
 Intros. Intros y.
 auto with valid_pointer.
Qed.

#[export] Hint Resolve lseg_valid_pointer : valid_pointer.

Lemma lseg_eq: forall sh contents x,
    lseg sh contents x x = !! (contents=nil /\ is_pointer_or_null x) && emp.
Proof.
intros.
destruct contents; unfold lseg; fold lseg.
f_equal. f_equal. f_equal. apply prop_ext; intuition.
apply pred_ext.
Intros y. contradiction.
Intros. discriminate.
Qed.

Lemma lseg_null: forall sh contents,
    lseg sh contents nullval nullval = !! (contents=nil) && emp.
Proof.
intros.
 rewrite lseg_eq.
 apply pred_ext.
 entailer!.
 entailer!.
Qed.

Lemma lseg_cons: forall sh (v u x: val) s,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * lseg sh s u nullval
 |-- lseg sh [v] x u * lseg sh s u nullval.
Proof.
intros.
     unfold lseg at 2. Exists u.
     entailer.
     destruct s; unfold lseg at 1; fold lseg; entailer.
Qed.

Lemma lseg_cons': forall sh (v u x a b: val) ,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * data_at sh t_struct_list (a,b) u
 |-- lseg sh [v] x u * data_at sh t_struct_list (a,b) u.
Proof.
intros.
     unfold lseg. Exists u.
     entailer.
Qed.

Lemma lseg_app': forall sh s1 s2 (a w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * data_at sh t_struct_list (a,z) y |--
   lseg sh (s1++s2) w y * data_at sh t_struct_list (a,z) y.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app_null: forall sh s1 s2 (w x: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x nullval |--
   lseg sh (s1++s2) w nullval.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app: forall sh s1 s2 a s3 (w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * lseg sh (a::s3) y z |--
   lseg sh (s1++s2) w y * lseg sh (a::s3) y z.
Proof.
 intros.
 unfold lseg at 3 5; fold lseg.
 Intros u; Exists u. rewrite prop_true_andp by auto.
 sep_apply (lseg_app' sh s1 s2 a w x y u); auto.
 cancel.
Qed.

Lemma listrep_lseg_null :
 listrep = fun sh s p => lseg sh s p nullval.
Proof.
extensionality sh s p.
revert p.
induction s; intros.
unfold lseg, listrep; apply pred_ext; entailer!.
unfold lseg, listrep; fold lseg; fold listrep.
apply pred_ext; Intros y; Exists y; rewrite IHs; entailer!.
Qed.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
revert POSTCONDITION; rewrite listrep_lseg_null; intro.
forward_if.
*
 subst x. rewrite lseg_null. Intros. subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold lseg at 1; fold lseg.
 Intros. contradiction H.
 Intros u.
 clear - SH.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val, EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   lseg sh s1b u nullval;
                   lseg sh s2 y nullval))%assert.
 + (* current assertion implies loop invariant *)
     Exists (@nil val) v s1' x u.
     subst s1. rewrite lseg_eq.
     entailer.
(*     sep_apply (lseg_cons sh v u x s1'); auto. *)
 + (* loop test is safe to execute *)
     entailer!.
 + (* loop body preserves invariant *)
    destruct s1b; unfold lseg at 2; fold lseg.
    Intros. contradiction.
    Intros z.
    forward.
    forward.
    Exists (s1a++a::nil, v0, s1b,u0,z). unfold fst, snd.
    simpl app; rewrite app_ass.
    entailer.
    sep_apply (lseg_cons' sh a u0 t v0 z); auto.
    sep_apply (lseg_app' sh s1a [a] v0 x t u0 z); auto.
    cancel.
 + (* after the loop *)
    clear v s1' Heqs1.
    subst. rewrite lseg_eq. Intros. subst.
    forward.
    forward.
    Exists x.
    entailer!.
    sep_apply (lseg_cons sh a y t s2); auto.
    sep_apply (lseg_app_null sh [a] s2 t y); auto.
    rewrite app_ass.
    sep_apply (lseg_app_null sh s1a ([a]++s2) x t); auto.
Qed.

End Proof3.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import LibEx.
Require Import ListEx.
Require Import Data.
Require Import Monad.

Require Import Params.
Require Import Nand.

(*  -------------------------------------------------------------

  Lemmas

*)

Lemma page_off_eq_dec :
  forall (loc loc' : page_off),
    loc = loc' \/ loc <> loc'.
Proof.
  intros.
  destruct (nat_eq_dec loc loc').
  left.
  subst;  trivial.
  right.
  intro HF; subst; trivial.
  apply n.
  trivial.
Qed.

Lemma pbn_eq_dec :
  forall (pbn pbn' : block_no),
    pbn = pbn' \/ pbn <> pbn'.
Proof.
  intros.
  destruct (nat_eq_dec pbn pbn').
  left.
  subst;  trivial.
  right.
  intro HF; subst; trivial.
  apply n.
  trivial.
Qed.

Lemma block_no_eq_dec :
  forall pbn pbn' : block_no, pbn = pbn' \/ pbn <> pbn'.
Proof.
  intros.
  destruct (nat_eq_dec pbn pbn'); auto.
Qed.

Lemma nand_erase_block_spec:
  forall c pbn b,
    bvalid_block_no pbn = true
    -> chip_get_block c pbn = Some b
    -> block_state b = bs_programmed
    -> exists c', nand_erase_block c pbn = Some c'
                  /\ chip_set_block c pbn (erased_block (block_erase_count b)) = Some c'
                  /\ chip_get_block c' pbn = Some (erased_block (block_erase_count b))
                  /\ (forall pbn', pbn <> pbn'
                                   -> chip_get_block c pbn' = chip_get_block c' pbn').
Proof.
  intros c pbn b.
  intros Hvb Hc Hbs.
  unfold chip_get_block in Hc.
  unfold nand_erase_block.
  rewrite Hvb.
  unfold chip_get_block.
  rewrite Hc.
  unfold chip_set_block.
  rewrite Hvb.
  destruct (list_get_list_set (l:=(chip_blocks c)) (erased_block (block_erase_count b)) Hc) as [l' Hset].
  rewrite Hset.
  exists (mkchip l').
  split; trivial.
  split; trivial.
  split.
    simpl.
    apply (list_get_list_set_eq Hset); auto.
  intros pbn' Hneq.
  simpl.
  rewrite (list_get_list_set_neq Hset Hneq).
  trivial.
Qed.

Lemma chip_set_block_elim :
  forall c pbn b c' ,
    chip_set_block c pbn b = Some c'
    -> bvalid_block_no pbn = true
       /\ chip_get_block c' pbn = Some b
       /\ forall pbn',
            pbn <> pbn'
            -> chip_get_block c' pbn' = chip_get_block c pbn'.
Proof.
  intros c pbn b c' Hsetc.
  split.
    unfold chip_set_block in Hsetc.
    destruct (bvalid_block_no pbn) eqn: Hvb; try discriminate.
    trivial.
  split.
    unfold chip_get_block.
    unfold chip_set_block in Hsetc.
    destruct (bvalid_block_no pbn) eqn: Hvb; try discriminate.
    destruct (list_set (chip_blocks c) pbn b) eqn: Hset; try discriminate.
    injection Hsetc.
    intro; subst c'.
    simpl.
    rewrite (list_get_list_set_eq Hset).
    trivial.
  intros pbn' H.
  unfold chip_get_block.
  unfold chip_set_block in Hsetc.
  destruct (bvalid_block_no pbn) eqn: Hvb; try discriminate.
  destruct (list_set (chip_blocks c) pbn b) eqn: Hset; try discriminate.
  injection Hsetc.
  intro; subst c'.
  simpl.
  rewrite (list_get_list_set_neq Hset H).
  trivial.
Qed.

Lemma nand_read_page_eq_in_same_block :
  forall c pbn off c',
    chip_get_block c pbn = chip_get_block c' pbn
    -> nand_read_page c pbn off = nand_read_page c' pbn off.
Proof.
  intros c pbn off c' Hc.
  unfold nand_read_page.
  destruct (bvalid_block_no pbn) eqn:Hpbn.
  rewrite <- Hc.
  trivial.
  trivial.
Qed.

Lemma invalid_off_implies_nand_read_page_none :
  forall c pbn loc,
    bvalid_page_off loc = false
    -> nand_read_page c pbn loc = None.
Proof.
  intros c pbn loc H.
  unfold nand_read_page.
  rewrite H.
  destruct (bvalid_block_no pbn); trivial.
  destruct (chip_get_block c pbn); trivial.
Qed.

Lemma nand_write_page_spec:
  forall c pbn off d o b p,
    bvalid_block_no pbn = true
    -> bvalid_page_off off = true
    -> chip_get_block c pbn = Some b
    -> block_get_page b off = Some p
    -> ble_nat (next_page b) off = true
    -> page_state p = ps_free
    -> exists c', nand_write_page c pbn off d o = Some c'
               /\ (exists b', chip_get_block c' pbn = Some b'
                              /\ next_page b' = S off
                              /\ block_erase_count b' = block_erase_count b
                              /\ block_state b' = bs_programmed
                              /\ (exists p', block_get_page b' off = Some p'
                                            /\ p' = mkpage d o ps_programmed)
                              /\ forall off',
                                   off' <> off
                                   -> bvalid_page_off off' = true
                                   -> block_get_page b' off' = block_get_page b off')
               /\ (forall pbn',
                     pbn' <> pbn
                     -> chip_get_block c pbn' = chip_get_block c' pbn').
Proof.
  intros c pbn off d o b p.
  intros Hvb Hvo Hc Hb Hnp Hps.
  unfold nand_write_page.
  rewrite Hvb.
  rewrite Hc.
  rewrite Hvo.
  rewrite Hnp.
  rewrite Hb.
  destruct (check_page_state_is_free (page_state p)) eqn:Hck.
  assert (exists b', block_set_page b off (mkpage d o ps_programmed) = Some b').
    unfold block_set_page.
    rewrite Hvo.
    unfold block_get_page in Hb.
    rewrite Hvo in Hb.
    destruct (list_get (block_pages b) off) eqn: Hgb; (try discriminate).
    injection Hb.
    intro; subst p0.
    destruct (list_get_list_set (mkpage d o ps_programmed) Hgb) as [b' Hsetb'].
    rewrite Hsetb'.
    eexists; eauto.
  destruct H as [b' Hb'].
  rewrite Hb'.
  unfold block_set_next_page.
  assert (exists c', chip_set_block c pbn
                                    (mkblock (block_pages b') (S off)
                                             (block_erase_count b') (block_state b')) = Some c').
    unfold chip_set_block.
    rewrite Hvb.
    unfold chip_get_block in Hc.
    destruct (list_get (chip_blocks c) pbn) eqn: Hgb; (try discriminate).
    injection Hc.
    intro; subst b0.
    destruct (list_get_list_set (mkblock (block_pages b') (S off)
                                             (block_erase_count b') (block_state b')) Hgb) as [c' Hsetc'].
    rewrite Hsetc'.
    eexists; eauto.
  destruct H as [c' Hc'].
  rewrite Hc'.
  exists c'.
  split; trivial.
  split.
    exists (mkblock (block_pages b') (S off)
                    (block_erase_count b') (block_state b')).
    split.
      unfold chip_get_block.
      unfold chip_set_block in Hc'.
      rewrite Hvb in Hc'.
      destruct (list_set (chip_blocks c) pbn (mkblock (block_pages b') (S off)
                    (block_erase_count b') (block_state b'))) eqn: Hset; try discriminate.
      injection Hc'; intro; subst c'.
      simpl.
      apply list_get_list_set_eq with (chip_blocks c); trivial.
    split.
      simpl.
      trivial.
    split.
      simpl.
      unfold block_set_page in Hb'.
      rewrite Hvo in Hb'.
      destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn: Hset; try discriminate.
      injection Hb'; intro; subst.
      simpl.
      trivial.
    split.
      simpl.
      unfold block_set_page in Hb'.
      rewrite Hvo in Hb'.
      destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn: Hset; try discriminate.
      injection Hb'; intro; subst.
      simpl.
      trivial.
    split.
      exists (mkpage d o ps_programmed).
      split; trivial.
      unfold block_get_page.
      rewrite Hvo.
      simpl.
      unfold block_set_page in Hb'.
      rewrite Hvo in Hb'.
      destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn: Hset; try discriminate.
      injection Hb'; intro; subst b'.
      simpl in * .
      rewrite (list_get_list_set_eq Hset).
      trivial.
    intros off' Hoff' Hvo'.
    unfold block_get_page.
    unfold block_set_page in Hb'.
    rewrite Hvo in Hb'.
    rewrite Hvo'.
    simpl.
    destruct (list_set (block_pages b) off (mkpage d o ps_programmed)) eqn:Hset; try discriminate.
    rewrite <- (list_get_list_set_neq Hset (neq_sym Hoff')).
    injection Hb'; intro; subst b'.
    simpl in * .
    trivial.
  intros pbn' Hneq.
  unfold chip_get_block.
  unfold chip_set_block in Hc'.
  rewrite Hvb in Hc'.
  destruct (list_set (chip_blocks c) pbn (mkblock (block_pages b') (S off)
                    (block_erase_count b') (block_state b'))) eqn:Hset; try discriminate.
  injection Hc'; intro; subst c'.
  simpl.
  rewrite (list_get_list_set_neq Hset (neq_sym Hneq)).
  trivial.

  unfold check_page_state_is_free in Hck.
  rewrite Hps in Hck.
  discriminate.
Qed.


Require Import VST.floyd.proofauto.
Require Import tree_copy.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive tree_card : Set :=
    | tree_card_0 : tree_card
    | tree_card_2 : tree_card -> tree_card -> tree_card.

Fixpoint tree (x: val) (s: (list Z)) (self_card: tree_card) {struct self_card} : mpred := match self_card with
    | tree_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | tree_card_2 _alpha_514 _alpha_513 =>
      EX v : Z,
      EX s2 : (list Z),
      EX r : val,
      EX s1 : (list Z),
      EX l : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null r) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = ((([(v : Z)] : list Z) ++ (s1 : list Z)) ++ (s2 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inl ((Vint (Int.repr v)) : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (tree (l : val) (s1 : list Z) (_alpha_513 : tree_card)) * (tree (r : val) (s2 : list Z) (_alpha_514 : tree_card))
end.

Inductive treeN_card : Set :=
    | treeN_card_0 : treeN_card
    | treeN_card_2 : treeN_card -> treeN_card -> treeN_card.

Fixpoint treeN (x: val) (n: Z) (self_card: treeN_card) {struct self_card} : mpred := match self_card with
    | treeN_card_0  =>  !!((x : val) = nullval) && !!((n : Z) = 0) && emp
    | treeN_card_2 _alpha_516 _alpha_515 =>
      EX n1 : Z,
      EX v : val,
      EX r : val,
      EX n2 : Z,
      EX l : val,
 !!(Int.min_signed <= n1 <= Int.max_signed) && !!(is_pointer_or_null v) && !!(is_pointer_or_null r) && !!(Int.min_signed <= n2 <= Int.max_signed) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!(0 <= (n1 : Z)) && !!(0 <= (n2 : Z)) && !!((n : Z) = ((1 + (n1 : Z)) + (n2 : Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inr (v : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (treeN (l : val) (n1 : Z) (_alpha_515 : treeN_card)) * (treeN (r : val) (n2 : Z) (_alpha_516 : treeN_card))
end.

Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: val) (s: (list Z)) (self_card: sll_card) {struct self_card} : mpred := match self_card with
    | sll_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | sll_card_1 _alpha_517 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_517 : sll_card))
end.

Definition tree_copy_spec :=
  DECLARE _tree_copy
   WITH r: val, x: val, s: (list Z), a: tree_card
   PRE [ (tptr (Tunion _sslval noattr)) ]
   PROP( is_pointer_or_null((r : val)); is_pointer_or_null((x : val)) )
   PARAMS(r)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x : val))] (r : val)); (tree (x : val) (s : list Z) (a : tree_card)))
   POST[ tvoid ]
   EX y: val,
   PROP( is_pointer_or_null((y : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (y : val))] (r : val)); (tree (x : val) (s : list Z) (a : tree_card)); (tree (y : val) (s : list Z) (a : tree_card))).

Lemma tree_x_valid_pointerP x s self_card: tree x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve tree_x_valid_pointerP : valid_pointer.
Lemma tree_local_factsP x s self_card :
  tree x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = tree_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_514 _alpha_513, self_card = tree_card_2 _alpha_514 _alpha_513))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve tree_local_factsP : saturate_local.
Lemma unfold_tree_card_0  (x: val) (s: (list Z)) : tree x s (tree_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_tree_card_2 (_alpha_514 : tree_card) (_alpha_513 : tree_card) (x: val) (s: (list Z)) : tree x s (tree_card_2 _alpha_514 _alpha_513) =
      EX v : Z,
      EX s2 : (list Z),
      EX r : val,
      EX s1 : (list Z),
      EX l : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null r) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = ((([(v : Z)] : list Z) ++ (s1 : list Z)) ++ (s2 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inl ((Vint (Int.repr v)) : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (tree (l : val) (s1 : list Z) (_alpha_513 : tree_card)) * (tree (r : val) (s2 : list Z) (_alpha_514 : tree_card)). Proof. auto. Qed.
Lemma treeN_x_valid_pointerP x n self_card: treeN x n self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve treeN_x_valid_pointerP : valid_pointer.
Lemma treeN_local_factsP x n self_card :
  treeN x n self_card|-- !!(((((x : val) = nullval)) -> (self_card = treeN_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_516 _alpha_515, self_card = treeN_card_2 _alpha_516 _alpha_515))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve treeN_local_factsP : saturate_local.
Lemma unfold_treeN_card_0  (x: val) (n: Z) : treeN x n (treeN_card_0 ) =  !!((x : val) = nullval) && !!((n : Z) = 0) && emp. Proof. auto. Qed.
Lemma unfold_treeN_card_2 (_alpha_516 : treeN_card) (_alpha_515 : treeN_card) (x: val) (n: Z) : treeN x n (treeN_card_2 _alpha_516 _alpha_515) =
      EX n1 : Z,
      EX v : val,
      EX r : val,
      EX n2 : Z,
      EX l : val,
 !!(Int.min_signed <= n1 <= Int.max_signed) && !!(is_pointer_or_null v) && !!(is_pointer_or_null r) && !!(Int.min_signed <= n2 <= Int.max_signed) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!(0 <= (n1 : Z)) && !!(0 <= (n2 : Z)) && !!((n : Z) = ((1 + (n1 : Z)) + (n2 : Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inr (v : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (treeN (l : val) (n1 : Z) (_alpha_515 : treeN_card)) * (treeN (r : val) (n2 : Z) (_alpha_516 : treeN_card)). Proof. auto. Qed.
Lemma sll_x_valid_pointerP x s self_card: sll x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve sll_x_valid_pointerP : valid_pointer.
Lemma sll_local_factsP x s self_card :
  sll x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = sll_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_517, self_card = sll_card_1 _alpha_517))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve sll_local_factsP : saturate_local.
Lemma unfold_sll_card_0  (x: val) (s: (list Z)) : sll x s (sll_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_sll_card_1 (_alpha_517 : sll_card) (x: val) (s: (list Z)) : sll x s (sll_card_1 _alpha_517) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_517 : sll_card)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [tree_copy_spec; malloc_spec]).

Lemma body_tree_copy : semax_body Vprog Gprog f_tree_copy tree_copy_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr r). { entailer!. }
try rename x into x2.
forward.
forward_if.

 - {
assert_PROP (a = tree_card_0) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card tree ssl_card_assert .
assert_PROP (((x2 : val) = nullval)). { entailer!. }
let ssl_var := fresh in assert_PROP(s = ([] : list Z)) as ssl_var; try rewrite ssl_var in *. { entailer!. }
forward; entailer!.
Exists nullval.
ssl_entailer.
rewrite (unfold_tree_card_0 ) at 1.
ssl_entailer.
rewrite (unfold_tree_card_0 ) at 1.
ssl_entailer.

}
 - {
assert_PROP (exists _alpha_514 _alpha_513, a = tree_card_2 _alpha_514 _alpha_513) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card tree ssl_card_assert _alpha_514x2 _alpha_513x2.
assert_PROP ((~ ((x2 : val) = nullval))). { entailer!. }
Intros vx2 s2x2 rx2 s1x2 lx2.
let ssl_var := fresh in assert_PROP(s = ((([(vx2 : Z)] : list Z) ++ (s1x2 : list Z)) ++ (s2x2 : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename vx2 into vx22.
forward.
try rename lx2 into lx22.
forward.
try rename rx2 into rx22.
forward.
forward.
assert_PROP(is_pointer_or_null((r : val))). { entailer!. }
assert_PROP(is_pointer_or_null((lx22 : val))). { entailer!. }
forward_call ((r : val), (lx22 : val), (s1x2 : list Z), (_alpha_513x2 : tree_card)).
Intros y1.
assert_PROP(is_pointer_or_null((lx22 : val))). { entailer!. }
assert_PROP(is_pointer_or_null((y1 : val))). { entailer!. }
try rename y1 into y12.
forward.
forward.
assert_PROP(is_pointer_or_null((r : val))). { entailer!. }
assert_PROP(is_pointer_or_null((rx22 : val))). { entailer!. }
forward_call ((r : val), (rx22 : val), (s2x2 : list Z), (_alpha_514x2 : tree_card)).
Intros y2.
assert_PROP(is_pointer_or_null((rx22 : val))). { entailer!. }
assert_PROP(is_pointer_or_null((y2 : val))). { entailer!. }
try rename y2 into y22.
forward.
forward_call (tarray (Tunion _sslval noattr) 3).
Intros y3.
assert_PROP (isptr y3). { entailer!. }
forward.
forward.
forward.
forward.
forward; entailer!.
Exists (y3 : val).
ssl_entailer.
rewrite (unfold_tree_card_2 (_alpha_514x2 : tree_card) (_alpha_513x2 : tree_card)) at 1.
Exists (vx22 : Z).
Exists (s2x2 : list Z).
Exists (rx22 : val).
Exists (s1x2 : list Z).
Exists (lx22 : val).
ssl_entailer.
rewrite (unfold_tree_card_2 (_alpha_514x2 : tree_card) (_alpha_513x2 : tree_card)) at 1.
Exists (vx22 : Z).
Exists (s2x2 : list Z).
Exists (y22 : val).
Exists (s1x2 : list Z).
Exists (y12 : val).
ssl_entailer.

}
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal2.

From lfind Require Import LFind.
Lemma lfind_state  (y:lst):@eq natural (len y) (len (append y Nil)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal2_theorem0_41_lem2/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (y:lst) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import oeuf.SafeInt.
Require Import oeuf.SafeDouble.

Require Import ZArith.

Require Import oeuf.MemInjProps.

Require Import StructTact.StructTactics.
Require Import oeuf.StuartTact.

Inductive opaque_type_name : Set :=
| Oint
| Odouble
.

Definition opaque_type_name_eq_dec (n1 n2 : opaque_type_name) :
        { n1 = n2 } + { n1 <> n2 }.
decide equality.
Defined.
Hint Resolve opaque_type_name_eq_dec : eq_dec.

Definition opaque_type_denote oty : Type :=
    match oty with
    | Oint => int
    | Odouble => float
    end.

Definition opaque_type_denote_eq_dec oty (x y : opaque_type_denote oty) :
        { x = y } + { x <> y }.
destruct oty; simpl in x, y.
- eapply Int.eq_dec.
- eapply Float.eq_dec.
Defined.

Record opaque_type_impl {oty} := MkOpaqueTypeImpl {
    ot_value_inject : opaque_type_denote oty -> val -> mem -> Prop;
    (* We may eventually need to split this into separate helper lemmas for
       value_val_inject and value_inject_mem_extends.  Currently we use a
       slightly weaker precondition in order to use a single helper lemma for
       both. *)
    ot_value_val_inject : forall mi m m' cv cv' ov,
        ot_value_inject ov cv m ->
        Val.inject mi cv cv' ->
        Mem.mem_inj mi m m' ->
        same_offsets mi ->
        ot_value_inject ov cv' m';
    ot_inject_defined : forall ov cv m,
        ot_value_inject ov cv m ->
        cv <> Vundef;
    ot_value_32bit : forall ov cv m,
        ot_value_inject ov cv m ->
        Val.load_result Mint32 cv = cv;
    (* ot_mem_inj : forall mi m m' cv ov, *)
    (*     ot_value_inject ov cv m -> *)
    (*     Mem.mem_inj mi m m' -> *)
    (*     (forall b, Mem.valid_block m b -> mi b <> None) -> *)
    (*     exists cv', *)
    (*         ot_value_inject ov cv' m' /\ *)
    (*         Val.inject mi cv cv'; *)
    ot_mem_inj_strict : forall mi m m' cv ov,
        ot_value_inject ov cv m ->
        Mem.mem_inj mi m m' ->
        (forall b, Mem.valid_block m b -> mi b = Some (b, 0%Z)) ->
        Val.inject mi cv cv;
    ot_ptr_block_valid : forall ov m b ofs,
        ot_value_inject ov (Vptr b ofs) m ->
        Mem.valid_block m b
}.

Implicit Arguments opaque_type_impl [].

Definition impl_int : opaque_type_impl Oint.
simple refine (MkOpaqueTypeImpl _  _  _ _ _ _ _).

- exact (fun ov cv m => cv = Vint ov).

- intros. simpl in *. on >Val.inject, invc; congruence.

- intros. simpl in *. congruence.

- intros. simpl in *. subst cv. reflexivity.

- intros. simpl in *. subst cv. eauto.

- intros. simpl in *. discriminate.
Defined.

Definition impl_double : opaque_type_impl Odouble.
  simple refine (MkOpaqueTypeImpl _ _ _ _ _ _ _).

  - intros ov cv m.
    exact (exists b,
              exists ofs,
                cv = Vptr b ofs /\
                Mem.load Mfloat64 m b (Int.unsigned ofs) = Some (Vfloat ov)).
  - intros. simpl in *.
    repeat break_exists.
    repeat break_and.
    on >Val.inject, invc;
      try congruence.
    inversion H6. subst.
    exists b2.
    unfold same_offsets in *.
    remember H4 as Hmi.
    clear HeqHmi.
    eapply H2 in H4. subst delta.
    eexists.
    split.
    reflexivity.
    eapply Mem.load_inj in H3; eauto.
    break_exists.
    break_and.
    inversion H0. subst.
    rewrite <- H.
    f_equal.
    rewrite Int.add_unsigned.
    fold Int.zero.
    rewrite Int.unsigned_zero.
    rewrite Int.unsigned_repr.
    reflexivity.
    rewrite Z.add_0_r.
    eapply Int.unsigned_range_2.

  - intros. simpl in H.
    repeat break_exists.
    repeat break_and.
    congruence.

  - intros. simpl in H.
    repeat break_exists.
    break_and.
    subst cv.

    reflexivity.

  - intros.
    simpl in H.
    repeat break_exists.
    break_and. subst cv.

    assert (Mem.valid_block m x).
    eapply Mem.valid_access_valid_block.
    eapply Mem.valid_access_implies.
    eapply Mem.load_valid_access; eauto.
    econstructor.

    eapply H1 in H.
    econstructor; eauto.
    unfold Int.add.
    rewrite Int.unsigned_repr.
    rewrite Z.add_0_r.
    rewrite Int.repr_unsigned.
    reflexivity.
    unfold Int.max_unsigned.
    unfold Int.modulus.
    simpl.
    omega.

  - intros.
    simpl in H.
    repeat break_exists.
    break_and.
    inversion H.
    subst.

    eapply Mem.valid_access_valid_block.
    eapply Mem.valid_access_implies.
    eapply Mem.load_valid_access; eauto.
    econstructor.
Defined.

Definition get_opaque_type_impl oty :=
    match oty with
    | Oint => impl_int
    | Odouble => impl_double
    end.

Section BY_NAME.
Local Set Implicit Arguments.

Variable oty : opaque_type_name.
Let impl := get_opaque_type_impl oty.

Definition opaque_type_value_inject := ot_value_inject impl.

Lemma opaque_type_value_val_inject : forall mi m m' cv cv' ov,
        opaque_type_value_inject ov cv m ->
        Val.inject mi cv cv' ->
        Mem.mem_inj mi m m' ->
        same_offsets mi ->
        opaque_type_value_inject ov cv' m'.
intros. unfold opaque_type_value_inject in *.
eapply (ot_value_val_inject impl); eauto.
Qed.

Lemma opaque_type_inject_defined : forall ov cv m,
        opaque_type_value_inject ov cv m ->
        cv <> Vundef.
intros. unfold opaque_type_value_inject in *.
eapply (ot_inject_defined impl); eauto.
Qed.

Lemma opaque_type_value_32bit : forall ov cv m,
        opaque_type_value_inject ov cv m ->
        Val.load_result Mint32 cv = cv.
intros. unfold opaque_type_value_inject in *.
eapply (ot_value_32bit impl); eauto.
Qed.

(* Lemma opaque_type_mem_inj : forall mi m m' cv ov, *)
(*     opaque_type_value_inject ov cv m -> *)
(*     Mem.mem_inj mi m m' -> *)
(*     (forall b, Mem.valid_block m b -> mi b <> None) -> *)
(*     exists cv', *)
(*         opaque_type_value_inject ov cv' m' /\ *)
(*         Val.inject mi cv cv'. *)
(* intros. unfold opaque_type_value_inject in *. *)
(* eapply (ot_mem_inj impl); eauto. *)
(* Qed. *)

Lemma opaque_type_mem_inj_strict : forall mi m m' cv ov,
    opaque_type_value_inject ov cv m ->
    Mem.mem_inj mi m m' ->
    (forall b, Mem.valid_block m b -> mi b = Some (b, 0%Z)) ->
    Val.inject mi cv cv.
intros. unfold opaque_type_value_inject in *.
eapply (ot_mem_inj_strict impl); eauto.
Qed.

Lemma opaque_type_ptr_block_valid : forall ov m b ofs,
    opaque_type_value_inject ov (Vptr b ofs) m ->
    Mem.valid_block m b.
intros. unfold opaque_type_value_inject in *.
eapply (ot_ptr_block_valid impl); eauto.
Qed.

End BY_NAME.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.Arith Coq.Vectors.Vector
     Coq.NArith.NArith.
Require Import Cava.Arrow.ArrowExport.

Require Import Aes.Pkg.

Import VectorNotations.
Import KappaNotation.
Open Scope kind_scope.

(* module aes_shift_rows (
  input  aes_pkg::ciph_op_e    op_i,
  input  logic [3:0][3:0][7:0] data_i,
  output logic [3:0][3:0][7:0] data_o
); *)
Definition aes_shift_rows
  : <<Bit, Vector (Vector (Vector Bit 8) 4) 4, Unit>> ~> Vector (Vector (Vector Bit 8) 4) 4 :=
  <[\op_i data_i =>
  (* // Row 0 is left untouched *)
  (* assign data_o[0] = data_i[0]; *)
    let data_o_0 = data_i[#0] in
  (* // Row 2 does not depend on op_i *)
  (* assign data_o[2] = aes_circ_byte_shift(data_i[2], 2'h2); *)
    let data_o_2 = !aes_circ_byte_shift data_i[#2] (#2) in

  (* // Row 1 *)
  (* assign data_o[1] = (op_i == CIPH_FWD) ? aes_circ_byte_shift(data_i[1], 2'h3) *)
  (*                                       : aes_circ_byte_shift(data_i[1], 2'h1); *)
    let data_o_1 =
      if op_i == !CIPH_FWD
      then !aes_circ_byte_shift data_i[#1] #3
      else !aes_circ_byte_shift data_i[#1] #1
      in
  (* // Row 3 *)
  (* assign data_o[3] = (op_i == CIPH_FWD) ? aes_circ_byte_shift(data_i[3], 2'h1) *)
  (*                                       : aes_circ_byte_shift(data_i[3], 2'h3); *)
    let data_o_3 =
      if op_i == !CIPH_FWD
      then !aes_circ_byte_shift data_i[#3] #1
      else !aes_circ_byte_shift data_i[#3] #3
      in
    data_o_0 :: data_o_1 :: data_o_2 :: data_o_3 :: []
  ]>.

Definition shift_rows_composed
:  << Vector _ 4, Unit>> ~> (Vector _ 4) :=
  <[\input =>
  let encoded = !aes_shift_rows !CIPH_FWD input in
  let decoded = !aes_shift_rows !CIPH_INV encoded in
  decoded ]>.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal17.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_2  := ( Nil).
Definition lfind_example_3  := ( Nil).
Definition lfind_example_4  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero Nil))).
Definition lfind_example_5  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_6  := ( Nil).
Definition lfind_example_7  := ( Nil).
Definition lfind_example_8  := ( Nil).
Definition lfind_example_9  := ( Cons (Succ Zero) Nil).
Definition lfind_example_10  := ( Nil).
Definition lfind_example_11  := ( Nil).
Definition lfind_example_12  := ( Nil).
Definition lfind_example_13  := ( Cons (Succ Zero) Nil).
Definition lfind_example_14  := ( Cons Zero Nil).
Definition lfind_example_15  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_16  := ( Nil).
Definition lfind_example_17  := ( Cons Zero Nil).
Definition lfind_example_18  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_19  := ( Cons Zero Nil).
Definition lfind_example_20  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_21  := ( Nil).
Definition lfind_example_22  := ( Cons (Succ Zero) Nil).
Definition lfind_example_23  := ( Cons (Succ (Succ Zero))         (Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) Nil)).
Definition lfind_example_24  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal17_theorem0_41_lem/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 .