Require Coq.Classes.EquivDec.
Require Coq.Lists.List.
Import List.ListNotations.
Require Import Coq.Program.Program.
Require Import Leapfrog.Syntax.
Require Import Leapfrog.FinType.
Require Import Leapfrog.Sum.
Require Import Leapfrog.Notations.

Require Import Leapfrog.BisimChecker.

Open Scope p4a.

Ltac prep_equiv :=
  unfold Equivalence.equiv, RelationClasses.complement in *;
  program_simpl; try congruence.

Obligation Tactic := prep_equiv.

Module TimestampRefKeepSingle.
  Inductive state :=
  | Start
  | ParseValue1
  | ParseValue2
  | ParseValue3
  | ParseValue4
  | ParseValue5
  | ParseValue6.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Typ
  | Len
  | Value
  | Scratch8
  | Scratch16
  | Scratch24
  | Scratch32
  | Scratch40.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition sz (h: header): nat :=
    match h with
    | Typ => 8
    | Len => 8
    | Value => 48
    | Scratch8 => 8
    | Scratch16 => 16
    | Scratch24 => 24
    | Scratch32 => 32
    | Scratch40 => 40
    end.

  Definition states (s: state) : Syntax.state state sz :=
    match s with
    | Start =>
      {| st_op :=
          extract(Typ) ;;
          extract(Len) ;
        st_trans := transition select (| EHdr Len |) {{
          [| exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
          [| exact #b|0|0|0|0|0|0|0|1 |] ==> inl ParseValue1 ;;;
          [| exact #b|0|0|0|0|0|0|1|0 |] ==> inl ParseValue2 ;;;
          [| exact #b|0|0|0|0|0|0|1|1 |] ==> inl ParseValue3 ;;;
          [| exact #b|0|0|0|0|0|1|0|0 |] ==> inl ParseValue4 ;;;
          [| exact #b|0|0|0|0|0|1|0|1 |] ==> inl ParseValue5 ;;;
          [| exact #b|0|0|0|0|0|1|1|0 |] ==> inl ParseValue6 ;;;
            reject
        }}
      |}
    | ParseValue1 =>
      {| st_op :=
          extract(Scratch8) ;;
          Value <- EConcat (m := 40) (EHdr Scratch8) ((@EHdr _ sz Value)[48--8])  ;
        st_trans := transition accept
      |}
    | ParseValue2 =>
      {| st_op :=
          extract(Scratch16) ;;
          Value <- EConcat (m := 32) (EHdr Scratch16) ((@EHdr _ sz Value)[48--16])  ;
        st_trans := transition accept
      |}
    | ParseValue3 =>
      {| st_op :=
          extract(Scratch24) ;;
          Value <- EConcat (m := 24) (EHdr Scratch24) ((@EHdr _ sz Value)[48--24])  ;
        st_trans := transition accept
      |}
    | ParseValue4 =>
      {| st_op :=
          extract(Scratch32) ;;
          Value <- EConcat (m := 16) (EHdr Scratch32) ((@EHdr _ sz Value)[48--32])  ;
        st_trans := transition accept
      |}
    | ParseValue5 =>
      {| st_op :=
          extract(Scratch40) ;;
          Value <- EConcat (m := 8) (EHdr Scratch40) ((@EHdr _ sz Value)[48--40])  ;
        st_trans := transition accept
      |}
    | ParseValue6 =>
      {| st_op := extract(Value) ;
        st_trans := transition accept
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampRefKeepSingle.

Module TimestampRefZeroSingle.
  Inductive state :=
  | Start
  | ParseValue1
  | ParseValue2
  | ParseValue3
  | ParseValue4
  | ParseValue5
  | ParseValue6.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Typ
  | Len
  | Value
  | Scratch8
  | Scratch16
  | Scratch24
  | Scratch32
  | Scratch40.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition sz (h: header): nat :=
    match h with
    | Typ => 8
    | Len => 8
    | Value => 48
    | Scratch8 => 8
    | Scratch16 => 16
    | Scratch24 => 24
    | Scratch32 => 32
    | Scratch40 => 40
    end.

  Definition states (s: state) :=
    match s with
    | Start =>
      {| st_op :=
          extract(Typ) ;;
          extract(Len) ;
        st_trans := transition select (| EHdr Len |) {{
          [| exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
          [| exact #b|0|0|0|0|0|0|0|1 |] ==> inl ParseValue1 ;;;
          [| exact #b|0|0|0|0|0|0|1|0 |] ==> inl ParseValue2 ;;;
          [| exact #b|0|0|0|0|0|0|1|1 |] ==> inl ParseValue3 ;;;
          [| exact #b|0|0|0|0|0|1|0|0 |] ==> inl ParseValue4 ;;;
          [| exact #b|0|0|0|0|0|1|0|1 |] ==> inl ParseValue5 ;;;
          [| exact #b|0|0|0|0|0|1|1|0 |] ==> inl ParseValue6 ;;;
            reject
        }}
      |}
    | ParseValue1 =>
      {| st_op :=
          extract(Scratch8) ;;
          Value <- EConcat (n := 8) (EHdr (Hdr_sz := sz) Scratch8) (ELit _ (Ntuple.n_tuple_repeat 40 false))  ;
        st_trans := transition accept
      |}
    | ParseValue2 =>
      {| st_op :=
          extract(Scratch16) ;;
          Value <- EConcat (n := 16) (EHdr (Hdr_sz := sz) Scratch16) (ELit _ (Ntuple.n_tuple_repeat 32 false))  ;
        st_trans := transition accept
      |}
    | ParseValue3 =>
      {| st_op :=
          extract(Scratch24) ;;
          Value <- EConcat (n := 24) (EHdr (Hdr_sz := sz) Scratch24) (ELit _ (Ntuple.n_tuple_repeat 24 false))  ;
        st_trans := transition accept
      |}
    | ParseValue4 =>
      {| st_op :=
          extract(Scratch32) ;;
          Value <- EConcat (n := 32) (EHdr (Hdr_sz := sz) Scratch32) (ELit _ (Ntuple.n_tuple_repeat 16 false))  ;
        st_trans := transition accept
      |}
    | ParseValue5 =>
      {| st_op :=
          extract(Scratch40) ;;
          Value <- EConcat (n := 40) (EHdr (Hdr_sz := sz) Scratch40) (ELit _ (Ntuple.n_tuple_repeat 8 false))  ;
        st_trans := transition accept
      |}
    | ParseValue6 =>
      {| st_op := extract(Value) ;
        st_trans := transition accept
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampRefZeroSingle.

Module TimestampSpecSingle.
  Inductive state :=
  | Start
  | ParseValue1
  | ParseValue2
  | ParseValue3
  | ParseValue4
  | ParseValue5
  | ParseValue6
  | ParseTimestamp.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Typ
  | Len
  | Scratch8
  | Scratch16
  | Scratch24
  | Scratch32
  | Scratch40
  | Scratch48
  | Pointer
  | Overflow
  | Flag
  | Timestamp.

  Definition sz (h: header): nat :=
    match h with
    | Typ => 8
    | Len => 8
    | Scratch8 => 8
    | Scratch16 => 16
    | Scratch24 => 24
    | Scratch32 => 32
    | Scratch40 => 40
    | Scratch48 => 48
    | Pointer => 8
    | Overflow => 4
    | Flag => 4
    | Timestamp => 32
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) : Syntax.state state sz :=
    match s with
    | Start =>
      {| st_op :=
          extract(Typ) ;;
          extract(Len) ;
        st_trans := transition select (| EHdr Typ, EHdr Len |) {{
          [| exact #b|0|1|0|0|0|1|0|0, exact #b|0|0|0|0|0|1|1|0 |] ==> inl ParseTimestamp ;;;
          [| *, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
          [| *, exact #b|0|0|0|0|0|0|0|1 |] ==> inl ParseValue1 ;;;
          [| *, exact #b|0|0|0|0|0|0|1|0 |] ==> inl ParseValue2 ;;;
          [| *, exact #b|0|0|0|0|0|0|1|1 |] ==> inl ParseValue3 ;;;
          [| *, exact #b|0|0|0|0|0|1|0|0 |] ==> inl ParseValue4 ;;;
          [| *, exact #b|0|0|0|0|0|1|0|1 |] ==> inl ParseValue5 ;;;
          [| *, exact #b|0|0|0|0|0|1|1|0 |] ==> inl ParseValue6 ;;;
            reject
        }}
      |}
    | ParseTimestamp =>
      {| st_op :=
          extract(Pointer) ;;
          extract(Overflow) ;;
          extract(Flag) ;;
          extract(Timestamp) ;
        st_trans := transition accept (* TODO: validate pointer and flag? *)
      |}
    | ParseValue1 =>
      {| st_op :=
          extract(Scratch8) ;
        st_trans := transition accept
      |}
    | ParseValue2 =>
      {| st_op :=
          extract(Scratch16) ;
        st_trans := transition accept
      |}
    | ParseValue3 =>
      {| st_op :=
          extract(Scratch24) ;
        st_trans := transition accept
      |}
    | ParseValue4 =>
      {| st_op :=
          extract(Scratch32) ;
        st_trans := transition accept
      |}
    | ParseValue5 =>
      {| st_op :=
          extract(Scratch40) ;
        st_trans := transition accept
      |}
    | ParseValue6 =>
      {| st_op := extract(Scratch48) ;
        st_trans := transition accept
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampSpecSingle.

Module TimestampRefSmall.
  Inductive state :=
  | Start
  | Parse1
  | Parse2
  | Parse3.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Len
  | Pref1
  | Pref2
  | Timestamps.

  Definition sz (h: header): nat :=
    match h with
    | Len => 2
    | Pref1 => 8
    | Pref2 => 16
    | Timestamps => 24
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) :=
    match s with
    | Start =>
      {| st_op :=
          extract(Len) ;
         st_trans := transition select (| EHdr Len |) {{
           [| exact #b|0|0 |] ==> accept ;;;
           [| exact #b|0|1 |] ==> inl Parse1 ;;;
           [| exact #b|1|0 |] ==> inl Parse2 ;;;
           [| exact #b|1|1 |] ==> inl Parse3 ;;;
            reject
         }}
      |}
    | Parse1 =>
      {| st_op :=
          extract(Pref1) ;;
          Timestamps <- EConcat (m := 16) (EHdr Pref1) ((EHdr (Hdr_sz := sz) Timestamps)[24--8])  ;
         st_trans := transition accept
      |}
    | Parse2 =>
      {| st_op :=
          extract(Pref2) ;;
          Timestamps <- EConcat (m := 8) (EHdr Pref2) ((EHdr (Hdr_sz := sz) Timestamps)[24--16]) ;
         st_trans := transition accept
      |}
    | Parse3 =>
      {| st_op := extract(Timestamps) ;
         st_trans := transition accept
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampRefSmall.

Module TimestampSpecSmall.
  Inductive state :=
  | Start
  | Parse1
  | Parse2
  | Parse3.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Len
  | T1
  | T2
  | T3.

  Definition sz (h: header): nat :=
    match h with
    | Len => 2
    | T1 | T2 | T3 => 8
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) : Syntax.state state sz :=
    match s with
    | Start =>
      {| st_op :=
          extract(Len) ;
         st_trans := transition select (| EHdr Len |) {{
           [| exact #b|0|0 |] ==> accept ;;;
           [| exact #b|0|1 |] ==> inl Parse1 ;;;
           [| exact #b|1|0 |] ==> inl Parse2 ;;;
           [| exact #b|1|1 |] ==> inl Parse3 ;;;
            reject
         }}
      |}
    | Parse1 =>
      {| st_op :=
          extract(T1) ;
         st_trans := transition accept
      |}
    | Parse2 =>
      {| st_op :=
          extract(T1) ;;
          extract(T2) ;
         st_trans := transition accept
      |}
    | Parse3 =>
      {| st_op :=
          extract(T1) ;;
          extract(T2) ;;
          extract(T3) ;
         st_trans := transition accept
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampSpecSmall.

(* parse 2 options of between 0-6 bytes, and if a timestamp option is present, parse it into a timestamp structure *)
Module TimestampSpec2.
  Inductive state :=
  | Parse0
  | Parse1

  | Parse0S
  | Parse1S

  | Parse01
  | Parse11

  | Parse02
  | Parse12

  | Parse03
  | Parse13

  | Parse04
  | Parse14

  | Parse05
  | Parse15

  | Parse06
  | Parse16.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Scratch8
  | Scratch16
  | Scratch24
  | Scratch32
  | Scratch40
  | T0
  | L0
  | V0
  | T1
  | L1
  | V1
  | Pointer
  | Overflow
  | Flag
  | Timestamp.

  Definition sz (h: header): nat :=
    match h with
    | Scratch8  => 8
    | Scratch16  => 16
    | Scratch24  => 24
    | Scratch32  => 32
    | Scratch40  => 40
    | T0  => 8
    | L0  => 8
    | V0  => 48
    | T1  => 8
    | L1  => 8
    | V1  => 48
    | Pointer  => 8
    | Overflow => 4
    | Flag => 4
    | Timestamp => 32
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) : Syntax.state state sz :=
    match s with
    | Parse0 =>
      {| st_op :=
          extract(T0) ;;
          extract(L0) ;
         st_trans := transition select (| EHdr (Hdr_sz := sz) T0, EHdr (Hdr_sz := sz) L0 |) {{
           [| exact #b|0|1|0|0|0|1|0|0, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse0S;;;
           [| exact #b|0|0|0|0|0|0|0|0, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| exact #b|0|0|0|0|0|0|0|1, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| *, exact #b|0|0|0|0|0|0|0|1 |] ==> inl Parse01 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|0 |] ==> inl Parse02 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|1 |] ==> inl Parse03 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|0 |] ==> inl Parse04 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|1 |] ==> inl Parse05 ;;;
           [| *, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse06 ;;;
            reject
         }}
      |}
    | Parse01 =>
      {| st_op :=
          extract(Scratch8) ;;
          V0 <- EConcat (m := 40) (EHdr (Hdr_sz := sz) Scratch8) ((EHdr (Hdr_sz := sz) V0)[48--8]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse02 =>
      {| st_op :=
          extract(Scratch16) ;;
          V0 <- EConcat (m := 32) (EHdr (Hdr_sz := sz) Scratch16) ((EHdr (Hdr_sz := sz) V0)[48--16]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse03 =>
      {| st_op :=
          extract(Scratch24) ;;
          V0 <- EConcat (m := 24) (EHdr (Hdr_sz := sz) Scratch24) ((EHdr (Hdr_sz := sz) V0)[48--24]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse04 =>
      {| st_op :=
          extract(Scratch32) ;;
          V0 <- EConcat (m := 16) (EHdr (Hdr_sz := sz) Scratch32) ((EHdr (Hdr_sz := sz) V0)[48--32]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse05 =>
      {| st_op :=
          extract(Scratch40) ;;
          V0 <- EConcat (m := 8) (EHdr (Hdr_sz := sz) Scratch40) ((EHdr (Hdr_sz := sz) V0)[48--40]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse06 =>
      {| st_op :=
          extract(V0) ;
         st_trans := transition inl Parse1;
      |}

    | Parse0S =>
      {| st_op :=
          extract(Pointer) ;;
          extract(Overflow) ;;
          extract(Flag) ;;
          extract(Timestamp) ;
        st_trans := transition inl Parse1 ;
      |}

    | Parse1 =>
      {| st_op :=
          extract(T1) ;;
          extract(L1) ;
         st_trans := transition select (| EHdr (Hdr_sz := sz) T1, EHdr (Hdr_sz := sz) L1 |) {{
           [| exact #b|0|1|0|0|0|1|0|0, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse1S;;;
           [| exact #b|0|0|0|0|0|0|0|0, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| exact #b|0|0|0|0|0|0|0|1, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| *, exact #b|0|0|0|0|0|0|0|1 |] ==> inl Parse11 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|0 |] ==> inl Parse12 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|1 |] ==> inl Parse13 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|0 |] ==> inl Parse14 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|1 |] ==> inl Parse15 ;;;
           [| *, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse16 ;;;
            reject
         }}
      |}
    | Parse11 =>
      {| st_op :=
          extract(Scratch8) ;;
          V1 <- EConcat (m := 40) (EHdr (Hdr_sz := sz) Scratch8) ((EHdr (Hdr_sz := sz) V1)[48--8]) ;
         st_trans := transition accept;
      |}
    | Parse12 =>
      {| st_op :=
          extract(Scratch16) ;;
          V1 <- EConcat (m := 32) (EHdr (Hdr_sz := sz) Scratch16) ((EHdr (Hdr_sz := sz) V1)[48--16]) ;
         st_trans := transition accept;
      |}
    | Parse13 =>
      {| st_op :=
          extract(Scratch24) ;;
          V1 <- EConcat (m := 24) (EHdr (Hdr_sz := sz) Scratch24) ((EHdr (Hdr_sz := sz) V1)[48--24]) ;
         st_trans := transition accept;
      |}
    | Parse14 =>
      {| st_op :=
          extract(Scratch32) ;;
          V1 <- EConcat (m := 16) (EHdr (Hdr_sz := sz) Scratch32) ((EHdr (Hdr_sz := sz) V1)[48--32]) ;
         st_trans := transition accept;
      |}
    | Parse15 =>
      {| st_op :=
          extract(Scratch40) ;;
          V1 <- EConcat (m := 8) (EHdr (Hdr_sz := sz) Scratch40) ((EHdr (Hdr_sz := sz) V1)[48--40]) ;
         st_trans := transition accept;
      |}
    | Parse16 =>
      {| st_op :=
          extract(V1) ;
         st_trans := transition accept;
      |}
    | Parse1S =>
      {| st_op :=
          extract(Pointer) ;;
          extract(Overflow) ;;
          extract(Flag) ;;
          extract(Timestamp) ;
        st_trans := transition accept ;
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampSpec2.

(* parse 3 options of between 0-6 bytes, and if a timestamp option is present, parse it into a timestamp structure *)
Module TimestampSpec3.
  Inductive state :=
  | Parse0
  | Parse1
  | Parse2

  | Parse0S
  | Parse1S
  | Parse2S

  | Parse01
  | Parse11
  | Parse21

  | Parse02
  | Parse12
  | Parse22

  | Parse03
  | Parse13
  | Parse23

  | Parse04
  | Parse14
  | Parse24

  | Parse05
  | Parse15
  | Parse25

  | Parse06
  | Parse16
  | Parse26.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | Scratch8
  | Scratch16
  | Scratch24
  | Scratch32
  | Scratch40
  | T0
  | L0
  | V0
  | T1
  | L1
  | V1
  | T2
  | L2
  | V2
  | Pointer
  | Overflow
  | Flag
  | Timestamp.

  Definition sz (h: header): nat :=
    match h with
    | Scratch8  => 8
    | Scratch16  => 16
    | Scratch24  => 24
    | Scratch32  => 32
    | Scratch40  => 40
    | T0  => 8
    | L0  => 8
    | V0  => 48
    | T1  => 8
    | L1  => 8
    | V1  => 48
    | T2  => 8
    | L2  => 8
    | V2  => 48
    | Pointer  => 8
    | Overflow => 4
    | Flag => 4
    | Timestamp => 32
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) : Syntax.state state sz :=
    match s with
    | Parse0 =>
      {| st_op :=
          extract(T0) ;;
          extract(L0) ;
         st_trans := transition select (| EHdr (Hdr_sz := sz) T0, EHdr (Hdr_sz := sz) L0 |) {{
           [| exact #b|0|1|0|0|0|1|0|0, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse0S;;;
           [| exact #b|0|0|0|0|0|0|0|0, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| exact #b|0|0|0|0|0|0|0|1, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| *, exact #b|0|0|0|0|0|0|0|1 |] ==> inl Parse01 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|0 |] ==> inl Parse02 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|1 |] ==> inl Parse03 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|0 |] ==> inl Parse04 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|1 |] ==> inl Parse05 ;;;
           [| *, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse06 ;;;
            reject
         }}
      |}
    | Parse01 =>
      {| st_op :=
          extract(Scratch8) ;;
          V0 <- EConcat (m := 40) (EHdr (Hdr_sz := sz) Scratch8) ((EHdr (Hdr_sz := sz) V0)[48--8]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse02 =>
      {| st_op :=
          extract(Scratch16) ;;
          V0 <- EConcat (m := 32) (EHdr (Hdr_sz := sz) Scratch16) ((EHdr (Hdr_sz := sz) V0)[48--16]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse03 =>
      {| st_op :=
          extract(Scratch24) ;;
          V0 <- EConcat (m := 24) (EHdr (Hdr_sz := sz) Scratch24) ((EHdr (Hdr_sz := sz) V0)[48--24]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse04 =>
      {| st_op :=
          extract(Scratch32) ;;
          V0 <- EConcat (m := 16) (EHdr (Hdr_sz := sz) Scratch32) ((EHdr (Hdr_sz := sz) V0)[48--32]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse05 =>
      {| st_op :=
          extract(Scratch40) ;;
          V0 <- EConcat (m := 8) (EHdr (Hdr_sz := sz) Scratch40) ((EHdr (Hdr_sz := sz) V0)[48--40]) ;
         st_trans := transition inl Parse1;
      |}
    | Parse06 =>
      {| st_op :=
          extract(V0) ;
         st_trans := transition inl Parse1;
      |}

    | Parse0S =>
      {| st_op :=
          extract(Pointer) ;;
          extract(Overflow) ;;
          extract(Flag) ;;
          extract(Timestamp) ;
        st_trans := transition inl Parse1 ;
      |}

    | Parse1 =>
      {| st_op :=
          extract(T1) ;;
          extract(L1) ;
         st_trans := transition select (| EHdr (Hdr_sz := sz) T1, EHdr (Hdr_sz := sz) L1 |) {{
           [| exact #b|0|1|0|0|0|1|0|0, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse1S;;;
           [| exact #b|0|0|0|0|0|0|0|0, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| exact #b|0|0|0|0|0|0|0|1, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| *, exact #b|0|0|0|0|0|0|0|1 |] ==> inl Parse11 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|0 |] ==> inl Parse12 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|1 |] ==> inl Parse13 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|0 |] ==> inl Parse14 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|1 |] ==> inl Parse15 ;;;
           [| *, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse16 ;;;
            reject
         }}
      |}
    | Parse11 =>
      {| st_op :=
          extract(Scratch8) ;;
          V1 <- EConcat (m := 40) (EHdr (Hdr_sz := sz) Scratch8) ((EHdr (Hdr_sz := sz) V1)[48--8]) ;
         st_trans := transition inl Parse2;
      |}
    | Parse12 =>
      {| st_op :=
          extract(Scratch16) ;;
          V1 <- EConcat (m := 32) (EHdr (Hdr_sz := sz) Scratch16) ((EHdr (Hdr_sz := sz) V1)[48--16]) ;
         st_trans := transition inl Parse2;
      |}
    | Parse13 =>
      {| st_op :=
          extract(Scratch24) ;;
          V1 <- EConcat (m := 24) (EHdr (Hdr_sz := sz) Scratch24) ((EHdr (Hdr_sz := sz) V1)[48--24]) ;
         st_trans := transition inl Parse2;
      |}
    | Parse14 =>
      {| st_op :=
          extract(Scratch32) ;;
          V1 <- EConcat (m := 16) (EHdr (Hdr_sz := sz) Scratch32) ((EHdr (Hdr_sz := sz) V1)[48--32]) ;
         st_trans := transition inl Parse2;
      |}
    | Parse15 =>
      {| st_op :=
          extract(Scratch40) ;;
          V1 <- EConcat (m := 8) (EHdr (Hdr_sz := sz) Scratch40) ((EHdr (Hdr_sz := sz) V1)[48--40]) ;
         st_trans := transition inl Parse2;
      |}
    | Parse16 =>
      {| st_op :=
          extract(V1) ;
         st_trans := transition inl Parse2;
      |}
    | Parse1S =>
      {| st_op :=
          extract(Pointer) ;;
          extract(Overflow) ;;
          extract(Flag) ;;
          extract(Timestamp) ;
        st_trans := transition inl Parse2 ;
      |}

    | Parse2 =>
      {| st_op :=
          extract(T2) ;;
          extract(L2) ;
         st_trans := transition select (| EHdr (Hdr_sz := sz) T2, EHdr (Hdr_sz := sz) L2 |) {{
           [| exact #b|0|1|0|0|0|1|0|0, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse2S;;;
           [| exact #b|0|0|0|0|0|0|0|0, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| exact #b|0|0|0|0|0|0|0|1, exact #b|0|0|0|0|0|0|0|0 |] ==> accept ;;;
           [| *, exact #b|0|0|0|0|0|0|0|1 |] ==> inl Parse21 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|0 |] ==> inl Parse22 ;;;
           [| *, exact #b|0|0|0|0|0|0|1|1 |] ==> inl Parse23 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|0 |] ==> inl Parse24 ;;;
           [| *, exact #b|0|0|0|0|0|1|0|1 |] ==> inl Parse25 ;;;
           [| *, exact #b|0|0|0|0|0|1|1|0 |] ==> inl Parse26 ;;;
            reject
         }}
      |}
    | Parse21 =>
      {| st_op :=
          extract(Scratch8) ;;
          V1 <- EConcat (m := 40) (EHdr (Hdr_sz := sz) Scratch8) ((EHdr (Hdr_sz := sz) V2)[48--8]) ;
         st_trans := transition accept;
      |}
    | Parse22 =>
      {| st_op :=
          extract(Scratch16) ;;
          V2 <- EConcat (m := 32) (EHdr (Hdr_sz := sz) Scratch16) ((EHdr (Hdr_sz := sz) V2)[48--16]) ;
         st_trans := transition accept;
      |}
    | Parse23 =>
      {| st_op :=
          extract(Scratch24) ;;
          V2 <- EConcat (m := 24) (EHdr (Hdr_sz := sz) Scratch24) ((EHdr (Hdr_sz := sz) V2)[48--24]) ;
         st_trans := transition accept;
      |}
    | Parse24 =>
      {| st_op :=
          extract(Scratch32) ;;
          V2 <- EConcat (m := 16) (EHdr (Hdr_sz := sz) Scratch32) ((EHdr (Hdr_sz := sz) V2)[48--32]) ;
         st_trans := transition accept;
      |}
    | Parse25 =>
      {| st_op :=
          extract(Scratch40) ;;
          V2 <- EConcat (m := 8) (EHdr (Hdr_sz := sz) Scratch40) ((EHdr (Hdr_sz := sz) V2)[48--40]) ;
         st_trans := transition accept;
      |}
    | Parse26 =>
      {| st_op :=
          extract(V2) ;
         st_trans := transition accept;
      |}
    | Parse2S =>
      {| st_op :=
          extract(Pointer) ;;
          extract(Overflow) ;;
          extract(Flag) ;;
          extract(Timestamp) ;
        st_trans := transition accept ;
      |}
    end.

  Program Definition aut: Syntax.t state sz :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End TimestampSpec3.


From Undecidability Require Import TM.Util.Prelim TM.Util.TM_facts.

(* * Mirror Operator *)

Section Mirror.
  Variable (n : nat) (sig : finType).

  Definition mirror_act : (option sig * move) -> (option sig * move) :=
    map_snd mirror_move.

  Definition mirror_acts : Vector.t (option sig * move) n -> Vector.t (option sig * move) n :=
    Vector.map mirror_act.

  Lemma mirror_act_involution a : mirror_act (mirror_act a) = a.
  Proof. destruct a. cbn. rewrite mirror_move_involution. reflexivity. Qed.

  Lemma mirror_acts_involution acts :
    mirror_acts (mirror_acts acts) = acts.
  Proof.
    unfold mirror_acts. apply Vector.eq_nth_iff. intros ? ? ->.
    erewrite !Vector.nth_map; eauto. apply mirror_act_involution.
  Qed.

  Variable F : finType.
  Variable pM : pTM sig F n.

  Definition Mirror_trans :
    state (projT1 pM) * Vector.t (option sig) n ->
    state (projT1 pM) *
    Vector.t (option sig * move) n :=
    fun qsym =>
      let (q', act) := trans qsym in
      (q', mirror_acts act).

  Definition MirrorTM : TM sig n :=
    {|
      trans := Mirror_trans;
      start := start (projT1 pM);
      halt := halt (m := projT1 pM);
    |}.

  Definition Mirror : pTM sig F n :=
    (MirrorTM; projT2 pM).

  Definition mirrorConf : mconfig sig (state (projT1 pM)) n -> mconfig sig (state (projT1 pM)) n :=
    fun c => mk_mconfig (cstate c) (mirror_tapes (ctapes c)).

  Lemma mirrorConf_involution c : mirrorConf (mirrorConf c) = c.
  Proof. destruct c as [q t]. unfold mirrorConf. cbn. f_equal. apply mirror_tapes_involution. Qed.

  Lemma mirrorConf_injective c1 c2 : mirrorConf c1 = mirrorConf c2 -> c1 = c2.
  Proof. destruct c1 as [q1 t1], c2 as [q2 t2]. unfold mirrorConf. cbn. intros H; inv H. f_equal. now apply mirror_tapes_injective. Qed.

  Lemma current_chars_mirror_tapes (t : tapes sig n) :
    current_chars (mirror_tapes t) = current_chars t.
  Proof. apply Vector.eq_nth_iff; intros i ? <-. autounfold with tape. now simpl_tape. Qed.

  Lemma doAct_mirror (t : tape sig) (act : option sig * move) :
    doAct (mirror_tape t) act = mirror_tape (doAct t (mirror_act act)).
  Proof. now destruct act as [ [ s | ] [ | | ]]; cbn; simpl_tape. Qed.

  Lemma doAct_mirror_multi (t : tapes sig n) (acts : Vector.t (option sig * move) n) :
    doAct_multi (mirror_tapes t) acts = mirror_tapes (doAct_multi t (mirror_acts acts)).
  Proof. apply Vector.eq_nth_iff; intros i ? <-. unfold doAct_multi, mirror_acts, mirror_tapes. simpl_tape. apply doAct_mirror. Qed.

  Lemma mirror_step c :
    step (M := projT1 pM) (mirrorConf c) = mirrorConf (step (M := projT1 Mirror) c).
  Proof.
    unfold step; cbn -[doAct_multi]. unfold Mirror_trans. cbn.
    destruct c as [q t]; cbn. rewrite current_chars_mirror_tapes.
    destruct (trans (q, current_chars t)) as [q' acts].
    unfold mirrorConf; cbn. f_equal. apply doAct_mirror_multi.
  Qed.

  Lemma mirror_lift k c1 c2 :
    loopM (M := projT1 Mirror)             c1  k = Some             c2 ->
    loopM (M := projT1 pM    ) (mirrorConf c1) k = Some (mirrorConf c2).
  Proof.
    unfold loopM. intros HLoop.
    apply loop_lift with (lift := mirrorConf) (f' := step (M:=projT1 pM)) (h' := haltConf (M:=projT1 pM)) in HLoop; auto.
    - intros ? _. now apply mirror_step.
  Qed.

  Lemma mirror_unlift k c1 c2 :
    loopM (M := projT1     pM) (mirrorConf c1) k = Some (mirrorConf c2) ->
    loopM (M := projT1 Mirror) (           c1) k = Some (           c2).
  Proof.
    unfold loopM. intros HLoop.
    apply loop_unlift with (lift := mirrorConf) (f := step (M:=MirrorTM)) (h := haltConf (M:=MirrorTM)) in HLoop
      as (? & HLoop & <- % mirrorConf_injective); auto.
    - intros ? _. now apply mirror_step.
  Qed.

  Definition Mirror_Rel (R : pRel sig F n) : pRel sig F n :=
    fun t '(l, t') => R (mirror_tapes t) (l, mirror_tapes t').

  Lemma Mirror_Realise R :
    pM ⊨ R -> Mirror ⊨ Mirror_Rel R.
  Proof.
    intros HRealise. intros t i outc HLoop.
    apply (HRealise (mirror_tapes t) i (mirrorConf outc)).
    now apply mirror_lift in HLoop.
  Qed.

  Definition Mirror_T (T : tRel sig n) : tRel sig n :=
    fun t k => T (mirror_tapes t) k.

  Lemma Mirror_Terminates T :
    projT1 pM ↓ T -> projT1 Mirror ↓ Mirror_T T.
  Proof.
    intros HTerm. hnf. intros t1 k H1. hnf in HTerm. specialize (HTerm (mirror_tapes t1) k H1) as (outc&H).
    exists (mirrorConf outc). apply mirror_unlift. cbn. now rewrite mirrorConf_involution.
  Qed.

  Lemma Mirror_RealiseIn R (k : nat) :
    pM ⊨c(k) R -> Mirror ⊨c(k) Mirror_Rel R.
  Proof.
    intros H.
    eapply Realise_total. split.
    - eapply Mirror_Realise. now eapply Realise_total.
    - eapply TerminatesIn_monotone.
      + eapply Mirror_Terminates. now eapply Realise_total.
      + firstorder.
  Qed.

End Mirror.

Arguments Mirror : simpl never.
Arguments Mirror_Rel { n sig F } R x y /.
Arguments Mirror_T { n sig } T x y /.

Ltac smpl_TM_Mirror :=
  once lazymatch goal with
  | [ |- Mirror _ ⊨ _ ] => eapply Mirror_Realise
  | [ |- Mirror _ ⊨c(_) _ ] => eapply Mirror_RealiseIn
  | [ |- projT1 (Mirror _) ↓ _ ] => eapply Mirror_Terminates
  end.

Smpl Add smpl_TM_Mirror : TM_Correct.


From Coq Require Import Arith ZArith OrderedType.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From nbits Require Import NBits.
From ssrlib Require Import Var Types SsrOrder Nats ZAriths Store FSets Tactics.
From BitBlasting Require Import Typ TypEnv State QFBV CNF BBCommon.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Conform .

  Fixpoint conform_exp (e : QFBV.exp) (s : SSAStore.t) (te : SSATE.env) : bool :=
    match e with
    | QFBV.Evar v => SSATE.vsize v te == size (SSAStore.acc v s)
    | QFBV.Econst _ => true
    | QFBV.Eunop op e => conform_exp e s te
    | QFBV.Ebinop op e1 e2 => conform_exp e1 s te && conform_exp e2 s te
    | QFBV.Eite b e1 e2 =>
      conform_bexp b s te && conform_exp e1 s te && conform_exp e2 s te
    end
  with
  conform_bexp (b : QFBV.bexp) (s : SSAStore.t) (te : SSATE.env) : bool :=
    match b with
    | QFBV.Bfalse
    | QFBV.Btrue => true
    | QFBV.Bbinop _ e1 e2 => conform_exp e1 s te && conform_exp e2 s te
    | QFBV.Blneg b => conform_bexp b s te
    | QFBV.Bconj b1 b2
    | QFBV.Bdisj b1 b2 => conform_bexp b1 s te && conform_bexp b2 s te
    end.

  (*
  Lemma conform_exp_upd x ty v s te :
    sizeof_typ ty = size v ->
    conform_exp (QFBV.Evar v) s te -> conform_exp (QFBV.Evar v) (SSAStore.upd x v s) (SSATE.add x ty te) .
  Proof.
    move=> Hs Hcon y. case Hyx: (y == x).
    - by rewrite (TypEnv.vsize_add_eq Hyx) (Store.acc_upd_eq Hyx).
    - move/idP/negP: Hyx => Hyx. rewrite (TypEnv.mem_add_neq Hyx) => Hmem.
      rewrite (Store.acc_upd_neq Hyx) (TypEnv.vsize_add_neq Hyx). exact: (Hcon _ Hmem).
  Qed.
   *)
  Lemma eval_conform_exp_size e te s :
    QFBV.well_formed_exp e te -> conform_exp e s te -> size (QFBV.eval_exp e s) = QFBV.exp_size e te.
  Proof .
    (* QFBV.exp *)
    elim e; rewrite /= .
    - move => v _ Hsize; rewrite (eqP Hsize) // .
    - done .
    - elim; rewrite /= .
      + move => e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) /invB size_map // .
      + move => e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) /negB /invB size_succB size_map // .
      + move => i j e0 _ _ _; rewrite size_extract // .
      + move => n e0 _ _ _; rewrite size_high // .
      + move => n e0 _ _ _; rewrite size_low // .
      + move => n e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) /zext size_cat size_zeros // .
      + move => n e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) /sext size_cat size_copy // .
      + move => n e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) size_repeat // .
      + move => n e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) size_rolB // .
      + move => n e0 IH Hwf Hcf .
        rewrite -(IH Hwf Hcf) size_rorB // .
    - elim; rewrite /=;
       move => e0 IH0 e1 IH1
                  /andP [/andP [/andP [Hwf0 Hwf1] Hszgt0] Hsize]
                  /andP [Hcf0 Hcf1] .
      + rewrite /andB size_lift (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1) (eqP Hsize) .
        reflexivity.
      + rewrite /orB size_lift (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1) (eqP Hsize) .
        reflexivity.
      + rewrite /xorB size_lift (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1) (eqP Hsize) .
        reflexivity.
      + rewrite size_addB (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1) (eqP Hsize) .
        reflexivity.
      + rewrite size_subB (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1) (eqP Hsize) .
        reflexivity.
      + rewrite size_mulB (IH0 Hwf0 Hcf0) . reflexivity.
      + rewrite size_udivB (IH0 Hwf0 Hcf0). reflexivity.
      + rewrite size_uremB (IH0 Hwf0 Hcf0). reflexivity.
      + rewrite size_sdivB (IH0 Hwf0 Hcf0). reflexivity.
      + rewrite size_sremB (IH0 Hwf0 Hcf0). reflexivity.
      + rewrite size_smodB_ss.
        * rewrite (IH0 Hwf0 Hcf0). reflexivity.
        * rewrite (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1). exact: (eqP Hsize).
      + rewrite shlBB_shlB size_shlB (IH0 Hwf0 Hcf0) . reflexivity.
      + rewrite shrBB_shrB size_shrB (IH0 Hwf0 Hcf0) . reflexivity.
      + rewrite sarBB_sarB size_sarB (IH0 Hwf0 Hcf0) . reflexivity.
      + rewrite size_cat (IH0 Hwf0 Hcf0) (IH1 Hwf1 Hcf1) addnC // .
      + reflexivity.
    - move => b e0 IH0 e1 IH1
                /andP [/andP [/andP [Hwfb Hwf0] Hwf1] Hsize]
                /andP [/andP [Hcfb Hcf0] Hcf1] .
      case (QFBV.eval_bexp b s) .
      * rewrite -(eqP Hsize) (IH0 Hwf0 Hcf0) maxnn. reflexivity.
      * rewrite (eqP Hsize) (IH1 Hwf1 Hcf1) maxnn. reflexivity.
  Qed .

  Fixpoint conform_bexps (bs : seq QFBV.bexp) s te : bool :=
    match bs with
    | [::] => true
    | b :: bs' => conform_bexp b s te && conform_bexps bs' s te
    end.

  Lemma conform_exp_mem E e s v :
    conform_exp e s E ->
    SSAVS.mem v (QFBV.vars_exp e) ->
    size (SSAStore.acc v s) = SSATE.vsize v E
  with conform_bexp_mem E e s v :
    conform_bexp e s E ->
    SSAVS.mem v (QFBV.vars_bexp e) ->
    size (SSAStore.acc v s) = SSATE.vsize v E.
  Proof.
    (* conform_exp_mem *)
    case: e => //=.
    - move=> x /eqP Hs Hmem. move: (SSAVS.Lemmas.mem_singleton1 Hmem) => Heq.
      rewrite (eqP Heq) Hs. reflexivity.
    - move=> _ e Hco Hmem. exact: (conform_exp_mem _ _ _ _ Hco Hmem).
    - move=> _ e1 e2 /andP [Hco1 Hco2]. rewrite SSAVS.Lemmas.mem_union.
      case/orP=> Hmem.
      + exact: (conform_exp_mem _ _ _ _ Hco1 Hmem).
      + exact: (conform_exp_mem _ _ _ _ Hco2 Hmem).
    - move=> b e1 e2 /andP [/andP [Hco_b Hco1] Hco2].
      rewrite !SSAVS.Lemmas.mem_union. (case/orP; last case/orP) => Hmem.
      + exact: (conform_bexp_mem _ _ _ _ Hco_b Hmem).
      + exact: (conform_exp_mem _ _ _ _ Hco1 Hmem).
      + exact: (conform_exp_mem _ _ _ _ Hco2 Hmem).
    (* conform_bexp_mem *)
    case: e => //=.
    - move=> _ e1 e2 /andP [Hco1 Hco2]. rewrite SSAVS.Lemmas.mem_union.
      case/orP=> Hmem.
      + exact: (conform_exp_mem _ _ _ _ Hco1 Hmem).
      + exact: (conform_exp_mem _ _ _ _ Hco2 Hmem).
    - move=> e Hco Hmem. exact: (conform_bexp_mem _ _ _ _ Hco Hmem).
    - move=> e1 e2 /andP [Hco1 Hco2]. rewrite SSAVS.Lemmas.mem_union.
      case/orP=> Hmem.
      + exact: (conform_bexp_mem _ _ _ _ Hco1 Hmem).
      + exact: (conform_bexp_mem _ _ _ _ Hco2 Hmem).
    - move=> e1 e2 /andP [Hco1 Hco2]. rewrite SSAVS.Lemmas.mem_union.
      case/orP=> Hmem.
      + exact: (conform_bexp_mem _ _ _ _ Hco1 Hmem).
      + exact: (conform_bexp_mem _ _ _ _ Hco2 Hmem).
  Qed.

End Conform .

Section Adhere .

  Definition adhere (m : vm) (te : SSATE.env) : Prop :=
    forall v, SSAVM.mem v m -> exists ls, SSAVM.find v m = Some ls /\
                                          SSATE.vsize v te == size ls .

End Adhere .

Section Bound .
  Fixpoint bound_exp e (vm : vm) : bool :=
    match e with
    | QFBV.Evar v => SSAVM.mem v vm
    | QFBV.Econst _ => true
    | QFBV.Eunop op e => bound_exp e vm
    | QFBV.Ebinop op e1 e2 => bound_exp e1 vm && bound_exp e2 vm
    | QFBV.Eite b e1 e2 =>
      bound_bexp b vm && bound_exp e1 vm && bound_exp e2 vm
    end
  with
  bound_bexp b vm : bool :=
    match b with
    | QFBV.Bfalse
    | QFBV.Btrue => true
    | QFBV.Bbinop _ e1 e2 => bound_exp e1 vm && bound_exp e2 vm
    | QFBV.Blneg b => bound_bexp b vm
    | QFBV.Bconj b1 b2
    | QFBV.Bdisj b1 b2 => bound_bexp b1 vm && bound_bexp b2 vm
    end.

  Lemma vm_preserve_bound_exp :
    forall e vm vm', bound_exp e vm -> vm_preserve vm vm' -> bound_exp e vm'
  with
  vm_preserve_bound_bexp :
    forall e vm vm', bound_bexp e vm -> vm_preserve vm vm' -> bound_bexp e vm' .
  Proof .
    (* vm_preserve_bound_exp *)
    elim; rewrite /= .
    - move => v vm vm' Hmem Hpsrv .
      elim : (SSAVM.Lemmas.mem_find_some Hmem) => ls Hfind .
      move : (Hpsrv v ls Hfind) .
      exact : SSAVM.Lemmas.find_some_mem .
    - done .
    - move => unop e IHe vm vm' He Hpsrv .
      exact : (IHe _ _ He Hpsrv) .
    - move => binop e0 IH0 e1 IH1 vm vm' /andP [He0 He1] Hpsrv .
      rewrite (IH0 _ _ He0 Hpsrv) (IH1 _ _ He1 Hpsrv) // .
    - move => c e0 IH0 e1 IH1 vm vm' /andP [/andP [Hc He0] He1] Hpsrv .
      rewrite (vm_preserve_bound_bexp c _ _ Hc Hpsrv)
              (IH0 _ _ He0 Hpsrv) (IH1 _ _ He1 Hpsrv) // .
    (* vm_preserve_bound_bexp *)
    elim; rewrite /= .
    - done .
    - done .
    - move => binop e0 e1 vm vm' /andP [He0 He1] Hpsrv .
      rewrite (vm_preserve_bound_exp e0 _ _ He0 Hpsrv)
              (vm_preserve_bound_exp e1 _ _ He1 Hpsrv) // .
    - move => b IHb; exact : IHb .
    - move => b0 IH0 b1 IH1 vm vm' /andP [Hb0 Hb1] Hpsrv .
      rewrite (IH0 _ _ Hb0 Hpsrv) (IH1 _ _ Hb1 Hpsrv) // .
    - move => b0 IH0 b1 IH1 vm vm' /andP [Hb0 Hb1] Hpsrv .
      rewrite (IH0 _ _ Hb0 Hpsrv) (IH1 _ _ Hb1 Hpsrv) // .
  Qed .

  Lemma consistent_conform_exp :
    forall e m te E s, bound_exp e m -> adhere m te ->
                       consistent m E s -> conform_exp e s te
  with
  consistent_conform_bexp :
    forall e m te E s, bound_bexp e m -> adhere m te ->
                       consistent m E s -> conform_bexp e s te.
  Proof .
    (* consistent_conform_exp *)
    elim; rewrite /= .
    - move => v m te E s Hmem Had Hcon.
      elim : (Had _ Hmem) => ls [Hfind Hsize] .
      rewrite (eqP Hsize).
      move: (Hcon v). rewrite /consistent1 Hfind => Henc.
      apply /eqP. exact: (enc_bits_size Henc).
    - done .
    - done .
    - elim => /= e0 IH0 e1 IH1 m te E s /andP [Hbnd0 Hbnd1] Had Hcon;
      rewrite (IH0 _ _ _ _ Hbnd0 Had Hcon) (IH1 _ _ _ _ Hbnd1 Had Hcon) // .
    - move => c e0 IH0 e1 IH1 m te E s
                /andP [/andP [Hbndc Hbnd0] Hbnd1] Had Hcon.
      rewrite (consistent_conform_bexp c _ _ _ _ Hbndc Had Hcon)
              (IH0 _ _ _ _ Hbnd0 Had Hcon) (IH1 _ _ _ _ Hbnd1 Had Hcon) // .
    (* consistent_conform_bexp *)
    elim; rewrite /= .
    - done .
    - done .
    - elim => e0 e1 m te E s /andP [Hbnd0 Hbnd1] Had Hcon;
      rewrite (consistent_conform_exp e0 _ _ _ _ Hbnd0 Had Hcon)
              (consistent_conform_exp e1 _ _ _ _ Hbnd1 Had Hcon) // .
    - done .
    - move => b0 IH0 b1 IH1 m te E s /andP [Hbnd0 Hbnd1] Had Hcon;
      rewrite (IH0 _ _ _ _ Hbnd0 Had Hcon) (IH1 _ _ _ _ Hbnd1 Had Hcon) // .
    - move => b0 IH0 b1 IH1 m te E s /andP [Hbnd0 Hbnd1] Had Hcon;
      rewrite (IH0 _ _ _ _ Hbnd0 Had Hcon) (IH1 _ _ _ _ Hbnd1 Had Hcon) // .
  Qed .

  Fixpoint bound_bexps (bs : seq QFBV.bexp) vm : bool :=
    match bs with
    | [::] => true
    | b :: bs' => bound_bexp b vm && bound_bexps bs' vm
    end.

  Lemma vm_preserve_bound_bexps :
    forall es m m', vm_preserve m m' -> bound_bexps es m -> bound_bexps es m'.
  Proof.
    elim.
    - move=> m m' Hpre. done.
    - move=> e es IHes m m' Hpre /= /andP [Hbdem Hbdesm].
      move: (vm_preserve_bound_bexp Hbdem Hpre) => Hbdem'.
      move: (IHes _ _ Hpre Hbdesm) => Hbdesm'.
        by rewrite Hbdem' Hbdesm'.
  Qed.

End Bound .


Require Import Coq.Lists.List. Import ListNotations.
From SyDPaCC.Bsml Require Import  Model.Core Model.Pid
     DataStructures.DistributedList
     DataStructures.DistributedVector
     Skeletons.StdLib Skeletons.MapReduce.
From SyDPaCC.Core Require Import Bmf Parallelization.
From SyDPaCC.Tree Require Import
     LTree Closure Support.NOption BTree VerticalComposition.
From SyDPaCC.Support Require Import Option UIP.

Generalizable All Variables.

Open Scope N_scope.
Open Scope sydpacc_scope.

  (** * Parallel Binary Trees and their Algorithmic Skeletons *)

Module Make (Import Bsml: Core.BSML).

  Typeclasses eauto := (bfs).

  Module Pid       := Pid.Make Bsml.Bsp.
  Module StdLib    := StdLib.Make Bsml Pid.
  Module Import ReplPar   := ReplicatedValue.C Bsml Pid.
  Module Import ParList   := DistributedList.C Bsml Pid.
  Module Import MapReduce := MapReduce.Make Bsml Pid StdLib ParList ReplPar.

  (** ** Parallel Linearized Binary Trees *)

  Definition PLTree A B :=
    { plt: par(list(segment A B)) | valid_tree(ParList.join plt) = true }.

  Program Definition join `(plt: PLTree A B) : LTree A B :=
    ParList.join plt.
  Next Obligation.
    now destruct plt.
  Qed.

  #[export] Instance tc_ltree_pltree A B : TypeCorr (@join A B).
  Proof.
    repeat constructor.
    intros [segs Hsegs]; simpl.
    assert(H: exists psegs, ParList.join psegs = segs)
      by apply surjective.
    destruct H as [psegs Hpsegs].
    assert(H: valid_tree(ParList.join psegs) = true)
      by (subst; auto).
    exists(exist _ psegs H).
    unfold join. subst. simpl.
    f_equal.
    apply UIP.Bool.UIP.
  Defined.

  #[export] Instance tc_btree_pltree A B :
    TypeCorr ( (@LTree.join A B) ∘ (@join A B) ).
  Proof. typeclasses eauto. Defined.

  (** ** Algorithmic Skeleetons on Parallel Linearized Binary Trees *)

  Section Skeletons.

    Definition map_par {A B C D} (kL:A->C) (kN:B->D) :
      par (list (segment A B)) -> par (list (segment C D)) :=
      Eval sydpacc in
      parallel (List.map (map_local kL kN)).

    Program Definition map {A B C D} (kL:A->C) (kN:B->D) :
      PLTree A B->PLTree C D :=
      (map_par kL kN) ∘ (@proj1_sig _ _ ).
    Next Obligation.
      autounfold with sydpacc. unfold valid_tree, map_par.
      erewrite @fun_corr with (fp:=MapReduce.par_map (map_local kL kN));
        eauto; try typeclasses eauto.
      destruct x as [ tree Htree ]. simpl proj1_sig.
      set(H:=valid_tree_map).
      specialize (H A B C D kL kN (ParList.join tree) Htree).
      now unfold valid_tree in H.
    Qed.

    #[export] Instance map_ltree_map_par A B C D (kL:A->C) (kN:B->D):
      FunCorr (LTree.map kL kN) (map kL kN).
    Proof.
      constructor. intros [plt Hplt] _.
      unfold map, map_par, join, LTree.map. autounfold with sydpacc; simpl.
      apply ltree_inj; simpl.
      now apply fun_corr.
    Defined.

    #[export] Instance map_tree_map_par `(kL:A->C) `(kN:B->D):
      FunCorr (BTree.map kL kN) (map kL kN).
    Proof.
      typeclasses eauto.
    Defined.

    Definition reduce_par {A B C} (k: (A * B * A) -> A)
               `{Hclose: @ClosureU A B C k phi psiN psiL psiR}
               (v:par(list(segment A B))) :
      option A :=
      let local : par (list (sum A C)) :=
          parfun (map_filter_some (reduce_local k phi psiL psiR))
                 v in
      let list : list (sum A C) := ParList.join local in
      reduce_global psiN list.

    Definition reduce {A B C} (k: (A * B * A) -> A)
               `{Hclose: @ClosureU A B C k phi psiN psiL psiR} :
      PLTree A B -> option A := (reduce_par k) ∘ (@proj1_sig _ _).

    (* Generalization of map correspondence, should be put in MapReduce: *)
    #[export] Instance parfun_corr `(f:list A->list B)
           `{H: Homomorphic _ _ f (@List.app _)} :
      FunCorr f (parfun f).
    Proof.
      constructor. intros ap _.
      unfold ParList.join.
      apply Pid.pids_ind.
      - simpl; autounfold with bsml.
        now autorewrite with bsml list.
      - intros n Hn IH; rewrite Pid.pid_up_to_succ.
        autorewrite with bsml; rewrite IH.
        autounfold with bsml; f_equal; simpl.
        autorewrite with bsml list.
        symmetry. apply homomorphic.
    Defined.

    #[export] Instance homorphic_map_filter_some `(f:A->option B) :
      Homomorphic (map_filter_some f) (@List.app _).
    Proof.
      constructor. intros.
      match goal with
      |[ |- ?x = ?y ] => assert(H: List.map Some x = List.map Some y)
      end.
      repeat( repeat rewrite map_app; repeat rewrite map_filter_some_prop).
      now rewrite filter_app.
      apply Pid.map_inj with (f:=Some); auto.
      intros a a' Heq. now inversion Heq.
    Defined.

    #[export] Instance reduce_ltree_reduce_par `(k:A*B*A->A)
             `{Hclose: @ClosureU A B C k phi psiN psiL psiR}:
      FunCorr (LTree.reduce k) (reduce k).
    Proof.
      repeat constructor. intros [plt Hplt] _.
      unfold reduce, reduce_par, LTree.reduce; autounfold with sydpacc.
      unfold reduce_segs.
      f_equal.
      eapply @fun_corr with (join_A:=@ParList.join (segment A B)); eauto.
      typeclasses eauto.
    Defined.

    #[export] Instance reduce_tree_reduce_par `(k:A*B*A->A)
           `{Hclose: @ClosureU A B C k phi psiN psiL psiR} :
      FunCorr (Some ∘ (BTree.reduce k)) (reduce k)(join_B:=(fun x=>x)∘(fun x=>x)).
    Proof. typeclasses eauto. Defined.

  End Skeletons.

End Make.

Close Scope sydpacc_scope.
Close Scope N_scope.