(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

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

(* This file provides simple bit-level parsing combinators for disassembling
 * Intel IA32 (x86) 32-bit binaries. *)
Require Coqlib.
Require Import Coq.Init.Logic.
Require Import Bool.
Require Import List.
Require Import String.
Require Import Maps.
Require Import Ascii.
Require Import ZArith.
Require Import Eqdep.
Require Import Parser.
Unset Automatic Introduction.
Set Implicit Arguments.
Local Open Scope Z_scope.

Require ExtrOcamlString.
Require ExtrOcamlNatBigInt.

(* a module for generating the parser for x86 instructions *)
Module X86_PARSER_ARG.
  Require Import X86Syntax.
  Require Import Bits.

  Definition char_p : Set := bool.
  Definition char_eq : forall (c1 c2:char_p), {c1=c2}+{c1<>c2} := bool_dec.
  Inductive type : Set :=
  | Int_t : type
  | Register_t : type
  | Byte_t : type
  | Half_t : type
  | Word_t : type
  | Scale_t : type
  | Condition_t : type
  | Operand_t : type
  | Instruction_t : type
  | Control_Register_t : type
  | Debug_Register_t : type
  | Segment_Register_t : type
  | Lock_or_Rep_t : type
  | Bool_t : type
  | Prefix_t : type
  | Option_t (t: type) : type
  (* Need pairs at this level if I want to have options of pairs*)
  | Pair_t (t1 t2: type) : type.

  Definition tipe := type.
  Definition tipe_eq : forall (t1 t2:tipe), {t1=t2} + {t1<>t2}.
    intros ; decide equality.
  Defined.

  Fixpoint tipe_m (t:tipe) :=
    match t with
      | Int_t => Z
      | Register_t => register
      | Byte_t => int8
      | Half_t => int16
      | Word_t => int32
      | Scale_t => scale
      | Condition_t => condition_type
      | Operand_t => operand
      | Instruction_t => instr
      | Control_Register_t => control_register
      | Debug_Register_t => debug_register
      | Segment_Register_t => segment_register
      | Lock_or_Rep_t => lock_or_rep
      | Bool_t => bool
      | Prefix_t => prefix
      | Option_t t => option (tipe_m t)
      | Pair_t t1 t2 => ((tipe_m t1) * (tipe_m t2))%type
    end.
End X86_PARSER_ARG.

Module X86_PARSER.
  Module X86_BASE_PARSER := Parser.Parser(X86_PARSER_ARG).
  Require Import X86Syntax.
  Require Import Bits.
  Import X86_PARSER_ARG.
  Import X86_BASE_PARSER.

  Definition option_t x := tipe_t (Option_t x).
  Definition int_t := tipe_t Int_t.
  Definition register_t := tipe_t Register_t.
  Definition byte_t := tipe_t Byte_t.
  Definition half_t := tipe_t Half_t.
  Definition word_t := tipe_t Word_t.
  Definition scale_t := tipe_t Scale_t.
  Definition condition_t := tipe_t Condition_t.
  Definition operand_t := tipe_t Operand_t.
  Definition instruction_t := tipe_t Instruction_t.
  Definition control_register_t := tipe_t Control_Register_t.
  Definition debug_register_t := tipe_t Debug_Register_t.
  Definition segment_register_t := tipe_t Segment_Register_t.
  Definition lock_or_rep_t := tipe_t Lock_or_Rep_t.
  Definition bool_t := tipe_t Bool_t.
  Definition prefix_t := tipe_t Prefix_t.
  (* combinators for building parsers *)
  Definition bit(x:bool) : parser char_t := Char_p x.
  Definition never t : parser t := Zero_p t.
  Definition always t (x:result_m t) : parser t := @Map_p unit_t t (fun (_:unit) => x) Eps_p.
  Definition alt t (p1 p2:parser t) : parser t := Alt_p p1 p2.
  Definition alts t (ps: list (parser t)) : parser t := List.fold_right (@alt t) (@never t) ps.
  Definition map t1 t2 (p:parser t1) (f:result_m t1 -> result_m t2) : parser t2 :=
    @Map_p t1 t2 f p.
  Implicit Arguments map [t1 t2].
  Definition seq t1 t2 (p1:parser t1) (p2:parser t2) : parser (pair_t t1 t2) := Cat_p p1 p2.
  Definition cons t (pair : result_m (pair_t t (list_t t))) : result_m (list_t t) :=
    (fst pair)::(snd pair).
  Definition seqs t (ps:list (parser t)) : parser (list_t t) :=
    List.fold_right (fun p1 p2 => map (seq p1 p2) (@cons t))
      (@always (list_t t) (@nil (result_m t))) ps.
  Fixpoint string_to_bool_list (s:string) : list bool :=
    match s with
      | EmptyString => nil
      | String a s =>
        (if ascii_dec a "0"%char then false else true)::(string_to_bool_list s)
    end.

  Fixpoint bits_n (n:nat) : result :=
    match n with
      | 0%nat => unit_t
      | S n => pair_t char_t (bits_n n)
    end.
  Fixpoint field'(n:nat) : parser (bits_n n) :=
    match n with
      | 0%nat => Eps_p
      | S n => Cat_p Any_p (field' n)
    end.
  Fixpoint bits2Z(n:nat)(a:Z) : result_m (bits_n n) -> result_m int_t :=
    match n with
      | 0%nat => fun _ => a
      | S n => fun p => bits2Z n (2*a + (if (fst p) then 1 else 0)) (snd p)
    end.
  Definition bits2int(n:nat)(bs:result_m (bits_n n)) : result_m int_t := bits2Z n 0 bs.
  Fixpoint bits (x:string) : parser (bits_n (String.length x)) :=
    match x with
      | EmptyString => Eps_p
      | String c s =>
        (Cat_p (Char_p (if ascii_dec c "0"%char then false else true)) (bits s))
    end.

  (* notation for building parsers *)
  Infix "|+|" := alt (right associativity, at level 80).
  Infix "$" := seq (right associativity, at level 70).
  Infix "@" := map (right associativity, at level 75).
  Notation "e %% t" := (e : result_m t) (at level 80).
  Definition bitsleft t (s:string)(p:parser t) : parser t :=
    bits s $ p @ (@snd _ _).
  Infix "$$" := bitsleft (right associativity, at level 70).

  Definition anybit : parser char_t := Any_p.
  Definition field(n:nat) := (field' n) @ (bits2int n).
  Definition reg := (field 3) @ (Z_to_register : _ -> result_m register_t).
  Definition byte := (field 8) @ (@Word.repr 7 : _ -> result_m byte_t).
 (* Definition halfword := (field 16) @ (@Word.repr 15 : _ -> result_m half_t).
  Definition word := (field 32) @ (@Word.repr 31 : _ -> result_m word_t). *)
  Definition halfword := (byte $ byte) @ ((fun p =>
      let b0 := Word.repr (Word.unsigned (fst p)) in
      let b1 := Word.repr (Word.unsigned (snd p)) in
        Word.or (Word.shl b1 (Word.repr 8)) b0): _ -> result_m half_t).
  Definition word := (byte $ byte $ byte $ byte) @
    ((fun p =>
        let b0 := zero_extend8_32 (fst p) in
        let b1 := zero_extend8_32 (fst (snd p)) in
        let b2 := zero_extend8_32 (fst (snd (snd p))) in
        let b3 := zero_extend8_32 (snd (snd (snd p))) in
         let w1 := Word.shl b1 (Word.repr 8) in
         let w2 := Word.shl b2 (Word.repr 16) in
         let w3 := Word.shl b3 (Word.repr 24) in
          Word.or w3 (Word.or w2 (Word.or w1 b0)))
    : _ -> result_m word_t).

  Definition scale_p := (field 2) @ (Z_to_scale : _ -> result_m scale_t).
  Definition tttn := (field 4) @ (Z_to_condition_type : _ -> result_m condition_t).

  (* This is used in a strange edge-case for modrm parsing. See the
     footnotes on p37 of the manual in the repo This is a case where I
     think intersections/complements would be nice operators *)

  (* JGM: we can handle this in the semantic action instead of the parser,
     so I replaced si, which used this and another pattern for [bits "100"]
     to the simpler case below -- helps to avoid some explosions in the
     definitions. *)
  Definition reg_no_esp : parser register_t :=
     (bits "000" |+| bits "001" |+| bits "010" |+|
     bits "011" |+| (* bits "100" <- this is esp *)  bits "101" |+|
     bits "110" |+| bits "111") @
       ((fun bs => Z_to_register (bits2int 3 bs)) : _ -> result_m register_t).

  Definition reg_no_ebp : parser register_t :=
     (bits "000" |+| bits "001" |+| bits "010" |+|
     bits "011" |+|  bits "100"  (* |+| bits "101" <- this is ebp *) |+|
     bits "110" |+| bits "111") @
       ((fun bs => Z_to_register (bits2int 3 bs)) : _ -> result_m register_t).

  Definition si :=
    (scale_p $ reg) @ (fun p => match snd p with
                                  | ESP => None
                                  | _ => Some p
                                end %% option_t (Pair_t Scale_t Register_t)).

  Definition sib := si $ reg.

  (* These next 4 parsers are used in the definition of the mod/rm parser *)
  Definition rm00 : parser operand_t :=
    (     bits "000"
      |+| bits "001"
      |+| bits "010"
      |+| bits "011"
      |+| bits "110"
      |+| bits "111" ) @
          (fun bs => Address_op (mkAddress (Word.repr 0)
            (Some (Z_to_register(bits2int 3 bs))) None) %% operand_t)
      |+| bits "100" $ si $ reg_no_ebp @
          (fun p => match p with
                      | (_,(si,base)) =>
                        Address_op (mkAddress (Word.repr 0)
                          (Some base) si)
                    end : result_m operand_t)
      |+| bits "100" $ si $ bits "101" $ word @
          (fun p => match p with
                      | (_,(si,(_, disp))) =>
                        Address_op (mkAddress disp
                          (None) si)
                    end : result_m operand_t)
      |+| bits "101" $ word @
          (fun p => match p with
                      | (_, disp) =>
                        Address_op (mkAddress disp None None)
                    end %% operand_t).

  Definition rm01 : parser operand_t :=
    ((    bits "000"
      |+| bits "001"
      |+| bits "010"
      |+| bits "011"
      |+| bits "101"
      |+| bits "110"
      |+| bits "111") $ byte) @
          (fun p =>
            match p with
              | (bs, disp) =>
                Address_op (mkAddress (sign_extend8_32 disp)
                  (Some (Z_to_register(bits2int 3 bs))) None)
            end %% operand_t)
      |+| bits "100" $ sib $ byte @
          (fun p =>
            match p with
              | (_,((si,base),disp)) =>
                Address_op (mkAddress (sign_extend8_32 disp) (Some base)
                  (si))
            end %% operand_t).

  Definition rm10 : parser operand_t :=
    ((    bits "000"
      |+| bits "001"
      |+| bits "010"
      |+| bits "011"
      |+| bits "101"
      |+| bits "110"
      |+| bits "111") $ word) @
          (fun p =>
            match p with
              | (bs, disp) =>
                Address_op (mkAddress disp (Some (Z_to_register(bits2int 3 bs))) None)
            end %% operand_t)
      |+|  bits "100" $ sib $ word @
          (fun p =>
            match p with
              | (_,((si,base),disp)) =>
                Address_op (mkAddress disp (Some base) si)
            end %% operand_t).

  Definition rm11 : parser operand_t := reg @ (fun x => Reg_op x : result_m operand_t).

  Definition modrm : parser (pair_t operand_t operand_t) :=
    (     (bits "00" $ reg $ rm00)
      |+| (bits "01" $ reg $ rm01)
      |+| (bits "10" $ reg $ rm10)
      |+| (bits "11" $ reg $ rm11) ) @
          (fun p => match p with
                      | (_, (r, op)) => (Reg_op r, op)
                    end %% (pair_t operand_t operand_t)).

  (* same as modrm but disallows the register case *)
  Definition modrm_noreg :=
  (     ("00" $$ reg $ rm00)
    |+| ("01" $$ reg $ rm01)
    |+| ("10" $$ reg $ rm10)).

  (* Similar to mod/rm parser except that the register field is fixed to a
   * particular bit-pattern, and the pattern starting with "11" is excluded. *)
  Definition ext_op_modrm(bs:string) : parser operand_t :=
    (      (bits "00" $ bits bs $ rm00)
     |+|   (bits "01" $ bits bs $ rm01)
     |+|   (bits "10" $ bits bs $ rm10) ) @
           (fun p => match p with
                       | (_,(_,op)) => op
                     end %% operand_t).

  Definition ext_op_modrm2(bs:string) : parser operand_t :=
    (      (bits "00" $ bits bs $ rm00)
     |+|   (bits "01" $ bits bs $ rm01)
     |+|   (bits "10" $ bits bs $ rm10)
     |+|   (bits "11" $ bits bs $ rm11) ) @
           (fun p => match p with
                       | (_,(_,op)) => op
                     end %% operand_t).

  (* Parsers for the individual instructions *)
  Definition AAA_p := bits "00110111" @ (fun _ => AAA %% instruction_t).
  Definition AAD_p := bits "1101010100001010" @ (fun _ => AAD %% instruction_t).
  Definition AAM_p := bits "1101010000001010" @ (fun _ => AAM %% instruction_t).
  Definition AAS_p := bits "00111111" @ (fun _ => AAS %% instruction_t).

  (* The parsing for ADC, ADD, AND, CMP, OR, SBB, SUB, and XOR can be shared *)

  Definition imm_op (opsize_override: bool) : parser operand_t :=
    match opsize_override with
      | false => word @ (fun w => Imm_op w %% operand_t)
      | true => halfword @ (fun w => Imm_op (sign_extend16_32 w) %% operand_t)
    end.

  Definition logic_or_arith_p (opsize_override: bool)
    (op1 : string) (* first 5 bits for most cases *)
    (op2 : string) (* when first 5 bits are 10000, the next byte has 3 bits
                      that determine the opcode *)
    (InstCon : bool->operand->operand->instr) (* instruction constructor *)
    : parser instruction_t
    :=
  (* register/memory to register and vice versa -- the d bit specifies
   * the direction. *)
  op1 $$ "0" $$ anybit $ anybit $ modrm @
    (fun p => match p with
                | (d, (w, (op1, op2))) =>
                  if d then InstCon w op1 op2 else InstCon w op2 op1
              end %% instruction_t)
  |+|
  (* sign extend immediate byte to register *)
  "1000" $$ "0011" $$ "11" $$ op2 $$ reg $ byte @
    (fun p =>
      let (r,imm) := p in InstCon true (Reg_op r) (Imm_op (sign_extend8_32 imm)) %%
    instruction_t)
  |+|
  (* zero-extend immediate byte to register *)
  "1000" $$ "0000" $$ "11" $$ op2 $$ reg $ byte @
    (fun p =>
      let (r,imm) := p in InstCon false (Reg_op r) (Imm_op (zero_extend8_32 imm)) %%
    instruction_t)
  |+|
  (* immediate word to register *)
  "1000" $$ "0001" $$ "11" $$ op2 $$ reg $ imm_op opsize_override @
    (fun p => let (r,imm) := p in InstCon true (Reg_op r) imm %% instruction_t)
  |+|
  (* zero-extend immediate byte to EAX *)
  op1 $$ "100" $$ byte @
    (fun imm => InstCon false (Reg_op EAX) (Imm_op (zero_extend8_32 imm)) %% instruction_t)
  |+|
  (* word to EAX *)
  op1 $$ "101" $$ imm_op opsize_override @
    (fun imm => InstCon true (Reg_op EAX)  imm %% instruction_t)
  |+|
  (* zero-extend immediate byte to memory *)
  "1000" $$ "0000" $$ ext_op_modrm op2 $ byte @
    (fun p => let (op,imm) := p in InstCon false op (Imm_op (zero_extend8_32 imm)) %%
    instruction_t)
  |+|
  (* sign-extend immediate byte to memory *)
  "1000" $$ "0011" $$ ext_op_modrm op2 $ byte @
    (fun p => let (op,imm) := p in InstCon true op (Imm_op (sign_extend8_32 imm)) %%
    instruction_t)
  |+|
  (* immediate word to memory *)
  "1000" $$ "0001" $$ ext_op_modrm op2 $ imm_op opsize_override @
    (fun p => let (op,imm) := p in InstCon true op imm %% instruction_t).

  Definition ADC_p s := logic_or_arith_p s "00010" "010" ADC.
  Definition ADD_p s := logic_or_arith_p s "00000" "000" ADD.
  Definition AND_p s := logic_or_arith_p s "00100" "100" AND.
  Definition CMP_p s := logic_or_arith_p s "00111" "111" CMP.
  Definition OR_p  s := logic_or_arith_p s "00001" "001" OR.
  Definition SBB_p s := logic_or_arith_p s "00011" "011" SBB.
  Definition SUB_p s := logic_or_arith_p s "00101" "101" SUB.
  Definition XOR_p s := logic_or_arith_p s "00110" "110" XOR.

  Definition ARPL_p :=
  "0110" $$ "0011" $$ modrm @
    (fun p => let (op1,op2) := p in ARPL op1 op2 %% instruction_t).

  Definition BOUND_p :=
  "0110" $$ "0010" $$ modrm @
    (fun p => let (op1,op2) := p in BOUND op1 op2 %% instruction_t).

  Definition BSF_p :=
  "0000" $$ "1111" $$ "1011" $$ "1100" $$ modrm @
    (fun p => let (op1,op2) := p in BSF op1 op2 %% instruction_t).

  Definition BSR_p :=
  "0000" $$ "1111" $$ "1011" $$ "1101" $$ modrm @
    (fun p => let (op1,op2) := p in BSR op1 op2 %% instruction_t).

  Definition BSWAP_p :=
  "0000" $$ "1111" $$ "1100" $$ "1" $$ reg @ (fun x => BSWAP x %% instruction_t).

  (* The various bit-testing operations can also share a parser *)
  Definition bit_test_p (opcode1:string) (opcode2:string)
    (Instr : operand -> operand -> instr) :=
    "0000" $$ "1111" $$ "1011" $$ "1010" $$ "11" $$ opcode1 $$ reg $ byte @
    (fun p =>
      let (r,imm) := p in Instr (Reg_op r) (Imm_op (zero_extend8_32 imm)) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "1011" $$ "1010" $$ ext_op_modrm opcode1 $ byte @
    (fun p =>
      let (op1,imm) := p in Instr op1 (Imm_op (zero_extend8_32 imm)) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "101" $$ opcode2 $$ "011" $$ modrm @
    (fun p => let (op2,op1) := p in Instr op1 op2 %% instruction_t).

  Definition BT_p := bit_test_p "100" "00" BT.
  Definition BTC_p := bit_test_p "111" "11" BTC.
  Definition BTR_p := bit_test_p "110" "10" BTR.
  Definition BTS_p := bit_test_p "101" "01" BTS.

  Definition CALL_p :=
    "1110" $$ "1000" $$ word  @
    (fun w => CALL true false (Imm_op w) None %% instruction_t)
  |+|
    "1111" $$ "1111" $$ ext_op_modrm2 "010" @
    (fun op => CALL true true op None %% instruction_t)
  |+|
    "1001" $$ "1010" $$ halfword $ word @
    (fun p => CALL false false (Imm_op (snd p)) (Some (fst p)) %% instruction_t)
  |+|
    "1111" $$ "1111" $$ ext_op_modrm2 "011" @
    (fun op => CALL false true op None %% instruction_t).

  Definition CDQ_p := "1001" $$ bits "1001" @ (fun _ => CDQ %% instruction_t).
  Definition CLC_p := "1111" $$ bits "1000" @ (fun _ => CLC %% instruction_t).
  Definition CLD_p := "1111" $$ bits "1100" @ (fun _ => CLD %% instruction_t).
  Definition CLI_p := "1111" $$ bits "1010" @ (fun _ => CLI %% instruction_t).
  Definition CLTS_p := "0000" $$ "1111" $$ "0000" $$ bits "0110" @
    (fun _ => CLTS %% instruction_t).
  Definition CMC_p := "1111" $$ bits "0101" @ (fun _ => CMC %% instruction_t).
  Definition CMPS_p := "1010" $$ "011" $$ anybit @ (fun x => CMPS x %% instruction_t).
  Definition CMPXCHG_p :=
   "0000" $$ "1111" $$ "1011" $$ "000" $$ anybit $ modrm @
    (fun p => match p with
                | (w,(op1,op2)) => CMPXCHG w op2 op1
              end %% instruction_t).

  Definition CPUID_p := "0000" $$ "1111" $$ "1010" $$ bits "0010" @
    (fun _ => CPUID %% instruction_t).
  Definition CWDE_p := "1001" $$ bits "1000" @ (fun _ => CWDE %% instruction_t).
  Definition DAA_p := "0010" $$ bits "0111" @ (fun _ => DAA %% instruction_t).
  Definition DAS_p := "0010" $$ bits "1111" @ (fun _ => DAS %% instruction_t).

  Definition DEC_p :=
    "1111" $$ "111" $$ anybit $ "11001" $$ reg @
      (fun p => let (w,r) := p in DEC w (Reg_op r) %% instruction_t)
  |+|
    "0100" $$ "1" $$ reg @
      (fun r => DEC true (Reg_op r) %% instruction_t)
  |+|
    "1111" $$ "111" $$ anybit $ ext_op_modrm "001" @
      (fun p => let (w,op1) := p in DEC w op1 %% instruction_t).

  Definition DIV_p :=
    "1111" $$ "011" $$ anybit $ "11110" $$ reg @
      (fun p => let (w,r) := p in DIV w (Reg_op r) %% instruction_t)
  |+|
    "1111" $$ "011" $$ anybit $ ext_op_modrm "110" @
      (fun p => let (w,op1) := p in DIV w op1 %% instruction_t).

  Definition HLT_p := "1111" $$ bits "0100" @ (fun _ => HLT %% instruction_t).

  Definition IDIV_p :=
    "1111" $$ "011" $$ anybit $ "11111" $$ reg @
    (fun p => let (w,r) := p in IDIV w (Reg_op r) %% instruction_t)
  |+|
    "1111" $$ "011" $$ anybit $ ext_op_modrm "111" @
     (fun p => let (w,op1) := p in IDIV w op1 %% instruction_t).

  Definition IMUL_p opsize_override :=
    "1111" $$ "011" $$ anybit $ ext_op_modrm2 "101" @
    (fun p => let (w,op1) := p in IMUL w op1 None None %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "1010" $$ "1111" $$ modrm @
    (fun p => let (op1,op2) := p in IMUL true op1 (Some op2) None %% instruction_t)
  |+|
    "0110" $$ "1011" $$ modrm $ byte @
    (fun p => match p with
                | ((op1,op2),imm) =>
                  IMUL true op1 (Some op2) (Some (sign_extend8_32 imm))
              end %% instruction_t)
  |+|
    match opsize_override with
      | false =>
          "0110" $$ "1001" $$ modrm $ word @
           (fun p => match p with
                | ((op1,op2),imm) =>
                  IMUL true op1 (Some op2) (Some imm)
              end  %% instruction_t)
      | true =>
          "0110" $$ "1001" $$ modrm $ halfword @
           (fun p => match p with
                | ((op1,op2),imm) =>
                  IMUL true op1 (Some op2) (Some (sign_extend16_32 imm))
              end  %% instruction_t)
    end.

  Definition IN_p :=
    "1110" $$ "010" $$ anybit $ byte @
    (fun p => let (w,pt) := p in IN w (Some pt) %% instruction_t)
  |+|
    "1110" $$ "110" $$ anybit @ (fun w => IN w None %% instruction_t).

  Definition INC_p :=
    "1111" $$ "111" $$ anybit  $ "11000" $$ reg @
      (fun p => let (w,r) := p in INC w (Reg_op r) %% instruction_t)
  |+|
    "0100" $$ "0" $$ reg @ (fun r => INC true (Reg_op r) %% instruction_t)
  |+|
    "1111" $$ "111" $$ anybit $ ext_op_modrm "000" @
       (fun p => let (w,op1) := p in INC w op1 %% instruction_t).

  Definition INS_p := "0110" $$ "110" $$ anybit @ (fun x => INS x %% instruction_t).

  Definition INTn_p := "1100" $$ "1101" $$ byte @ (fun x => INTn x %% instruction_t).
  Definition INT_p := "1100" $$ bits "1100" @ (fun _ => INT %% instruction_t).

  Definition INTO_p := "1100" $$ bits "1110" @ (fun _ => INTO %% instruction_t).
  Definition INVD_p := "0000" $$ "1111" $$ "0000" $$ bits "1000" @
    (fun _ => INVD %% instruction_t).

  Definition INVLPG_p :=
    "0000" $$ "1111" $$ "0000" $$ "0001" $$ ext_op_modrm "111" @
    (fun x => INVLPG x %% instruction_t).

  Definition IRET_p := "1100" $$ bits "1111" @ (fun _ => IRET %% instruction_t).

  Definition Jcc_p :=
    "0111" $$ tttn $ byte @
    (fun p => let (ct,imm) := p in Jcc ct (sign_extend8_32 imm) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "1000" $$ tttn $ word @
    (fun p => let (ct,imm) := p in Jcc ct imm %% instruction_t).

  Definition JCXZ_p := "1110" $$ "0011" $$ byte @ (fun x => JCXZ x %% instruction_t).

  Definition JMP_p :=
    "1110" $$ "1011" $$ byte @
    (fun b => JMP true false (Imm_op (sign_extend8_32 b)) None %% instruction_t)
  |+|
    "1110" $$ "1001" $$ word @
    (fun w => JMP true false (Imm_op w) None %% instruction_t)
  |+|
    "1111" $$ "1111" $$ ext_op_modrm2 "100" @
    (fun op => JMP true true op None %% instruction_t)
  |+|
    "1110" $$ "1010" $$ halfword $ word @
      (fun p => JMP false true (Imm_op (snd p)) (Some (fst p)) %% instruction_t)
  |+|
    "1111" $$ "1111" $$ ext_op_modrm2 "101" @
    (fun op => JMP false true op None %% instruction_t).

  Definition LAHF_p := "1001" $$ bits "1111" @ (fun _ => LAHF %% instruction_t).

  Definition LAR_p :=
    "0000" $$ "1111" $$ "0000" $$ "0010" $$ modrm @
      (fun p => LAR (fst p) (snd p) %% instruction_t).

  Definition LDS_p := "1100" $$ "0101" $$ modrm @
    (fun p => LDS (fst p) (snd p) %% instruction_t).
  Definition LEA_p := "1000" $$ "1101" $$ modrm_noreg @
    (fun p => LEA (Reg_op (fst p)) (snd p) %% instruction_t).
  Definition LEAVE_p := "1100" $$ bits "1001" @
    (fun _ => LEAVE %% instruction_t).
  Definition LES_p := "1100" $$ "0100" $$ modrm @
    (fun p => LES (fst p) (snd p) %% instruction_t).
  Definition LFS_p := "0000" $$ "1111" $$ "1011" $$ "0100" $$ modrm @
    (fun p => LFS (fst p) (snd p) %% instruction_t).
  Definition LGDT_p := "0000" $$ "1111" $$ "0000" $$ "0001" $$ ext_op_modrm "010" @
    (fun x => LGDT x %% instruction_t).
  Definition LGS_p := "0000" $$ "1111" $$ "1011" $$ "0101" $$ modrm @
    (fun p => LGS (fst p) (snd p) %% instruction_t).
  Definition LIDT_p := "0000" $$ "1111" $$ "0000" $$ "0001" $$ ext_op_modrm "011" @
    (fun x => LIDT x %% instruction_t).
  Definition LLDT_p :=
    "0000" $$ "1111" $$ "0000" $$ "0000" $$ "11" $$ "010" $$ reg @
    (fun r => LLDT (Reg_op r) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "0000" $$ "0000" $$ ext_op_modrm "010" @
    (fun x => LLDT x %% instruction_t).

  Definition LMSW_p :=
    "0000" $$ "1111" $$ "0000" $$ "0001" $$ "11" $$ "110" $$ reg @
      (fun r => LMSW (Reg_op r) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "0000" $$ "0001" $$ "11" $$ ext_op_modrm "110" @
      (fun x => LMSW x %% instruction_t).

  (* JGM: note, this isn't really an instruction, but rather a prefix.  So it
     shouldn't be included in the list of instruction parsers. *)
(*  Definition LOCK_p := "1111" $$ bits "0000" @ (fun _ => LOCK %% instruction_t). *)
  Definition LODS_p := "1010" $$ "110" $$ anybit @ (fun x => LODS x %% instruction_t).
  Definition LOOP_p := "1110" $$ "0010" $$ byte @ (fun x => LOOP x %% instruction_t).
  Definition LOOPZ_p := "1110" $$ "0001" $$ byte @ (fun x => LOOPZ x %% instruction_t).
  Definition LOOPNZ_p := "1110" $$ "0000" $$ byte @ (fun x => LOOPNZ x %% instruction_t).
  Definition LSL_p := "0000" $$ "1111" $$ "0000" $$ "0011" $$ modrm @
    (fun p => LSL (fst p) (snd p) %% instruction_t).
  Definition LSS_p := "0000" $$ "1111" $$ "1011" $$ "0010" $$ modrm @
    (fun p => LSS (fst p) (snd p) %% instruction_t).
  Definition LTR_p := "0000" $$ "1111" $$ "0000" $$ "0000" $$ ext_op_modrm "011" @
    (fun x => LTR x %% instruction_t).

  (* This is may not be right. Need to test this thoroughly.
     There is no 8bit mode for CMOVcc *)

  Definition CMOVcc_p :=
    "0000" $$ "1111" $$ "0100" $$ tttn $ modrm @
    (fun p => match p with | (tttn, (op1, op2))=>CMOVcc tttn op1 op2 end %% instruction_t).

  Definition MOV_p opsize_override :=
    "1000" $$ "101" $$ anybit $ modrm @
      (fun p => match p with | (w,(op1,op2)) => MOV w op1 op2 end %% instruction_t)
  |+|
    "1000" $$ "100" $$ anybit $ modrm @
      (fun p => match p with | (w,(op1,op2)) => MOV w op2 op1 end %% instruction_t)
  |+|
   "1100" $$ "0111" $$ "11" $$ "000" $$ reg $ imm_op opsize_override @
     (fun p => match p with | (r,w) => MOV true  (Reg_op r) w end %% instruction_t)
  |+|
   "1100" $$ "0110" $$ "11" $$ "000" $$ reg $ byte @
     (fun p => match p with
                 | (r,b) => MOV false (Reg_op r) (Imm_op (zero_extend8_32 b))
               end %% instruction_t)
  |+|
    "1011" $$ "1" $$ reg $ imm_op opsize_override @
      (fun p => match p with | (r,w) => MOV true (Reg_op r)  w
                end %% instruction_t)
  |+|
    "1011" $$ "0" $$ reg $ byte @
      (fun p => match p with
                  | (r,b) => MOV false (Reg_op r) (Imm_op (zero_extend8_32 b))
                end %% instruction_t)
  |+|
    "1100" $$ "0111" $$ ext_op_modrm "000" $ imm_op opsize_override @
      (fun p => match p with | (op,w) => MOV true op w end %% instruction_t)
  |+|
    "1100" $$ "0110" $$ ext_op_modrm "000" $ byte @
    (fun p => match p with | (op,b) => MOV false op (Imm_op (zero_extend8_32 b)) end %% instruction_t)
  |+|
    "1010" $$ "0001" $$ word @ (fun w => MOV true  (Reg_op EAX) (Offset_op w) %% instruction_t)
  |+|
    "1010" $$ "0000" $$ word @ (fun w => MOV false (Reg_op EAX) (Offset_op w)  %% instruction_t)
  |+|
    "1010" $$ "0011" $$ word @ (fun w => MOV true (Offset_op w) (Reg_op EAX) %% instruction_t)
  |+|
    "1010" $$ "0010" $$ word @ (fun w => MOV false (Offset_op w) (Reg_op EAX) %% instruction_t).

  Definition control_reg_p :=
      bits "000" @ (fun _ => CR0 %% control_register_t)
  |+| bits "010" @ (fun _ => CR2 %% control_register_t)
  |+| bits "011" @ (fun _ => CR3 %% control_register_t)
  |+| bits "100" @ (fun _ => CR4 %% control_register_t).

  Definition MOVCR_p :=
    "0000" $$ "1111" $$ "0010" $$ "0010" $$ "11" $$ control_reg_p $ reg @
    (fun p => MOVCR false (fst p) (snd p) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "0010" $$ "0000" $$ "11" $$ control_reg_p $ reg @
    (fun p => MOVCR true (fst p) (snd p) %% instruction_t).

  (* Note:  apparently, the bit patterns corresponding to DR4 and DR5 either
   * (a) get mapped to DR6 and DR7 respectively or else (b) cause a fault,
   * depending upon the value of some control register.  My guess is that it's
   * okay for us to just consider this a fault. Something similar seems to
   * happen with the CR registers above -- e.g., we don't have a CR1. *)
  Definition debug_reg_p :=
      bits "000" @ (fun _ => DR0 %% debug_register_t)
  |+| bits "001" @ (fun _ => DR1 %% debug_register_t)
  |+| bits "010" @ (fun _ => DR2 %% debug_register_t)
  |+| bits "011" @ (fun _ => DR3 %% debug_register_t)
  |+| bits "110" @ (fun _ => DR6 %% debug_register_t)
  |+| bits "111" @ (fun _ => DR7 %% debug_register_t).

  Definition MOVDR_p :=
    "0000" $$ "1111" $$ "0010" $$ "0011" $$ "11" $$ debug_reg_p $ reg @
    (fun p => MOVDR false (fst p) (snd p) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "0010" $$ "0001" $$ "11" $$ debug_reg_p $ reg @
    (fun p => MOVDR true (fst p) (snd p) %% instruction_t).

  Definition segment_reg_p :=
      bits "000" @ (fun _ => ES %% segment_register_t)
  |+| bits "001" @ (fun _ => CS %% segment_register_t)
  |+| bits "010" @ (fun _ => SS %% segment_register_t)
  |+| bits "011" @ (fun _ => DS %% segment_register_t)
  |+| bits "100" @ (fun _ => FS %% segment_register_t)
  |+| bits "101" @ (fun _ => GS %% segment_register_t).

  Definition seg_modrm : parser (pair_t segment_register_t operand_t) :=
        ("00" $$ segment_reg_p $ rm00)
    |+| ("01" $$ segment_reg_p $ rm01)
    |+| ("10" $$ segment_reg_p $ rm10)
    |+| ("11" $$ segment_reg_p $ rm11).

  Definition MOVSR_p :=
    "1000" $$ "1110" $$ seg_modrm @
      (fun p => MOVSR false (fst p) (snd p) %% instruction_t)
  |+|
    "1000" $$ "1100" $$ seg_modrm @
     (fun p => MOVSR true (fst p) (snd p) %% instruction_t).

  Definition MOVBE_p :=
    "0000" $$ "1111" $$ "0011" $$ "1000" $$ "1111" $$ "0000" $$ modrm @
    (fun p => MOVBE (snd p) (fst p) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "0011" $$ "1000" $$ "1111" $$ "0001" $$ modrm @
    (fun p => MOVBE (fst p) (snd p) %% instruction_t).

  Definition MOVS_p := "1010" $$ "010" $$ anybit @ (fun x => MOVS x %% instruction_t).

  Definition MOVSX_p := "0000" $$ "1111" $$ "1011" $$ "111" $$ anybit $ modrm @
    (fun p => match p with | (w,(op1,op2)) => MOVSX w op1 op2 end %% instruction_t).

  Definition MOVZX_p := "0000" $$ "1111" $$ "1011" $$ "011" $$ anybit $ modrm @
    (fun p => match p with | (w,(op1,op2)) => MOVZX w op1 op2 end %% instruction_t).

  Definition MUL_p :=
  "1111" $$ "011" $$ anybit $ ext_op_modrm2 "100" @
    (fun p => MUL (fst p) (snd p) %% instruction_t).

  Definition NEG_p :=
  "1111" $$ "011" $$ anybit $ ext_op_modrm2 "011" @
    (fun p => NEG (fst p) (snd p) %% instruction_t).

  (*
  Definition NOP_p :=
    "1001" $$ bits "0000" @ (fun _ => NOP None %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "0001" $$ "1111" $$ ext_op_modrm "000" @
    (fun op => NOP (Some op) %% instruction_t).
  *)

  Definition NOT_p :=
    "1111" $$ "011" $$ anybit $ ext_op_modrm2 "010" @
    (fun p => NOT (fst p) (snd p) %% instruction_t).

  Definition OUT_p :=
    "1110" $$ "011" $$ anybit $ byte @
      (fun p => OUT (fst p) (Some (snd p)) %% instruction_t)
  |+|
    "1110" $$ "111" $$ anybit @ (fun w => OUT w None %% instruction_t).

  Definition OUTS_p := "0110" $$ "111" $$ anybit @ (fun x => OUTS x %% instruction_t).

  Definition POP_p :=
  "1000" $$ "1111" $$ ext_op_modrm "000" @ (fun x => POP x %% instruction_t)
  |+|
    "0101" $$ "1" $$ reg @ (fun r => POP (Reg_op r) %% instruction_t).

  Definition POPSR_p :=
    "000" $$ "00" $$ bits "111" @ (fun _ => POPSR ES %% instruction_t)
  |+|
    "000" $$ "10" $$ bits "111" @ (fun _ => POPSR SS %% instruction_t)
  |+|
    "000" $$ "11" $$ bits "111" @ (fun _ => POPSR DS %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "10" $$ "100" $$ bits "001" @
      (fun _ => POPSR FS %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "10" $$ "101" $$ bits "001" @
      (fun _ => POPSR GS %% instruction_t).

  Definition POPA_p := "0110" $$ bits "0001" @ (fun _ => POPA %% instruction_t).
  Definition POPF_p := "1001" $$ bits "1101" @ (fun _ => POPF %% instruction_t).

  Definition PUSH_p :=
    "1111" $$ "1111" $$ ext_op_modrm "110" @ (fun x => PUSH true x %% instruction_t)
  |+|
    "0101" $$ "0" $$ reg @ (fun r => PUSH true (Reg_op r) %% instruction_t)
  |+|
    "0110" $$ "1010" $$ byte @
    (fun b => PUSH false (Imm_op (sign_extend8_32 b)) %% instruction_t)
  |+|
    "0110" $$ "1000" $$ word @ (fun w => PUSH true (Imm_op w) %% instruction_t).

  Definition segment_reg2_p :=
        bits "00" @ (fun _ => ES %% segment_register_t)
    |+| bits "01" @ (fun _ => CS %% segment_register_t)
    |+| bits "10" @ (fun _ => SS %% segment_register_t)
    |+| bits "11" @ (fun _ => DS %% segment_register_t).

  Definition PUSHSR_p :=
    "000" $$ segment_reg2_p $ bits "110" @
    (fun p => PUSHSR (fst p) %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "10" $$ "100" $$ bits "000" @
    (fun _ => PUSHSR FS %% instruction_t)
  |+|
    "0000" $$ "1111" $$ "10" $$ "101" $$ bits "000" @
    (fun _ => PUSHSR GS %% instruction_t).

  Definition PUSHA_p := "0110" $$ bits "0000" @ (fun _ => PUSHA %% instruction_t).
  Definition PUSHF_p := "1001" $$ bits "1100" @ (fun _ => PUSHF %% instruction_t).

  Definition rotate_p extop (inst : bool -> operand -> reg_or_immed -> instr) :=
    "1101" $$ "000" $$ anybit $ ext_op_modrm2 extop @
    (fun p => inst (fst p) (snd p) (Imm_ri (Word.repr 1)) %% instruction_t)
  |+|
    "1101" $$ "001" $$ anybit $ ext_op_modrm2 extop @
    (fun p => inst (fst p) (snd p) (Reg_ri ECX) %% instruction_t)
  |+|
    "1100" $$ "000" $$ anybit $ ext_op_modrm2 extop $ byte @
    (fun p => match p with | (w, (op,b)) => inst w op (Imm_ri b) end %% instruction_t).

  Definition RCL_p := rotate_p "010" RCL.
  Definition RCR_p := rotate_p "011" RCR.

  Definition RDMSR_p := "0000" $$ "1111" $$ "0011" $$ bits "0010" @
    (fun _ => RDMSR %% instruction_t).
  Definition RDPMC_p := "0000" $$ "1111" $$ "0011" $$ bits "0011" @
    (fun _ => RDPMC %% instruction_t).
  Definition RDTSC_p := "0000" $$ "1111" $$ "0011" $$ bits "0001" @
    (fun _ => RDTSC %% instruction_t).
  Definition RDTSCP_p := "0000" $$ "1111" $$ "0000" $$ "0001" $$ "1111" $$ bits "1001" @
    (fun _ => RDTSCP %% instruction_t).

  (*
  Definition REPINS_p := "1111" $$ "0011" $$ "0110" $$ "110" $$ anybit @
    (fun x => REPINS x %% instruction_t).
  Definition REPLODS_p := "1111" $$ "0011" $$ "1010" $$ "110" $$ anybit @
    (fun x => REPLODS x %% instruction_t).
  Definition REPMOVS_p := "1111" $$ "0011" $$ "1010" $$ "010" $$ anybit @
    (fun x => REPMOVS x %% instruction_t).
  Definition REPOUTS_p := "1111" $$ "0011" $$ "0110" $$ "111" $$ anybit @
    (fun x => REPOUTS x %% instruction_t).
  Definition REPSTOS_p := "1111" $$ "0011" $$ "1010" $$ "101" $$ anybit @
    (fun x => REPSTOS x %% instruction_t).
  Definition REPECMPS_p := "1111" $$ "0011" $$ "1010" $$ "011" $$ anybit @
    (fun x => REPECMPS x %% instruction_t).
  Definition REPESCAS_p := "1111" $$ "0011" $$ "1010" $$ "111" $$ anybit @
    (fun x => REPESCAS x %% instruction_t).
  Definition REPNECMPS_p := "1111" $$ "0010" $$ "1010" $$ "011" $$ anybit @
    (fun x => REPNECMPS x %% instruction_t).
  Definition REPNESCAS_p := "1111" $$ "0010" $$ "1010" $$ "111" $$ anybit @
    (fun x => REPNESCAS x %% instruction_t).
  *)

  Definition RET_p :=
    "1100" $$ bits "0011" @ (fun _ => RET true None %% instruction_t)
  |+|
    "1100" $$ "0010" $$ halfword @ (fun h => RET true (Some h) %% instruction_t)
  |+|
    "1100" $$ bits "1011" @ (fun _ => RET false None %% instruction_t)
  |+|
    "1100" $$ "1010" $$ halfword @ (fun h => RET false (Some h) %% instruction_t).

  Definition ROL_p := rotate_p "000" ROL.
  Definition ROR_p := rotate_p "001" ROR.
  Definition RSM_p := "0000" $$ "1111" $$ "1010" $$ bits "1010" @
    (fun _ => RSM %% instruction_t).
  Definition SAHF_p := "1001" $$ bits "1110" @
    (fun _ => SAHF %% instruction_t).
  Definition SAR_p := rotate_p "111" SAR.
  Definition SCAS_p := "1010" $$ "111" $$ anybit @ (fun x => SCAS x %% instruction_t).
  Definition SETcc_p :=
  "0000" $$ "1111" $$ "1001" $$ tttn $ modrm @
    (fun p => SETcc (fst p) (snd (snd p)) %% instruction_t).
  Definition SGDT_p := "0000" $$ "1111" $$ "0000" $$ "0001" $$ ext_op_modrm "000" @
    (fun x => SGDT x %% instruction_t).
  Definition SHL_p := rotate_p "100" SHL.

  Definition shiftdouble_p opcode inst :=
    ("0000" $$ "1111" $$ "1010" $$ opcode $$ "00" $$ "11" $$ reg $ reg $ byte) @
    (fun p => match p with | (r2,(r1,b)) => inst (Reg_op r1) r2 (Imm_ri b) end %% instruction_t)
  |+|
    ("0000" $$ "1111" $$ "1010" $$ opcode $$ "00" $$ modrm_noreg $ byte) @
    (fun p => match p with | ((r,op), b) => inst op r (Imm_ri b) end %% instruction_t)
  |+|
    ("0000" $$ "1111" $$ "1010" $$ opcode $$ "01" $$ "11" $$ reg $ reg) @
    (fun p => match p with | (r2,r1) => inst (Reg_op r1) r2 (Reg_ri ECX) end %% instruction_t)
  |+|
    ("0000" $$ "1111" $$ "1010" $$ opcode $$ "01" $$ modrm_noreg) @
    (fun p => match p with | (r,op) => inst op r (Reg_ri ECX) end %% instruction_t).

  Definition SHLD_p := shiftdouble_p "01" SHLD.
  Definition SHR_p := rotate_p "101" SHR.
  Definition SHRD_p := shiftdouble_p "11" SHRD.
  Definition SIDT_p := "0000" $$ "1111" $$ "0000" $$ "0001" $$ ext_op_modrm "001" @
    (fun x => SIDT x %% instruction_t).
  Definition SLDT_p := "0000" $$ "1111" $$ "0000" $$ "0000" $$ ext_op_modrm "000" @
    (fun x => SLDT x %% instruction_t).
  Definition SMSW_p := "0000" $$ "1111" $$ "0000" $$ "0001" $$ ext_op_modrm "100" @
    (fun x => SMSW x %% instruction_t).
  Definition STC_p := "1111" $$ bits "1001" @ (fun _ => STC %% instruction_t).
  Definition STD_p := "1111" $$ bits "1101" @ (fun _ => STD %% instruction_t).
  Definition STI_p := "1111" $$ bits "1011" @ (fun _ => STI %% instruction_t).
  Definition STOS_p := "1010" $$ "101" $$ anybit @
    (fun x => STOS x %% instruction_t).
  Definition STR_p := "0000" $$ "1111" $$ "0000" $$ "0000" $$ ext_op_modrm "001" @
    (fun x => STR x  %% instruction_t).

  Definition TEST_p (opsize_override: bool) :=
    "1111" $$ "0111" $$ ext_op_modrm2 "000" $ imm_op opsize_override @
    (fun p => TEST true (fst p) (snd p) %% instruction_t)
  |+|
    "1111" $$ "0110" $$ ext_op_modrm2 "000" $ byte @
    (fun p => TEST false (fst p) (Imm_op (zero_extend8_32 (snd p))) %% instruction_t)
  |+|
    "1000" $$ "010" $$ anybit $ modrm @
    (fun p => match p with | (w,(op1,op2)) => TEST w op1 op2 end %% instruction_t)
  |+|
    "1010" $$ "1001" $$ imm_op opsize_override @ (fun w => TEST true w (Reg_op EAX) %% instruction_t)
  |+|
    "1010" $$ "1000" $$ byte @
    (fun b => TEST true (Imm_op (zero_extend8_32 b)) (Reg_op EAX) %% instruction_t).

  Definition UD2_p := "0000" $$ "1111" $$ "0000" $$ bits "1011" @
    (fun _ => UD2 %% instruction_t).

  Definition VERR_p := "0000" $$ "1111" $$ "0000" $$ "0000" $$ ext_op_modrm "100" @
    (fun x => VERR x %% instruction_t).
  Definition VERW_p := "0000" $$ "1111" $$ "0000" $$ "0000" $$ ext_op_modrm "101" @
    (fun x => VERW x %% instruction_t).
  Definition WAIT_p := "1001" $$ bits "1011 " @ (fun _ => WAIT %% instruction_t).
  Definition WBINVD_p := "0000" $$ "1111" $$ "0000" $$ bits "1001" @
    (fun _ => WBINVD %% instruction_t).
  Definition WRMSR_p := "0000" $$ "1111" $$ "0011" $$ bits "0000" @
    (fun _ => WRMSR %% instruction_t).
  Definition XADD_p :=
    "0000" $$ "1111" $$ "1100" $$ "000" $$ anybit $ modrm @
    (fun p => match p with | (w,(op1,op2)) => XADD w op2 op1 end %% instruction_t).
  Definition XCHG_p :=
    "1000" $$ "011" $$ anybit $ modrm @
    (fun p => match p with | (w,(op1,op2)) => XCHG w op1 op2 end %% instruction_t)
  |+|
    "1001" $$ "0" $$ reg @ (fun r => XCHG true (Reg_op EAX) (Reg_op r) %% instruction_t).

  Definition XLAT_p := "1101" $$ bits "0111" @ (fun _ => XLAT %% instruction_t).

  (* Now glue all of the individual instruction parsers together into
     one big parser. *)

  Definition instr_parsers_opsize_pre : list (parser instruction_t) :=
    ADC_p true :: ADD_p true :: AND_p true :: CMP_p true :: OR_p true :: SBB_p true :: SUB_p true :: SHL_p :: SHLD_p :: SHR_p :: SAR_p :: SHRD_p :: XOR_p true ::IMUL_p true :: MOV_p true :: MOVSX_p :: MOVZX_p :: NEG_p :: NOT_p :: DIV_p :: IDIV_p :: TEST_p true :: CDQ_p :: CWDE_p :: MUL_p :: XCHG_p :: nil.

  Definition instr_parsers_nosize_pre : list (parser instruction_t) :=
    AAA_p :: AAD_p :: AAM_p :: AAS_p :: ADC_p false :: ADD_p false :: AND_p false :: CMP_p false :: OR_p false :: SBB_p false :: SUB_p false :: XOR_p false :: ARPL_p :: BOUND_p :: BSF_p :: BSR_p :: BSWAP_p :: BT_p :: BTC_p :: BTR_p :: BTS_p :: CALL_p :: CDQ_p :: CLC_p :: CLD_p :: CLI_p :: CMOVcc_p :: CMC_p :: CMPS_p :: CMPXCHG_p :: CPUID_p :: CWDE_p :: DAA_p :: DAS_p :: DEC_p :: DIV_p :: HLT_p :: IDIV_p :: IMUL_p false :: IN_p :: INC_p :: INS_p :: INTn_p :: INT_p :: INTO_p :: INVD_p :: INVLPG_p :: IRET_p :: Jcc_p :: JCXZ_p :: JMP_p :: LAHF_p :: LAR_p :: LDS_p :: LEA_p :: LEAVE_p :: LES_p :: LFS_p :: LGDT_p :: LGS_p :: LIDT_p :: LLDT_p :: LMSW_p :: (* LOCK_p :: -- see note above about LOCK_p *) LODS_p :: LOOP_p :: LOOPZ_p :: LOOPNZ_p :: LSL_p :: LSS_p :: LTR_p :: MOV_p false :: MOVCR_p :: MOVDR_p :: MOVSR_p :: MOVBE_p :: MOVS_p :: MOVSX_p :: MOVZX_p :: MUL_p :: NEG_p :: (* NOP_p :: *) NOT_p :: OUT_p :: OUTS_p :: POP_p :: POPSR_p :: POPA_p :: POPF_p :: PUSH_p :: PUSHSR_p :: PUSHA_p :: PUSHF_p :: RCL_p :: RCR_p :: RDMSR_p :: RDPMC_p :: RDTSC_p :: RDTSCP_p :: (* REPINS_p :: REPLODS_p :: REPMOVS_p :: REPOUTS_p :: REPSTOS_p :: REPECMPS_p :: REPESCAS_p :: REPNECMPS_p :: REPNESCAS_p :: *) RET_p :: ROL_p :: ROR_p :: RSM_p :: SAHF_p :: SAR_p :: SCAS_p :: SETcc_p :: SGDT_p :: SHL_p :: SHLD_p :: SHR_p :: SHRD_p :: SIDT_p :: SLDT_p :: SMSW_p :: STC_p :: STD_p :: STI_p :: STOS_p :: STR_p :: TEST_p false :: UD2_p :: VERR_p :: VERW_p :: WAIT_p :: WBINVD_p :: WRMSR_p :: XADD_p :: XCHG_p :: XLAT_p :: nil.

  Fixpoint list2pair_t (l: list result) :=
    match l with
      | nil => unit_t
      | r::r'::nil => pair_t r r'
      | r::l' => pair_t r (list2pair_t l')
    end.

  Definition lock_or_rep_p : parser lock_or_rep_t :=
    ("1111" $$ ( bits "0000" @ (fun _ => lock %% lock_or_rep_t)
                 |+| bits "0010" @ (fun _ => repn %% lock_or_rep_t)
                 |+| bits "0011" @ (fun _ => rep  %% lock_or_rep_t))).

  Definition segment_override_p : parser segment_register_t :=
  ("0010" $$ bits "1110" @ (fun _ => CS %% segment_register_t)
    |+| "0011" $$ bits "0110" @ (fun _ => SS %% segment_register_t)
    |+| "0011" $$ bits "1110" @ (fun _ => DS %% segment_register_t)
    |+| "0010" $$ bits "0110" @ (fun _ => ES %% segment_register_t)
    |+| "0110" $$ bits "0100" @ (fun _ => FS %% segment_register_t)
    |+| "0110" $$ bits "0101" @ (fun _ => GS %% segment_register_t)).

  Definition op_override_p : parser bool_t :=
    "0110" $$ bits "0110" @ (fun _ => true %% bool_t).
  Definition addr_override_p : parser bool_t :=
    "0110" $$ bits "0111" @ (fun _ => true %% bool_t).

  (* Ok, now I want all permutations of the above four parsers.
     I make a little perm2 combinator that takes two parsers and gives you
     p1 $ p2 |+| p2 $ p1, making sure to swap the results in the second case *)

  Definition perm2 t1 t2 (p1: parser t1) (p2: parser t2) : parser (pair_t t1 t2) :=
      p1 $ p2 |+|
      p2 $ p1 @ (fun p => match p with (a, b) => (b, a) %% pair_t t1 t2 end).

  (* Then I build that up into a perm3 and perm4. One could make a recursive
     function to do this, but I didn't want to bother with the necessary
     proofs and type-system juggling.*)

  Definition perm3 t1 t2 t3 (p1: parser t1) (p2: parser t2) (p3: parser t3)
    : parser (pair_t t1 (pair_t t2 t3)) :=
    let r_t := pair_t t1 (pair_t t2 t3) in
       p1 $ (perm2 p2 p3)
   |+| p2 $ (perm2 p1 p3) @ (fun p => match p with (b, (a, c)) => (a, (b, c)) %% r_t end)
   |+| p3 $ (perm2 p1 p2) @ (fun p => match p with (c, (a, b)) => (a, (b, c)) %% r_t end).

  Definition perm4 t1 t2 t3 t4 (p1: parser t1) (p2: parser t2) (p3: parser t3)
    (p4: parser t4) : parser (pair_t t1 (pair_t t2 (pair_t t3 t4))) :=
    let r_t := pair_t t1 (pair_t t2 (pair_t t3 t4)) in
       p1 $ (perm3 p2 p3 p4)
   |+| p2 $ (perm3 p1 p3 p4) @
         (fun p => match p with (b, (a, (c, d))) => (a, (b, (c, d))) %% r_t end)
   |+| p3 $ (perm3 p1 p2 p4) @
         (fun p => match p with (c, (a, (b, d))) => (a, (b, (c, d))) %% r_t end)
   |+| p4 $ (perm3 p1 p2 p3) @
         (fun p => match p with (d, (a, (b, c))) => (a, (b, (c, d))) %% r_t end).

  (* In this case, prefixes are optional. Before, each of the above
     parsing rules for the prefixes accepted Eps, and this was how we
     handled this.  However, if the parsers you join with perm can
     each accept Eps, then the result is a _highly_ ambiguous parser.

     Instead we have a different combinator, called option_perm, that
     handles this without introducing extra ambiguity *)

  (* This signature is slightly awkward - because there's no result
     type corresponding to option (and I'm hesitant to add it to
     Parser at the moment) we can't just have a signature like parser
     t1 -> parser t2 -> parser (option_t t1) (option_t t2)) *)

  Definition option_perm2 t1 t2 (p1: parser (tipe_t t1)) (p2: parser (tipe_t t2))
     : parser (pair_t (option_t t1) (option_t t2)) :=
     let r_t := pair_t (option_t t1) (option_t t2) in
         Eps_p @ (fun p => (None, None) %% r_t)
     |+| p1 @ (fun p => (Some p, None) %% r_t )
     |+| p2 @ (fun p => (None, Some p) %% r_t)
     |+| perm2 p1 p2 @ (fun p => match p with (a, b) => (Some a, Some b) %%r_t end).

  Definition option_perm3 t1 t2 t3 (p1:parser(tipe_t t1)) (p2:parser(tipe_t t2))
    (p3:parser(tipe_t t3)): parser(pair_t(option_t t1)(pair_t(option_t t2) (option_t t3)))
    :=
    let r_t := pair_t(option_t t1)(pair_t(option_t t2) (option_t t3))  in
        Eps_p @ (fun p => (None, (None, None)) %% r_t)
    |+| p1 @ (fun p => (Some p, (None, None)) %% r_t)
    |+| p2 @ (fun p => (None, (Some p, None)) %% r_t)
    |+| p3 @ (fun p => (None, (None, Some p)) %% r_t)
    |+| perm2 p1 p2 @(fun p => match p with (a, b) => (Some a, (Some b, None)) %%r_t end)
    |+| perm2 p1 p3 @(fun p => match p with (a, c) => (Some a, (None, Some c)) %%r_t end)
    |+| perm2 p2 p3 @(fun p => match p with (b, c) => (None, (Some b, Some c)) %%r_t end)
    |+| perm3 p1 p2 p3 @ (fun p => match p with (a, (b, c))
                                    => (Some a, (Some b, Some c)) %%r_t end).

  (* This is beginning to get quite nasty. Someone should write a form for arbitrary
     n and prove it's correct :) *)
  Definition option_perm4 t1 t2 t3 t4 (p1:parser(tipe_t t1)) (p2: parser(tipe_t t2))
    (p3: parser(tipe_t t3)) (p4: parser(tipe_t t4)) :
      parser(pair_t(option_t t1) (pair_t(option_t t2) (pair_t(option_t t3) (option_t t4))))
      :=
    let r_t := pair_t(option_t t1) (pair_t(option_t t2)
      (pair_t(option_t t3)(option_t t4))) in
        Eps_p @ (fun p => (None, (None, (None, None))) %% r_t)
    |+| p1 @ (fun p => (Some p, (None, (None, None))) %% r_t)
    |+| p2 @ (fun p => (None, (Some p, (None, None))) %% r_t)
    |+| p3 @ (fun p => (None, (None, (Some p, None))) %% r_t)
    |+| p4 @ (fun p => (None, (None, (None, Some p))) %% r_t)
    |+| perm2 p1 p2 @ (fun p => match p with (a, b)
                                  => (Some a, (Some b, (None, None))) %% r_t end)
    |+| perm2 p1 p3 @ (fun p => match p with (a, c)
                                  => (Some a, (None, (Some c, None))) %% r_t end)
    |+| perm2 p1 p4 @ (fun p => match p with (a, d)
                                  => (Some a, (None, (None, Some d))) %% r_t end)
    |+| perm2 p2 p3 @ (fun p => match p with (b, c)
                                  => (None, (Some b, (Some c, None))) %% r_t end)
    |+| perm2 p2 p4 @ (fun p => match p with (b, d)
                                  => (None, (Some b, (None, Some d))) %% r_t end)
    |+| perm2 p3 p4 @ (fun p => match p with (c, d)
                                  => (None, (None, (Some c, Some d))) %% r_t end)
    |+| perm3 p1 p2 p3 @ (fun p => match p with (a, (b, c))
                                    => (Some a, (Some b, (Some c, None))) %%r_t end)
    |+| perm3 p1 p3 p4 @ (fun p => match p with (a, (c, d))
                                    => (Some a, (None, (Some c, Some d))) %%r_t end)
    |+| perm3 p1 p2 p4 @ (fun p => match p with (a, (b, d))
                                    => (Some a, (Some b, (None, Some d))) %%r_t end)
    |+| perm3 p2 p3 p4 @ (fun p => match p with (b, (c, d))
                                    => (None, (Some b, (Some c, Some d))) %%r_t end)
    |+| perm4 p1 p2 p3 p4 @ (fun p => match p with (a, (b, (c, d)))
                                        => (Some a, (Some b, (Some c, Some d))) %% r_t end).

  Definition opt2b (a: option bool) (default: bool) :=
    match a with
      | Some b => b
      | None => default
    end.

  Definition prefix_parser_nooverride :=
   option_perm2 lock_or_rep_p segment_override_p @
     (fun p => match p with (l, s) =>
                 mkPrefix l s false false %% prefix_t end).
  Definition prefix_parser_opsize :=
    op_override_p @ (fun p =>  mkPrefix None None p false %% prefix_t)
    |+| op_override_p $ lock_or_rep_p @
        (fun p => match p with (b, l) => (mkPrefix (Some l) None b false %% prefix_t) end)

    |+| op_override_p $ segment_override_p @
        (fun p => match p with (b, s) => (mkPrefix None (Some s) b false %% prefix_t) end)

    |+| op_override_p $ lock_or_rep_p $ segment_override_p @
        (fun p => match p with (b, (l, s)) =>
                    (mkPrefix (Some l) (Some s) b false %% prefix_t) end)

    |+| op_override_p $ segment_override_p $ lock_or_rep_p @
        (fun p => match p with (b, (s, l)) =>
                    (mkPrefix (Some l) (Some s) b false %% prefix_t) end)

    |+| segment_override_p $ op_override_p @
        (fun p => match p with (s, b) =>
                    (mkPrefix None (Some s) b false %% prefix_t) end)

    |+| segment_override_p $ op_override_p $ lock_or_rep_p @
        (fun p => match p with (s, (b, l)) =>
                    (mkPrefix (Some l) (Some s) b false %% prefix_t) end)

    |+| segment_override_p $ lock_or_rep_p $ op_override_p  @
        (fun p => match p with (s, (l, b)) =>
                    (mkPrefix (Some l) (Some s) b false %% prefix_t) end)

    |+| lock_or_rep_p $ op_override_p @
        (fun p => match p with (l, b) =>
                    (mkPrefix (Some l) None b false %% prefix_t) end)

    |+| lock_or_rep_p $ op_override_p $ segment_override_p @
        (fun p => match p with (l, (b, s)) =>
                    (mkPrefix (Some l) (Some s) b false %% prefix_t) end)

    |+| lock_or_rep_p $ segment_override_p $ op_override_p @
        (fun p => match p with (l, (s, b)) =>
                    (mkPrefix (Some l) (Some s) b false %% prefix_t) end).

  Definition instruction_parser_list :=
    (List.map (fun (p:parser instruction_t) => prefix_parser_nooverride $ p)
      instr_parsers_nosize_pre) ++
    (List.map (fun (p:parser instruction_t) => prefix_parser_opsize $ p)
      instr_parsers_opsize_pre).

  Definition instruction_parser := alts instruction_parser_list.

  Definition instruction_regexp_pair := parser2regexp instruction_parser.
  Record instParserState := mkPS {
    inst_ctxt : ctxt_t ;
    inst_regexp : regexp (pair_t prefix_t instruction_t) ;
    inst_regexp_wf : wf_regexp inst_ctxt inst_regexp
  }.

  Definition initial_parser_state : instParserState :=
    mkPS (snd instruction_regexp_pair) (fst instruction_regexp_pair)
    (p2r_wf instruction_parser _).

  Definition byte_explode (b:int8) : list bool :=
  let bs := Word.bits_of_Z 8 (Word.unsigned b) in
    (bs 7)::(bs 6)::(bs 5)::(bs 4)::(bs 3)::(bs 2)::(bs 1)::(bs 0)::nil.

  Definition parse_byte (ps:instParserState) (b:int8) :
    instParserState * list (prefix * instr) :=
    let cs := byte_explode b in
    let r' := deriv_parse' (inst_regexp ps) cs in
    let wf' := wf_derivs (inst_ctxt ps) cs (inst_regexp ps) (inst_regexp_wf ps) in
      (mkPS (inst_ctxt ps) r' wf', apply_null (inst_ctxt ps) r' wf').

End X86_PARSER.


Require Import VST.floyd.proofauto.
Require Import fastpile.
Require Import spec_stdlib.
Require Import PileModel.

Record PileAPD := {
  pilerep: list Z -> val -> mpred;
  pilerep_local_facts: forall sigma p,
    pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma);
  pilerep_valid_pointer: forall sigma p,
    pilerep sigma p |-- valid_pointer p;
  pile_freeable (p: val) : mpred (*maybe expose the definition of this as malloc_token? Preferably NOT*)
}.

#[export] Hint Resolve pilerep_local_facts : saturate_local.
#[export] Hint Resolve pilerep_valid_pointer : valid_pointer.

Definition tpile := Tstruct _pile noattr.

Local Open Scope assert.

Section PileASI.
Variable M: MallocFreeAPD.
Variable PILE:PileAPD.

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() (PARAMS () GLOBALS (gv) (SEP(mem_mgr M gv)))
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(pilerep PILE nil p; pile_freeable PILE p; mem_mgr M gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(pilerep PILE sigma p; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep PILE (n::sigma) p; mem_mgr M gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS (p) GLOBALS ()
    SEP (pilerep PILE sigma p)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep PILE sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) (GLOBALS (gv)
    SEP(pilerep PILE sigma p; pile_freeable PILE p; mem_mgr M gv))
 POST[ tvoid ]
     PROP() LOCAL() SEP(mem_mgr M gv).

Definition PileASI:funspecs := [ Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].

End PileASI.


Require Export Fiat.Parsers.ContextFreeGrammar.Core.
Require Export Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Export Fiat.Parsers.StringLike.FirstCharSuchThat.
Require Export Coq.Strings.String.
Require Export Fiat.Computation.Core.
Require Export Coq.Program.Program.
Require Export Fiat.Computation.ApplyMonad.
Require Export Fiat.Computation.SetoidMorphisms.
Require Export Fiat.Common.
Require Export Fiat.Parsers.StringLike.Core.

Require Import Fiat.Parsers.ContextFreeGrammar.Equality.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.NatFacts.
Require Import Coq.Lists.List.

Export Common.opt2.Notations.

Import ListNotations.

Global Open Scope string_scope.
Global Open Scope list_scope.
Global Arguments string_beq : simpl never.
Global Arguments ascii_beq : simpl never.
Global Arguments item_beq : simpl never.
Global Arguments production_beq : simpl never.
Global Arguments productions_beq : simpl never.
Delimit Scope char_scope with char.
Infix "=p" := (production_beq _) (at level 70, no associativity).

(** Unfolding rules for enumerated ascii *)
Global Arguments Ascii.one / .
Global Arguments Ascii.shift _ !_ / .
Global Arguments Ascii.ascii_of_pos !_ / .
Global Arguments Ascii.ascii_of_nat !_ / .
Global Arguments Carriers.default_nonterminal_carrierT / .

Section tac_helpers.
  Lemma pull_match_list {A R R' rn rc} {ls : list A} (f : R -> R')
  : match ls with
      | nil => f rn
      | cons x xs => f (rc x xs)
    end = f (match ls with
               | nil => rn
               | cons x xs => rc x xs
             end).
  Proof.
    destruct ls; reflexivity.
  Qed.

  Lemma pull_match_item {A R R' rn rc} {ls : item A} (f : R -> R')
  : match ls with
      | NonTerminal x => f (rn x)
      | Terminal x => f (rc x)
    end = f (match ls with
               | NonTerminal x => rn x
               | Terminal x => rc x
             end).
  Proof.
    destruct ls; reflexivity.
  Qed.

  Lemma pull_match_bool {R R' rn rc} {b : bool} (f : R -> R')
  : (if b then f rn else f rc)
    = f (if b then rn else rc).
  Proof.
    destruct b; reflexivity.
  Qed.

  Lemma pull_If_bool {R R' rn rc} {b : bool} (f : R -> R')
  : (If b Then f rn Else f rc)
    = f (If b Then rn Else rc).
  Proof.
    destruct b; reflexivity.
  Qed.
End tac_helpers.

Lemma unguard {T} (x : T)
: refine { x' : T | True }
         (ret x).
Proof.
  repeat intro; computes_to_inv; subst.
  apply PickComputes; constructor.
Qed.

Global Arguments unguard {_} _ [_] _.

Ltac parser_pull_tac :=
  repeat match goal with
           | [ |- context G[match ?ls with
                              | nil => [?x]
                              | (_::_) => [?y]
                            end] ]
             => rewrite (@pull_match_list _ _ _ x (fun _ _ => y) ls (fun k => [k]))
           | [ |- context G[match ?it with
                              | NonTerminal _ => [?x]
                              | Terminal _ => [?y]
                            end] ]
             => rewrite (@pull_match_item _ _ _ (fun _ => x) (fun _ => y) it (fun k => [k]))
           | [ |- context G[match ?b with
                              | true => [?x]
                              | false => [?y]
                            end] ]
             => rewrite (@pull_match_bool _ _ x y b (fun k => [k]))
           | [ |- context G[match ?b with
                              | true => ret ?x
                              | false => ret ?y
                            end] ]
             => rewrite (@pull_match_bool _ _ x y b (fun k => ret k))
           | [ |- context G[If ?b Then [?x] Else [?y] ] ]
             => rewrite (@pull_If_bool _ _ x y b (fun k => [k]))
           | [ |- context G[If ?b Then ret ?x Else ret ?y] ]
             => rewrite (@pull_If_bool _ _ x y b (fun k => ret k))
         end.

Ltac unguard :=
  rewrite ?(unguard [0]).

Ltac solve_prod_beq :=
  clear;
  repeat match goal with
           | [ |- context[true = false] ] => congruence
           | [ |- context[false = true] ] => congruence
           | [ |- context[EqNat.beq_nat ?x ?y] ]
             => is_var x;
               let H := fresh in
               destruct (EqNat.beq_nat x y) eqn:H;
                 [ apply EqNat.beq_nat_true in H; subst x
                 | ];
                 simpl
           | [ |- context[EqNat.beq_nat ?x ?y] ]
             => first [ is_var x; fail 1
                      | generalize x; intro ]
         end.

Definition if_aggregate {A} (b1 b2 : bool) (x y : A)
: (If b1 Then x Else If b2 Then x Else y) = (If (b1 || b2)%opt2_bool Then x Else y)
  := if_aggregate b1 b2 x y.
Definition if_aggregate2 {A} (b1 b2 b3 : bool) (x y z : A) (H : b1 = false -> b2 = true -> b3 = true -> False)
: (If b1 Then x Else If b2 Then y Else If b3 Then x Else z) = (If (b1 || b3)%opt2_bool Then x Else If b2 Then y Else z)
  := if_aggregate2 x y z H.
Definition if_aggregate3 {A} (b1 b2 b3 b4 : bool) (x y z w : A) (H : b1 = false -> (b2 || b3)%bool = true -> b4 = true -> False)
: (If b1 Then x Else If b2 Then y Else If b3 Then z Else If b4 Then x Else w) = (If (b1 || b4)%opt2_bool Then x Else If b2 Then y Else If b3 Then z Else w)
  := if_aggregate3 _ _ x y z w H.

Module opt2.
  Definition orb_false_r : forall b, (b || false)%opt2_bool = b
    := Bool.orb_false_r.
  Definition andb_orb_distrib_r : forall b1 b2 b3 : bool,
      (b1 && (b2 || b3))%opt2_bool = (b1 && b2 || b1 && b3)%opt2_bool
    := Bool.andb_orb_distrib_r.
  Definition andb_orb_distrib_l : forall b1 b2 b3 : bool,
      ((b1 || b2) && b3)%opt2_bool = (b1 && b3 || b2 && b3)%opt2_bool
    := Bool.andb_orb_distrib_l.
  Definition orb_andb_distrib_r
    : forall b1 b2 b3 : bool,
      (b1 || b2 && b3)%opt2_bool = ((b1 || b2) && (b1 || b3))%opt2_bool
    := Bool.orb_andb_distrib_r.
  Definition orb_andb_distrib_l
    : forall b1 b2 b3 : bool,
      (b1 && b2 || b3)%opt2_bool = ((b1 || b3) && (b2 || b3))%opt2_bool
    := Bool.orb_andb_distrib_l.
  Definition andb_assoc
    : forall b1 b2 b3 : bool, (b1 && (b2 && b3))%opt2_bool = (b1 && b2 && b3)%opt2_bool
    := Bool.andb_assoc.
  Definition orb_assoc
    : forall b1 b2 b3 : bool, (b1 || (b2 || b3))%opt2_bool = (b1 || b2 || b3)%opt2_bool
    := Bool.orb_assoc.
  Definition andb_orb_distrib_r_assoc
    : forall b1 b2 b3 b4 : bool,
      (b1 && (b2 || b3) || b4)%opt2_bool = (b1 && b2 || (b1 && b3 || b4))%opt2_bool
    := andb_orb_distrib_r_assoc.
  Definition beq_0_1_leb
    : forall x : nat,
      (opt2.beq_nat x 1 || opt2.beq_nat x 0)%opt2_bool = opt2.leb x 1
    := beq_0_1_leb.
  Definition beq_S_leb
    : forall x n : nat,
      (opt2.beq_nat x (S n) || opt2.leb x n)%opt2_bool = opt2.leb x (S n)
    := beq_S_leb.
End opt2.


(* Sequentialisation - Definition of a sequentializing vertex *)
(* From a Proof Net, return a LL proof of the same sequent *)

From Coq Require Import Bool.
From OLlibs Require Import dectype.
Set Warnings "-notation-overridden". (* to ignore warnings due to the import of ssreflect *)
From mathcomp Require Import all_ssreflect.
Set Warnings "notation-overridden".
From GraphTheory Require Import mgraph setoid_bigop structures.

From Yalla Require Export mll_prelim mll_def mll_basic mll_seq_to_pn.

Import EqNotations.

Set Mangle Names.
Set Mangle Names Light.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Section Atoms.

(** A set of atoms for building formulas *)
Context { atom : DecType }.
(* TODO meilleur moyen de récupérer les notations *)
Notation formula := (@formula atom).
Notation base_graph := (graph (flat rule) (flat (formula * bool))).
Notation graph_data := (@graph_data atom).
Notation proof_structure := (@proof_structure atom).
Notation proof_net := (@proof_net atom).
Notation switching := (@switching atom).
Notation switching_left := (@switching_left atom).

Definition iso_to_isod (F G : proof_structure) (h : F ≃ G) :
  F ≃d perm_graph_data (sequent_iso_perm h) G.
Proof. eexists; simpl. apply perm_of_sequent_iso_perm. Defined.

(* sequentialisation : fonction reliant regles à noeuds => nb cut + quels tens lies à des cut *)
(* seuentialisation sans coupure puis avec (+ de cas ou en remplacant par des tens) *)

Definition sequentializing {G : proof_net} (v : G) : Type :=
  match vlabel v with
  | ax => {A & G ≃ ax_pn A}
  | ⊗ => {'(G0, G1) : proof_net * proof_net & G ≃ add_node_ps_tens G0 G1}
  | ⅋ => {G0 : proof_net & G ≃ add_node_ps_parr G0}
  | cut => {'(G0, G1) : proof_net * proof_net & G ≃ add_node_ps_cut G0 G1}
  | c => void (* a conclusion node is never sequentializing *)
  end.

Section Rem_node.
Context {G : proof_structure} {v : G}.
Hypothesis (V : vlabel v = ⊗ \/ vlabel v = ⅋) (T : terminal v).

(* Vertices neighbourhing v *)
Local Notation elv := (left V).
Local Notation erv := (right V).
Local Notation ecv := (ccl V).
Local Notation lv := (source elv).
Local Notation rv := (source erv).
Local Notation cv := (target ecv).

(** Base graph for removing a node and its eventual conclusion *) (* TODO faire comme add_node des cas selon vlabel_v pour factoriser ? *)
Definition rem_node_graph_1 := induced ([set: G] :\ v :\ cv).

(* Then add new conclusions *)
Lemma lv_inside : lv \in setT :\ v :\ cv.
Proof.
  rewrite !in_set. splitb; apply /eqP => F.
  - assert (P : walk lv lv [:: elv ; ecv]) by by rewrite /= F ccl_e left_e; splitb.
    by specialize (ps_acyclic P).
  - assert (FF : lv = target elv) by by rewrite left_e.
    apply (no_selfloop FF).
Qed.

Lemma rv_inside : rv \in setT :\ v :\ cv.
Proof.
  rewrite !in_set. splitb; apply /eqP => F.
  - assert (P : walk rv rv [:: erv ; ecv]) by by rewrite /= F ccl_e right_e; splitb.
    by specialize (ps_acyclic P).
  - assert (FF : rv = target erv) by by rewrite right_e.
    apply (no_selfloop FF).
Qed.

Definition rem_node_graph :=
  @add_concl_graph _ (@add_concl_graph _ rem_node_graph_1 (Sub rv rv_inside) c (flabel erv))
                     (inl (Sub lv lv_inside)) c (flabel elv).

Lemma vlabel_cv : vlabel cv = c.
Proof. apply /eqP. by rewrite -terminal_tens_parr. Qed.

Lemma v_neq_cv : v <> cv.
Proof. intro F. have := vlabel_cv. rewrite -F. by destruct V as [V' | V']; rewrite V'. Qed.

(* Give its order *)
Definition rem_node_transport (e : edge G) : edge rem_node_graph :=
  if @boolP _ is AltTrue p then Some (inl (Some (inl (Sub e p : edge rem_node_graph_1))))
  else if e == elv then None else Some (inl None).

Definition rem_node_order :=
  None :: (Some (inl None)) :: [seq rem_node_transport x | x <- [seq x <- order G | x != ecv]].

Definition rem_node_graph_data := {|
  graph_of := rem_node_graph;
  order := rem_node_order;
  |}.

Lemma rem_node_removed : edge_set (setT :\ v :\ cv) = setT :\ elv :\ erv :\ ecv.
Proof.
  assert (C := vlabel_cv).
  apply /setP => a. rewrite !in_set.
  destruct (eq_comparable a ecv) as [? | Hc];
  [ | destruct (eq_comparable a erv) as [? | Hr]];
  [ | | destruct (eq_comparable a elv)];
  try by (subst a; rewrite ?left_e ?right_e !eq_refl ?andb_false_r).
  assert (a != ecv /\ a != erv /\ a != elv) as [-> [-> ->]] by by splitb; apply /eqP.
  splitb; apply /eqP.
  - by apply no_source_c.
  - intros ?. contradict Hc. by apply ccl_eq.
  - intros ?. contradict Hc. by apply one_target_c.
  - intros ?. contradict Hr. by apply right_eq2.
Qed.

Definition rem_node_transport' : edge rem_node_graph -> edge G :=
  fun e => match e with
  | Some (inl (Some (inl (exist a _)))) => a
  | Some (inl (Some (inr a))) => match a with end
  | Some (inl None) => erv
  | Some (inr a) => match a with end
  | None => elv
  end.

Lemma rem_node_transport'_inj : injective rem_node_transport'.
Proof.
  move => [[[[[e E] | []] | ]| []] | ] [[[[[a A] | []] | ]| []] | ];
  cbnb; introb; cbnb.
  all: try by (contradict E || contradict A); apply /negP; rewrite rem_node_removed // !in_set; caseb.
  - by assert (erv <> elv) by apply nesym, left_neq_right.
  - by assert (elv <> erv) by apply left_neq_right.
Qed.

Lemma rem_node_transportK e :
  e <> ecv -> rem_node_transport' (rem_node_transport e) = e.
Proof.
  intros ?.
  unfold rem_node_transport, rem_node_transport'.
  case: {-}_ /boolP => In; cbnb. case_if.
  revert In. rewrite rem_node_removed !in_set. introb.
Qed.

Lemma rem_node_transportK' e :
  rem_node_transport (rem_node_transport' e) = e.
Proof.
  unfold rem_node_transport, rem_node_transport'.
  destruct e as [[[[[e E] | []] | ] | []] | ];
  case: {-}_ /boolP => In.
  - cbnb.
  - by contradict E; apply /negP.
  - contradict In; apply /negP. rewrite rem_node_removed !in_set. caseb.
  - case_if. by assert (erv <> elv) by apply nesym, left_neq_right.
  - contradict In; apply /negP. rewrite rem_node_removed !in_set. caseb.
  - case_if.
Qed.

Lemma flabel_rem_node_transport' e : flabel (rem_node_transport' e) = flabel e.
Proof. destruct e as [[[[[e E] | []] | ] | []] | ]; cbnb. Qed.

Lemma rem_node_transport_in_edges_at (b : bool) (e : edge G)
  (Hu : endpoint b e \in [set: G] :\ v :\ cv) :
  rem_node_transport e \in edges_at_outin b (inl (inl (Sub (endpoint b e) Hu)) : rem_node_graph).
Proof.
  rewrite in_set /rem_node_transport.
  case: {-}_ /boolP => In; cbnb; case_if; destruct b; cbnb.
  - contradict Hu; apply /negP. rewrite !in_set left_e. caseb.
  - revert In. rewrite rem_node_removed // !in_set. introb.
    all: contradict Hu; apply /negP; rewrite !in_set ?right_e; caseb.
  - revert In. rewrite rem_node_removed // !in_set. introb.
    contradict Hu; apply /negP.
    rewrite ccl_e !in_set. caseb.
Qed.

Lemma rem_node_transport_edges u Hu b : edges_at_outin b u =
  [set rem_node_transport' a | a in edges_at_outin b (inl (inl (Sub u Hu)) : rem_node_graph)].
Proof.
  apply /setP => e. rewrite in_set.
  symmetry. destruct (eq_comparable u (endpoint b e)) as [? | Hc]; [subst u | ].
  - rewrite eq_refl. apply /imsetP. exists (rem_node_transport e).
    + apply rem_node_transport_in_edges_at.
    + rewrite rem_node_transportK //.
      intros ?; subst e.
      contradict Hu; apply /negP.
      rewrite !in_set.
      destruct b; rewrite ?ccl_e; caseb.
  - transitivity false; last by by symmetry; apply /eqP; apply nesym.
    apply /imsetP; move => [[[[[[a A] | []] | ] | []] | ] Ain /= ?]; subst e.
    all: contradict Ain; apply /negP.
    all: rewrite !in_set eq_sym; destruct b; cbnb; by apply /eqP.
Qed.

Lemma rem_node_p_deg : proper_degree rem_node_graph.
Proof.
  move => b [[[u U] | []] | []] /=.
  - rewrite -p_deg rem_node_transport_edges card_imset //; by apply rem_node_transport'_inj.
  - destruct b.
    + assert (Hr : edges_at_in (inl (inr tt) : rem_node_graph) = [set Some (inl None)]).
      { apply /setP => e; rewrite !in_set. by destruct e as [[[[[? ?] | []] | ] | []] | ]. }
      by rewrite Hr cards1.
    + assert (Hr : edges_at_out (inl (inr tt) : rem_node_graph) = set0).
      { apply /setP => e; rewrite !in_set. by destruct e as [[[[[? ?] | []] | ] | []] | ]. }
      by rewrite Hr cards0.
  - destruct b.
    + assert (Hr : edges_at_in (inr tt : rem_node_graph) = [set None]).
      { apply /setP => e. rewrite !in_set. by destruct e as [[[[[? ?] | []] | ] | []] | ]. }
      by rewrite Hr cards1.
    + assert (Hr : edges_at_out (inr tt : rem_node_graph) = set0).
      { apply /setP => e. rewrite !in_set. by destruct e as [[[[[? ?] | []] | ] | []] | ]. }
      by rewrite Hr cards0.
Qed.

Lemma rem_node_p_ax_cut : proper_ax_cut rem_node_graph.
Proof.
  move => b [[[u U] | []] | []] /= Hu; try by destruct b.
  destruct (p_ax_cut Hu) as [el [er [Lin [Rin LR]]]].
  exists (rem_node_transport el), (rem_node_transport er).
  revert Lin. rewrite rem_node_transport_edges => /imsetP[al Al ?]. subst el.
  revert Rin. rewrite rem_node_transport_edges => /imsetP[ar Ar ?]. subst er.
  revert LR. rewrite !flabel_rem_node_transport' => LR.
  rewrite !rem_node_transportK'. splitb.
Qed.

Lemma rem_node_p_tens_parr : proper_tens_parr rem_node_graph.
Proof.
  move => b [[[u U] | []] | []] /= Hu; try by destruct b.
  destruct (p_tens_parr Hu) as [el [er [ec [Lin [Ll [Rin [Rl [Cin Elrc]]]]]]]].
  exists (rem_node_transport el), (rem_node_transport er), (rem_node_transport ec).
  revert Lin. rewrite rem_node_transport_edges => /imsetP[al Al ?]. subst el.
  revert Rin. rewrite rem_node_transport_edges => /imsetP[ar Ar ?]. subst er.
  revert Cin. rewrite rem_node_transport_edges => /imsetP[ac Ac ?]. subst ec.
  revert Elrc. rewrite !flabel_rem_node_transport' => Elrc.
  rewrite !rem_node_transportK'. splitb.
  - revert Ll. destruct al as [[[[[? ?] | []] | ] | []] | ]; cbnb.
  - revert Rl. destruct ar as [[[[[? ?] | []] | ] | []] | ]; cbnb.
    + contradict Ar. by rewrite !in_set.
    + by rewrite left_l.
Qed.

Lemma rem_node_p_noleft : proper_noleft rem_node_graph.
Proof. move => [[[[[e E] | []] | ]| []] | ] //=. by apply p_noleft. Qed.

Lemma rem_node_p_order : proper_order rem_node_graph_data.
Proof.
  split.
  - rewrite /= /rem_node_order.
    move => [[[[[e E] | []] | ] | []] | ] //=.
    rewrite !in_cons /=.
    assert (Hr : Some (inl (Some (inl (Sub e E : edge rem_node_graph_1)))) = rem_node_transport e).
    { rewrite /rem_node_transport. case: {-}_ /boolP => [In | /negP //]. cbnb. }
    rewrite Hr {Hr}. split.
    + move => ?. apply map_f.
      rewrite mem_filter. splitb.
      * revert E. rewrite rem_node_removed !in_set. introb.
      * by apply p_order.
    + move => /mapP[a A Ha].
      assert (a = e).
      { revert Ha. unfold rem_node_transport. case: {-}_ /boolP => [In | /negP //].
        case: {-}_ /boolP => [In' | /negP-? //]; last by case_if.
        move => /eqP. by cbnb => /eqP-->. }
      subst a.
      revert A. rewrite mem_filter. introb.
      by apply p_order.
  - rewrite /= in_cons /=. splitb.
    + apply /mapP; move => [a A] /eqP.
      rewrite /rem_node_transport.
      case: {-}_ /boolP => ?; case_if.
      revert A. rewrite mem_filter => /andP[_ A].
      apply p_order in A.
      contradict A.
      rewrite left_e. by destruct V as [H | H]; rewrite H.
    + apply /mapP; move => [a A] /eqP.
      rewrite /rem_node_transport.
      case: {-}_ /boolP => Ain; case_if.
      revert A. rewrite mem_filter => /andP[/eqP-A0 A].
      revert Ain. rewrite rem_node_removed // !in_set. introb.
      apply p_order in A.
      contradict A.
      rewrite right_e. by destruct V as [H | H]; rewrite H.
    + rewrite map_inj_in_uniq.
      { apply filter_uniq, p_order. }
      intros a b.
      rewrite !mem_filter => /andP[_ A] /andP[_ B].
      rewrite /rem_node_transport.
      case: {-}_ /boolP => Ain;
      case: {-}_ /boolP => Bin => /eqP; case_if.
      enough (L : forall e, e \notin edge_set (setT :\ v :\ cv) -> e \in order G -> e = ecv).
      { transitivity (ccl V); [ | symmetry]; by apply L. }
      clear - T.
      intros a Ain A.
      apply p_order in A.
      revert Ain. rewrite rem_node_removed !in_set. introb.
      * contradict A. rewrite right_e. destruct V as [H | H]; by rewrite H.
      * contradict A. rewrite left_e. destruct V as [H | H]; by rewrite H.
Qed.

Definition rem_node_ps := {|
  graph_data_of := rem_node_graph_data;
  p_deg := rem_node_p_deg;
  p_ax_cut := rem_node_p_ax_cut;
  p_tens_parr := rem_node_p_tens_parr;
  p_noleft := rem_node_p_noleft;
  p_order := rem_node_p_order;
  |}.

End Rem_node. (* TODO move this to the file with parr if not used for tens *)

(*
Definition rem_cut_graph_1 {G : proof_structure} {v : G} (H : vlabel v = cut) :=
  induced (setT :\ v).

(* Add two new conclusions *)
Lemma rem_cut_graph_helper {G : proof_structure} {v : G} (H : vlabel v = cut) :
  {'(e, f) & edges_at_in v = [set e; f] /\ e <> f /\ source e \in [set: G] :\ v /\ source f \in [set: G] :\ v}.
Proof.
  assert (C : exists e, [exists f, (e != f) && (edges_at_in v == [set e; f])]).
  { assert (C := pre_proper_cut H).
    revert C => /eqP/cards2P[e [f [? ?]]].
    exists e. apply /existsP. exists f. apply /andP. split; trivial. by apply /eqP. }
  revert C => /sigW[e] /existsP/sigW[f /andP[/eqP-? /eqP-In]].
  exists (e, f). splitb; trivial; [set a := e | set a := f].
  all: rewrite !in_set andb_true_r; apply /eqP.
  all: enough (v = target a) as -> by apply no_selfloop.
  all: enough (A : a \in edges_at_in v) by by revert A; rewrite in_set => /eqP-->.
  all: rewrite In !in_set; caseb.
Qed.

Definition rem_cut_graph {G : proof_structure} {v : G} (H : vlabel v = cut) : base_graph.
Proof.
  destruct (rem_cut_graph_helper H) as [[e f] [_ [_ [E F]]]].
  exact(@add_concl_graph _
    (@add_concl_graph _ (rem_cut_graph_1 H) (Sub (source e) E) c (flabel e))
      (inl (Sub (source f) F)) c (flabel f)).
Defined.

Definition splitting_cc (G : proof_net) (v : G) : bool :=
  match vlabel v as V return vlabel v = V -> bool with
  | ax => fun _ => terminal v
  | ⊗ => fun H => uconnected_nb (@switching_left _ (rem_node_graph (or_introl H))) == 2
  | ⅋ => fun H => uconnected_nb (@switching_left _ (rem_node_graph (or_intror H))) == 1
  | cut => fun H => uconnected_nb (@switching_left _ (rem_cut_graph H)) == 2
  | c => fun _ => false
  end Logic.eq_refl.

(* puis définir les graphes avec induced_sub S pour S dans
equivalence_partition (is_uconnected f) [set: G] et là ça devient galère,
faire des vues pour se retrouver avec des il existe equi = [S S'] (il existe sur
set de finset, donc ok je pense) puis définir les Gi à partir de là,
montrer qu'ils sont uconnected_nb = 1, puis finalement que
G iso à add_node Gi *)*)

(* OLD TRY
Lemma terminal_parr_is_splitting_cc (G : proof_net) (v : G) :
  vlabel v = ⅋ -> terminal v -> splitting_cc v.
Proof.
  intros V T.
  unfold splitting_cc. generalize (erefl (vlabel v)). rewrite {2 3}V => V'.
  assert (V = V') by apply eq_irrelevance. subst V'.
  enough (C : correct (rem_node_graph (or_intror V))) by by apply /eqP; destruct C.
  unfold rem_node_graph.
  destruct (rem_node_sources_stay (or_intror V)) as [e f].
  apply add_concl_correct, correct_to_weak, add_concl_correct. split.
  { apply uacyclic_induced, p_correct. }
  intros [x X] [y Y].
  destruct (correct_to_weak (p_correct G)) as [_ C].
  revert C => /(_ x y)/sigW[[p P] _].
  enough ({q : Supath switching_left (Sub x X : rem_node_graph_1 (or_intror V)) (Sub y Y) &
    p = [seq (val a.1, a.2) | a <- upval q]}) as [q _] by by exists q.
  revert x X P. induction p as [ | a p IH] => x X; rewrite /supath /=.
  { introb. replace Y with X by apply eq_irrelevance. by exists (supath_nil _ _). }
  rewrite in_cons => /andP[/andP[/andP[/eqP-? W] /andP[u U]] /norP[n N]]; subst x.
  destruct (utarget a \in [set: G] :\ v :\ target (ccl_parr V)) eqn:A.
  - destruct (IH _ A) as [q Hq].
    { splitb. }
    assert (Ain : a.1 \in edge_set ([set: G] :\ v :\ target (ccl_parr V))).
    { rewrite in_set. destruct a as [a []]; splitb. }
    assert (PA : supath switching_left (Sub (usource a) X : rem_node_graph_1 (or_intror V))
      (Sub (utarget a) A) [:: (Sub a.1 Ain, a.2)]).
    { rewrite /supath /= in_cons orb_false_r. splitb; try by cbnb.
      revert n. rewrite /switching_left /=. case_if. }
    enough (D : upath_disjoint switching_left {| upvalK := PA |} q).
    { exists (supath_cat D). cbn. rewrite Hq. f_equal. simpl. by destruct a. }
    rewrite /= /upath_disjoint disjoint_has /= orb_false_r.
    revert u. subst p.
    destruct q as [q Q]. rewrite -map_comp /=. clear.
    induction q as [ | c q IH]; trivial.
    rewrite /= !in_cons => /norP[k K]. apply /norP. rewrite IH //. splitb.
    revert k. rewrite /switching_left /=. case_if.
  - clear IH.
    assert (Vc : vlabel (target (ccl_parr V)) = c).
    { revert T. clear. rewrite (terminal_tens_parr (or_intror V)). apply /eqP. }
    assert (Ca : a = forward (left_parr V)).
    { clear - X A n Vc.
      revert A. rewrite !in_set andb_true_r => /nandP[/negPn/eqP-A | /negPn/eqP-A].
      - exfalso.
        destruct a as [a []].
        + assert (a = ccl_parr V) by by apply one_target_c.
          subst a.
          contradict X; apply /negP.
          rewrite !in_set /= ccl_e. caseb.
        + contradict A. simpl.
          by apply no_source_c.
      - destruct a as [a []].
        + simpl in A. f_equal.
          revert n. rewrite /switching_left /= A V /=. case_if.
          by apply left_eq.
        + assert (a = ccl_parr V) by by apply ccl_eq.
          subst a.
          contradict X; apply /negP.
          rewrite !in_set /=. caseb. }
    subst a.
    assert (Cp : p = [::] \/ p = [:: forward (ccl_parr V)]).
    { destruct p as [ | s p]; auto. right.
      assert (s = forward (ccl_parr V)).
      { revert W => /= /andP[/eqP-S W].
        rewrite left_e in S.
        destruct s as [s []]; simpl in *.
        - apply /eqP. cbn. rewrite andb_true_r. apply /eqP.
          by apply ccl_eq.
        - revert u N. rewrite !in_cons => /norP[S1 _] /norP[S2 _]. revert S1 S2.
          rewrite /switching_left left_e left_l S V /=.
          case_if.
          enough (left_parr V = s) by by [].
          symmetry. by apply left_eq. }
      subst s.
      destruct p as [ | r p]; trivial.
      exfalso. revert U W. clear - Vc.
      rewrite /= !in_cons => /andP[/norP[U _] _] /andP[_ /andP[/eqP-W _]].
      assert (r = backward (ccl_parr V)).
      { clear - W Vc.
        destruct r as [r []].
        - revert W. cbnb => W. contradict W.
          by apply no_source_c.
        - revert W. cbnb => W.
          apply /eqP. cbn. splitb. apply /eqP.
          by apply one_target_c. }
      subst r.
      contradict U. by apply /negP/negPn/eqP. }
    contradict Y. apply /negP. clear -Cp W.
    rewrite !in_set.
    revert W. destruct Cp; subst p; simpl.
    + move => /eqP-?; subst y. rewrite left_e. caseb.
    + move => /andP[_ /eqP-?]. subst y. caseb.
Qed.

Lemma splitting_cc_parr_is_sequentializing (G : proof_net) (v : G) :
  vlabel v = ⅋ -> terminal v -> splitting_cc v -> sequentializing v.
Proof.
  intros V T.
  unfold splitting_cc. generalize (erefl (vlabel v)). rewrite {2 3}V => V' S.
  assert (V = V') by apply eq_irrelevance. subst V'.
  rewrite /sequentializing V.
  assert (C : correct (rem_node_graph (or_intror V))).
  { split; [ | by apply /eqP].
    apply union_edge_uacyclic; last by apply unit_graph_uacyclic.
    apply union_edge_uacyclic; last by apply unit_graph_uacyclic.
    apply uacyclic_induced, p_correct. }
  exists {| ps_of := rem_node_ps (or_intror V) T ; p_correct := C |}.
Abort.
(*
  assert (h := rem_node_iso (or_intror V) T).
  rewrite {1}V in h.
  apply h.
Qed.
*)

Lemma splitting_cc_is_sequentializing (G : proof_net) (v : G) :
  splitting_cc v -> sequentializing v.
Proof.
Admitted.

Lemma terminal_parr_is_sequentializing (G : proof_net) (v : G) :
  vlabel v = ⅋ -> terminal v -> sequentializing v.
Proof. intros. by apply splitting_cc_is_sequentializing, terminal_parr_is_splitting_cc. Qed.
*)

Lemma exists_seq_or_no_seq (G : proof_net) :
  (forall (v : G), (sequentializing v -> False)) -> {v : G & sequentializing v}.
Proof.
Check existsPn.
(* Must use bool and not type, see criterion where needed in splitting tens *)
Abort.

End Atoms.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive insn :=
| Arg (dst : nat)
| Self (dst : nat)
| Deref (dst : nat) (e : nat) (off : nat)
| Call (dst : nat) (f : nat) (a : nat)
| MkConstr (dst : nat) (tag : nat) (args : list nat)
| Switch (dst : nat) (cases : list (list insn))
| MkClose (dst : nat) (f : function_name) (free : list nat)
| OpaqueOp (dst : nat) (op : opaque_oper_name) (args : list nat)
| Copy (dst : nat) (src : nat)
.

Definition env := list (list insn * nat).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    locals : list (nat * value)
}.

Definition set f l v :=
    Frame (arg f) (self f) ((l, v) :: locals f).

Definition local f l := lookup (locals f) l.

Inductive cont :=
| Kseq (code : list insn) (k : cont)
| Kswitch (code : list insn) (k : cont)
| Kret (code : list insn) (ret : nat) (dst : nat) (f : frame) (k : cont)
| Kstop (ret : nat).

Inductive state :=
| Run (i : list insn) (f : frame) (k : cont)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SSeq : forall i is f k,
        is <> [] ->
        sstep E (Run (i :: is) f k)
                (Run [i] f (Kseq is k))

| SArg : forall dst f k,
        sstep E (Run [Arg dst] f k)
                (Run [] (set f dst (arg f)) k)
| SSelf : forall dst f k,
        sstep E (Run [Self dst] f k)
                (Run [] (set f dst (self f)) k)

| SDerefinateConstr : forall dst e off f k  tag args v,
        local f e = Some (Constr tag args) ->
        nth_error args off = Some v ->
        sstep E (Run [Deref dst e off] f k)
                (Run [] (set f dst v) k)
| SDerefinateClose : forall dst e off f k  fname free v,
        local f e = Some (Close fname free) ->
        nth_error free off = Some v ->
        sstep E (Run [Deref dst e off] f k)
                (Run [] (set f dst v) k)

| SConstrDone : forall dst tag args f k vs,
        Forall2 (fun l v => local f l = Some v) args vs ->
        sstep E (Run [MkConstr dst tag args] f k)
                (Run [] (set f dst (Constr tag vs)) k)
| SCloseDone : forall dst fname free f k vs,
        Forall2 (fun l v => local f l = Some v) free vs ->
        sstep E (Run [MkClose dst fname free] f k)
                (Run [] (set f dst (Close fname vs)) k)
| SOpaqueOpDone : forall dst op args f k vs v,
        Forall2 (fun l v => local f l = Some v) args vs ->
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run [OpaqueOp dst op args] f k)
                (Run [] (set f dst v) k)

| SMakeCall : forall dst fl a f k  fname free arg body ret,
        local f fl = Some (Close fname free) ->
        local f a = Some arg ->
        nth_error E fname = Some (body, ret) ->
        sstep E (Run [Call dst fl a] f k)
                (Run body (Frame arg (Close fname free) [])
                    (Kret [] ret dst f k))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall dst cases f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run [Switch dst cases] f k)
                (Run case f (Kswitch [] k))

| SCopy : forall dst src f k v,
        local f src = Some v ->
        sstep E (Run [Copy dst src] f k)
                (Run [] (set f dst v) k)

| SContSeq : forall code f k,
        sstep E (Run [] f (Kseq code k))
                (Run code f k)
| SContSwitch : forall code f k,
        sstep E (Run [] f (Kswitch code k))
                (Run code f k)
| SContRet : forall f code ret dst f' k v,
        local f ret = Some v ->
        sstep E (Run [] f (Kret code ret dst f' k))
                (Run code (set f' dst v) k)
| SContStop : forall ret f v,
        local f ret = Some v ->
        sstep E (Run [] f (Kstop ret))
                (Stop v)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body ret,
        nth_error (fst prog) fname = Some (body, ret) ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 (Kstop ret)).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*

Definition prog_type : Type := env * list metadata.

Inductive initial_state (prog : prog_type) : state -> Prop :=.

Inductive final_state (prog : prog_type) : state -> Prop :=
| FinalState : forall v, final_state prog (Stop v).

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env
                 (sstep)
                 (initial_state prog)
                 (final_state prog)
                 (initial_env prog).

*)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HArg :     forall dst, P (Arg dst))
    (HSelf :    forall dst, P (Self dst))
    (HDeref :   forall dst e off, P (Deref dst e off))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pll cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HCopy :    forall dst src, P (Copy dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Arg dst => HArg dst
        | Self dst => HSelf dst
        | Deref dst e off => HDeref dst e off
        | Call dst f a => HCall dst f a
        | MkConstr dst tag args => HConstr dst tag args
        | Switch dst cases => HSwitch dst cases (go_list_list cases)
        | MkClose dst fname free => HClose dst fname free
        | OpaqueOp dst op args => HOpaqueOp dst op args
        | Copy dst src => HCopy dst src
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HArg :     forall dst, P (Arg dst))
    (HSelf :    forall dst, P (Self dst))
    (HDeref :   forall dst e off, P (Deref dst e off))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Forall (Forall P) cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HCopy :    forall dst src, P (Copy dst src))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp HCopy _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HArg :     forall dst, P (Arg dst))
    (HSelf :    forall dst, P (Self dst))
    (HDeref :   forall dst e off, P (Deref dst e off))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pll cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HCopy :    forall dst src, P (Copy dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp HCopy
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.

Definition dest e :=
    match e with
    | Arg dst => dst
    | Self dst => dst
    | Deref dst _ _ => dst
    | Call dst _ _ => dst
    | MkConstr dst _ _ => dst
    | Switch dst _ => dst
    | MkClose dst _ _ => dst
    | OpaqueOp dst _ _ => dst
    | Copy dst _ => dst
    end.