Require Import bbv.Word.
Require Import Coq.Lists.List.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Lt.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.NArith.NArith.
Require Import Coq.Structures.OrderedType.
Require Import Coq.Numbers.NatInt.NZLog.
Require Import Coq.ZArith.Wf_Z.
Require Export FMapAVL.
Require Export Coq.Structures.OrderedTypeEx.
Require Import Lia.
Module M := FMapAVL.Make(N_as_OT).

(* Compute (wordToNat (wplus (natToWord 32 10) (natToWord 32 20))). *)
Definition WLen: nat := 256.
Definition bigNum: N := wordToN (wlshift' (natToWord 257 1) 256).
Definition EVMWord:= word WLen.
Definition ByteLen: nat := 8.
Definition Byte := word ByteLen.
Definition StackLen := 1024.
Definition WZero: EVMWord  := natToWord WLen 0.
Definition WTrue: EVMWord  := natToWord WLen 1.
Definition WFalse: EVMWord := natToWord WLen 0.
Definition ZeroBit: word _ := natToWord 1 0.
Definition W0xFF: EVMWord := natToWord WLen 255.
Definition boolToWord(b: bool): EVMWord :=
  match b with
  | true  => WTrue
  | false => WFalse
  end.

(* Compute W0xFF. *)
Definition wgtbWorToUZ{sz: nat}(w: word sz): Z := wordToZ(bbv.Word.combine w ZeroBit).
Definition wugtb{sz: nat}(l r: word sz): bool := Z.gtb (wgtbWorToUZ l) (wgtbWorToUZ r).
Definition wultb{sz: nat}(l r: word sz): bool := Z.ltb (wgtbWorToUZ l) (wgtbWorToUZ r).
Definition wsgtb{sz: nat}(l r: word sz): bool := Z.gtb (wordToZ l) (wordToZ r).
Definition wsltb{sz: nat}(l r: word sz): bool := Z.ltb (wordToZ l) (wordToZ r).
Definition withbyte(w: EVMWord)(i: nat): EVMWord := wand (wrshift' w (248%nat - (i * 8))) W0xFF.
Definition Wones: EVMWord := wones WLen.
Definition pushMask(bytes: nat): EVMWord := wnot (wlshift' Wones (bytes * 8)).
Definition pushWordPass(w: EVMWord)(bytes: nat): EVMWord := wand (pushMask bytes) w.
(* Compute whd W0xFF. *)
Definition sextWordBytes(w: EVMWord)(bytes: nat): EVMWord :=
  match whd (wlshift' w (256 - (bytes * 8))) with
  | true  => wor (wlshift' Wones (bytes * 8)) (pushMask bytes)
  | false => pushMask bytes
  end.

Definition bytetoEWMword(w: word 8): EVMWord. Proof.
apply (Word.combine w (wzero' 248)).
Defined.
Compute wordToN (bytetoEWMword (natToWord 8 1)).
Definition wordSubModulus(a b: EVMWord): EVMWord :=
  if N.ltb (wordToN a) (wordToN b)
  then NToWord WLen (bigNum - ((wordToN b) - (wordToN a)))
  else wminus a b
.
Definition map_n_evmword := M.t EVMWord.
Definition find {V: Type}(k: EVMWord)(m: M.t V) := M.find (wordToN k) m.
Definition update (p: EVMWord * EVMWord) (m: map_n_evmword) :=
  M.add (wordToN (fst p)) (snd p) m.
Definition mapLength {V: Type}(m: M.t V): nat :=
  length (M.elements m).
Fixpoint wordmsb {sz: nat}(bitnum aux: nat)(w: word sz): nat :=
  match w with
  | WO => aux
  | WS b w1 =>
    match b with
    | true  => wordmsb (S bitnum) bitnum w1
    | false => wordmsb (S bitnum) aux w1
    end
  end.

Definition log2Orzero {sz} (w: word sz): nat := wordmsb 0 0 w.
(* aux parameter required to ensure termnation checker, for words we will have at most 256 iterations *)
Fixpoint effExpAux(a b: N)(aux: nat){struct aux}: N  :=
  match aux with
  | O => 0
  | S p =>
    match N.eqb b 0 with
    | true  => 1
    | false =>
      match N.eqb (N.modulo b 2) 1 with
      | true  => a * (effExpAux a (b - 1) p)
      | false => (effExpAux a (b / 2) p ) * (effExpAux a (b / 2) p)
      end
    end
  end.

Fixpoint expmodAux (a b m: N)(aux: nat): N:=
  match N.eqb m 1 with
  | true  => 0
  | false =>
    match aux with
    | 0 => 0
    | S p =>
      match N.eqb b 0 with
      | true  => 1
      | false =>
        match N.eqb (N.modulo b 2) 1 with
        | true  => N.modulo (a * (effExpAux a (b - 1) p)) m
        | false =>  let presq := (effExpAux a (b / 2) p ) in N.modulo (presq * presq) m
        end
      end
    end
  end.

Definition effExp(a b: N): N := effExpAux a b 512%nat.
Definition expmod(a b m: N): N := expmodAux a b m 512%nat.
(* Compute let maxword := (effExp 2 256) in let mwm1
:= N.sub maxword 1 in effExp mwm1 mwm1. *)
Definition wordModulus := effExp 2 256.

Notation "k |-> v" := (pair k v) (at level 60).
Notation "k |-> v" := (pair k v) (at level 60).
Notation "[ ]" := (M.empty nat).
Notation "[ p1 , .. , pn ]" := (update p1 .. (update pn (M.empty nat)) .. ).

Compute pushWordPass Wones 32.

Compute NToWord 8 1.

Definition combine {A B C: Type}(f: A -> B)(g: B -> C): A -> C :=
fun a => g (f a).

Notation "f1 * f2" := (combine f1 f2).

Definition map{L R R1: Type}(s: L + R)(f: R -> R1): L + R1 :=
  match s with
  | inl l => inl l
  | inr r => inr (f r)
  end.

Definition flatMap{L R R1: Type}(s: L + R)(f: R -> L + R1): L + R1 :=
  match s with
  | inl l => inl l
  | inr r => f r
  end.

Definition flatMapT(L R R1: Type)(s: L + R)(f: R -> L + R1): L + R1 :=
  match s with
  | inl l => inl l
  | inr r => f r
  end.

Definition leftMap{L1 L2 R: Type}(s: L1+R)(f: L1 -> L2): L2 + R :=
  match s with
  | inl l => inl (f l)
  | inr r => inr r
  end.

(* end straightforward either impl*)

(* very util functions*)

Fixpoint compareNatsAndAct{T: Set}(a b: nat)(ifAgreaterOrEqualToB ifBgreater: T): T:=
  match (a, b) with
   | (O, O)            => ifAgreaterOrEqualToB
   | (S _, O)          => ifAgreaterOrEqualToB
   | (O, S _)          => ifBgreater
   | (S predA,S predB) => compareNatsAndAct predA predB ifAgreaterOrEqualToB ifBgreater
  end.

Fixpoint gtb(a b: nat): bool :=
  match (a,b) with
  | (O, O) => false
  | (S _, O) => true
  | (O, S _) => false
  | (S predA, S predB) => gtb predA predB
  end.
Definition mapO{A B: Type}(o: option A)(f: A -> B): option B :=
  match o with
  | Some a => Some (f a)
  | None   => None
  end.
Definition flatMapO{A B: Type}(o: option A)(f: A -> option B): option B :=
  match o with
  | Some a => f a
  | None   => None
  end.
(* Compute let pos := 4 in let l := 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: nil in skipn 1 (firstn (pos - 1) l).
Compute let pos := 4 in let l := 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: nil in skipn pos l. *)
(* TODO: proofs
 *)
Definition listSwapWithHead{A: Set}(l: list A)(pos: nat): option (list A) :=
  flatMapO
  (hd_error l)
  (fun head =>
    flatMapO
    (nth_error l pos)
    (fun item =>
      let middle := skipn 1 (firstn (pos) l) in
      let rest   := skipn (pos + 1) l in
      Some ((item :: middle) ++ (head :: rest))
    )
  ).

Definition getSliceFromList{T: Type}(l: list T)(offset length: nat): option (list T) :=
  match Nat.ltb (offset+ length) (List.length l) with
  | true  => Some (firstn length (skipn offset l))
  | false => None
  end.

Compute let offset := 35 in let length := 3 in let l := 0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: nil in getSliceFromList l offset length.

Compute let pos := 4 in let l := 0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: nil in listSwapWithHead l pos.
(* end very util functions *)
(* execution 'monad' and error codes*)
Inductive Log: Type :=
| Log0: list EVMWord -> Log
| Log1: EVMWord -> list EVMWord -> Log
| Log2: EVMWord -> EVMWord -> list EVMWord -> Log
| Log3: EVMWord -> EVMWord -> EVMWord -> list EVMWord -> Log
| Log4: EVMWord -> EVMWord -> EVMWord -> EVMWord -> list EVMWord -> Log.

Inductive ExecutionState: Type :=
| ExecutionStateMk: list (EVMWord) -> map_n_evmword -> map_n_evmword -> (M.t (list (word 8))) -> nat -> (list Log) -> ExecutionState. (* pc stack memory storage contracts logs*)

Definition getLog_ES es :=
match es with
| ExecutionStateMk _ _ _ _ _ logs => logs
end.

Definition setLog_ES es logs :=
match es with
| ExecutionStateMk stack memory storage contractMap pc _ => ExecutionStateMk stack memory storage contractMap pc logs
end.

Definition getPc_ES es :=
match es with
| ExecutionStateMk _ _ _ _ pc _ => pc
end.

Definition setPc_ES es pc :=
match es with
| ExecutionStateMk stack memory storage contractMap _ logs => ExecutionStateMk stack memory storage contractMap pc logs
end.

Definition getStack_ES es :=
match es with
| ExecutionStateMk stack _ _ _ _ _ => stack
end.

Definition getMemory_ES es :=
match es with
| ExecutionStateMk _ memory _ _ _ _ => memory
end.

Definition setStack_ES es stack :=
match es with
| ExecutionStateMk _ memory storage contractMap pc logs => ExecutionStateMk stack memory storage contractMap pc logs
end.

Definition setMemory_ES es memory :=
match es with
| ExecutionStateMk stack _ storage contractMap pc logs => ExecutionStateMk stack memory storage contractMap pc logs
end.

Definition getStorage_ES es :=
match es with
| ExecutionStateMk _ _ storage _ _ _ => storage
end.

Definition setStorage_ES es storage :=
match es with
| ExecutionStateMk stack memory _ contractMap pc logs => ExecutionStateMk stack memory storage contractMap pc logs
end.

Definition getContractMap_ES es :=
match es with
| ExecutionStateMk _ _ _ contractMap _ _ => contractMap
end.

Definition setContractMap_ES es contractMap :=
match es with
| ExecutionStateMk stack memory storage _ pc logs => ExecutionStateMk stack memory storage contractMap pc logs
end.

Inductive SuccessfulExecutionResult: Type :=
| SuccessfulExecutionResultMk: ExecutionState -> SuccessfulExecutionResult
| SuccessfulExecutionResultMkWithData: ExecutionState -> list EVMWord -> SuccessfulExecutionResult
.

Inductive ErrorCode: Set :=
| OutOfGas: ErrorCode
| InvalidOpcode: ErrorCode
| InvalidJumpDest: ErrorCode
| StackUnderflow: ErrorCode
| StackOverflow: ErrorCode
| BadWordAsByte: ErrorCode
| BadSigExtendWord: ErrorCode
| BadByteArgI: ErrorCode
| BadShlArgI: ErrorCode
| BadShrArgI: ErrorCode
| BadCallDataLoadArgI: ErrorCode
| BadPeekArg: ErrorCode
| NonexistentAddress: ErrorCode
| NonexistentContract: ErrorCode
| NonexistentMemoryCell: ErrorCode
| NonexistentStorageCell: ErrorCode
| NonexistentCallDataCell : ErrorCode
| NotImplemented : ErrorCode
.

Inductive ErrorneousExecutionResult: Type :=
| ErrorneousExecutionResultMk: ErrorCode -> ExecutionState -> ErrorneousExecutionResult.

Definition ExecutionResult: Type := ErrorneousExecutionResult + SuccessfulExecutionResult.

Definition OpcodeApplicationResult: Type := ExecutionResult + ExecutionState.

Definition ExecutionResultOr T : Type := ExecutionResult + T.

(* end execution 'monad' and error codes*)
(* handy constructors *)

Definition stopExecutionWithSuccess(es: ExecutionState): OpcodeApplicationResult :=
  inl (inr (SuccessfulExecutionResultMk es)).

Definition failWithErrorCode{T: Type}(es: ExecutionState)(errorCode: ErrorCode): ExecutionResultOr T :=
  inl ( inl (ErrorneousExecutionResultMk errorCode es)).

(* Definition runningExecutionWithState es: OpcodeApplicationResult := inr es. *)

Definition runningExecutionWithState {T: Type}(t: T): ExecutionResultOr T := inr t.
(* end handy constructors *)
(* program counter operations *)

Definition setProgramCounter(es: ExecutionState)(programLength newPc: nat): OpcodeApplicationResult :=
    match Nat.leb programLength newPc with
    | true  => runningExecutionWithState es
    | false => failWithErrorCode es InvalidJumpDest
    end.
(* end program counter opertaions*)

Definition attach{T: Type}(o: OpcodeApplicationResult)(t: T): ExecutionResultOr (ExecutionState *T) :=
  map
  o
  (fun es => (es,t)).

(* stack operations *)
Definition pushItemToExecutionStateStack es item: OpcodeApplicationResult :=
  if(length (getStack_ES es) <? 1024)
  then runningExecutionWithState (setStack_ES es (item :: (getStack_ES es)))
  else failWithErrorCode es StackOverflow.

Definition removeAndDropFromStackOneItem es :=
  let stack := getStack_ES es in
    match stack with
      | head :: tail => runningExecutionWithState (setStack_ES es tail)
      | nil => failWithErrorCode es StackUnderflow
    end.

Definition removeAndReturnFromStackOneItem es: (ExecutionResultOr (ExecutionState * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: tail =>
          runningExecutionWithState ((setStack_ES es tail), head1)
      | nil => failWithErrorCode es StackUnderflow
    end.

Definition removeAndReturnFromStackTwoItems es: (ExecutionResultOr (ExecutionState * EVMWord * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: head2 :: tail =>
          runningExecutionWithState
            ((setStack_ES es tail), head1, head2)
      | nil | _ :: nil => failWithErrorCode es StackUnderflow
    end.

Definition removeAndReturnFromStackTwoItemsEnder es: (ErrorneousExecutionResult + (ExecutionState * EVMWord * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: head2 :: tail =>
          inr ((setStack_ES es tail), head1, head2)
      | nil | _ :: nil => inl (ErrorneousExecutionResultMk StackUnderflow es)
    end.

Definition removeAndReturnFromStackThreeItems es: (ExecutionResultOr (ExecutionState * EVMWord * EVMWord * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: head2 :: head3:: tail =>
          runningExecutionWithState
            ((setStack_ES es tail), head1, head2, head3)
      | nil | _ :: nil | _ :: _ :: nil => failWithErrorCode es StackUnderflow
    end.

Definition removeAndReturnFromStackFourItems es: (ExecutionResultOr (ExecutionState * EVMWord * EVMWord * EVMWord * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: head2 :: head3 :: head4 :: tail =>
          runningExecutionWithState
            ((setStack_ES es tail), head1, head2, head3, head4)
      | nil | _ :: nil | _ :: _ :: nil | _ :: _ :: _ :: nil=> failWithErrorCode es StackUnderflow
    end.

Definition removeAndReturnFromStackFiveItems es: (ExecutionResultOr (ExecutionState * EVMWord * EVMWord * EVMWord * EVMWord * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: head2 :: head3 :: head4 :: head5 :: tail =>
          runningExecutionWithState
            ((setStack_ES es tail), head1, head2, head3, head4, head5)
      | nil | _ :: nil | _ :: _ :: nil | _ :: _ :: _ :: nil | _ :: _ :: _ :: _ :: nil => failWithErrorCode es StackUnderflow
    end.

Definition removeAndReturnFromStackSixItems es: (ExecutionResultOr (ExecutionState * EVMWord * EVMWord * EVMWord * EVMWord * EVMWord * EVMWord)) :=
  let stack := getStack_ES es in
    match stack with
      | head1 :: head2 :: head3 :: head4 :: head5 :: head6 :: tail =>
          runningExecutionWithState
            ((setStack_ES es tail), head1, head2, head3, head4, head5, head6)
      | nil | _ :: nil | _ :: _ :: nil | _ :: _ :: _ :: nil | _ :: _ :: _ :: _ :: nil | _ :: _ :: _ :: _ :: _ :: nil => failWithErrorCode es StackUnderflow
    end.

Definition peekNthItemFromStack es (n: nat): (ExecutionResultOr EVMWord):=
  let stack := getStack_ES es in
    match nth_error stack n with
      | Some item => runningExecutionWithState item
      | None      => failWithErrorCode es BadPeekArg
    end.
(* end stack operations *)

Fixpoint insertItemsIntoMemoryAux(es: ExecutionState)(acc offset: nat)(words: list EVMWord){struct words} : ExecutionState :=
  match words with
  | nil        => es
  | w :: words' =>
    let mem := getMemory_ES es in
    let updatedMemory := update (natToWord WLen (acc + offset), w) mem in
    let new_es := setMemory_ES es updatedMemory in
    insertItemsIntoMemoryAux new_es (S acc) offset words'
  end.

Definition insertItemsIntoMemory(es: ExecutionState)(offset: nat)(words: list EVMWord): ExecutionState :=
  insertItemsIntoMemoryAux es 0 offset words.

Definition zipBytesToWord(l: list (word 8)):=
  fold_left (fun acc => fun b => wor (wlshift' acc 8) (bytetoEWMword b)) l WZero.
(*
Lemma
Compute let w0 := natToWord 8 1 in let w1 := natToWord 8 1 in let w2 := natToWord 8 1 in let res := zipBytesToWord (w1 :: w1 :: w1 :: w1 :: nil) in wordToN res.
 *)

Fixpoint zipListOfBytesIntoListOfWordsAux(l: list (word 8))(crutch: nat): list EVMWord :=
  match crutch with
  | O => match l with | nil => nil | _ :: __ => (zipBytesToWord l) :: nil end
  | S p => zipListOfBytesIntoListOfWordsAux (skipn 32 l) (p) ++ (zipBytesToWord (firstn 32 l) :: nil)
  end.

Definition zipListOfBytesIntoListOfWords(l: list (word 8)): list EVMWord :=
  zipListOfBytesIntoListOfWordsAux l ( ((length l) / 32) + 1).

(* WordUtil *)
Definition extractByteAsNat(w: EVMWord): ErrorCode + nat :=
  match weqb (wlshift' w 8%nat) WZero with
  | true  => inr (wordToNat w)
  | false => inl BadWordAsByte
  end.

(* WordUtil *)
Inductive SimplePriceOpcode: Set :=
| ADD	          : SimplePriceOpcode
| MUL	          : SimplePriceOpcode
| SUB	          : SimplePriceOpcode
| DIV	          : SimplePriceOpcode
| SDIV	        : SimplePriceOpcode
| MOD	          : SimplePriceOpcode
| SMOD	        : SimplePriceOpcode
| ADDMOD	      : SimplePriceOpcode
| MULMOD	      : SimplePriceOpcode
| SIGNEXTEND	  : SimplePriceOpcode
| LT	          : SimplePriceOpcode
| GT	          : SimplePriceOpcode
| SLT	          : SimplePriceOpcode
| SGT	          : SimplePriceOpcode
| EQ	          : SimplePriceOpcode
| ISZERO	      : SimplePriceOpcode
| AND	          : SimplePriceOpcode
| OR	          : SimplePriceOpcode
| XOR	          : SimplePriceOpcode
| NOT	          : SimplePriceOpcode
| BYTE          : SimplePriceOpcode
| ADDRESS	      : SimplePriceOpcode
| BALANCE	      : SimplePriceOpcode
| ORIGIN	      : SimplePriceOpcode
| CALLER	      : SimplePriceOpcode
| CALLVALUE	    : SimplePriceOpcode
| CALLDATALOAD	: SimplePriceOpcode
| CALLDATASIZE	: SimplePriceOpcode
| CODESIZE	    : SimplePriceOpcode
| GASPRICE	    : SimplePriceOpcode
| EXTCODESIZE	  : SimplePriceOpcode
| BLOCKHASH	    : SimplePriceOpcode
| COINBASE	    : SimplePriceOpcode
| TIMESTAMP	    : SimplePriceOpcode
| NUMBER	      : SimplePriceOpcode
| DIFFICULTY  	: SimplePriceOpcode
| GASLIMIT	    : SimplePriceOpcode
| POP	          : SimplePriceOpcode
| MLOAD	        : SimplePriceOpcode
| MSTORE	      : SimplePriceOpcode
| MSTORE8	      : SimplePriceOpcode
| SLOAD	        : SimplePriceOpcode
| PC	          : SimplePriceOpcode
| MSIZE	        : SimplePriceOpcode
| GAS	          : SimplePriceOpcode
| JUMPDEST	    : SimplePriceOpcode
| PUSH	        : word 5 -> EVMWord -> SimplePriceOpcode
| DUP	          : word 4 -> SimplePriceOpcode
| SWAP	        : word 4 -> SimplePriceOpcode
| CREATE	      : SimplePriceOpcode
| JUMP          : SimplePriceOpcode
| JUMPI         : SimplePriceOpcode
.

Definition simplePriceOpcodePrice(o: SimplePriceOpcode): nat :=
  match o with
  | ADD	          => 3
  | MUL	          => 5
  | SUB	          => 3
  | DIV	          => 5
  | SDIV	        => 5
  | MOD	          => 5
  | SMOD	        => 5
  | ADDMOD	      => 8
  | MULMOD	      => 8
  | SIGNEXTEND	  => 5
  | LT	          => 3
  | GT	          => 3
  | SLT	          => 3
  | SGT	          => 3
  | EQ	          => 3
  | ISZERO	      => 3
  | AND	          => 3
  | OR	          => 3
  | XOR	          => 3
  | NOT	          => 3
  | BYTE          => 3
  | ADDRESS	      => 2
  | BALANCE	      => 400
  | ORIGIN	      => 2
  | CALLER	      => 2
  | CALLVALUE	    => 2
  | CALLDATALOAD	=> 3
  | CALLDATASIZE	=> 2
  | CODESIZE	    => 2
  | GASPRICE	    => 2
  | EXTCODESIZE	  => 700
  | BLOCKHASH	    => 20
  | COINBASE	    => 2
  | TIMESTAMP	    => 2
  | NUMBER	      => 2
  | DIFFICULTY  	=> 2
  | GASLIMIT	    => 2
  | POP	          => 2
  | MLOAD	        => 3
  | MSTORE	      => 3
  | MSTORE8	      => 3
  | SLOAD	        => 200
  | PC	          => 2
  | MSIZE	        => 2
  | GAS	          => 2
  | JUMPDEST	    => 1
  | PUSH _ _	    => 3
  | DUP _	        => 3
  | SWAP	_       => 3
  | CREATE	      => 32000
  | JUMP          => 8
  | JUMPI         => 10
  end.

Inductive ComplexPriceOpcode: Set :=
|	EXP                : ComplexPriceOpcode
|	SHA3	             : ComplexPriceOpcode
|	CALLDATACOPY	     : ComplexPriceOpcode
|	CODECOPY	         : ComplexPriceOpcode
|	EXTCODECOPY	       : ComplexPriceOpcode
|	SSTORE	           : ComplexPriceOpcode
|	LOG0	             : ComplexPriceOpcode
|	LOG1	             : ComplexPriceOpcode
|	LOG2	             : ComplexPriceOpcode
|	LOG3	             : ComplexPriceOpcode
|	LOG4	             : ComplexPriceOpcode
|	CALL	             : ComplexPriceOpcode
|	CALLCODE	         : ComplexPriceOpcode
|	DELEGATECALL	     : ComplexPriceOpcode
|	SELFDESTRUCT	     : ComplexPriceOpcode
.

Inductive OpCode: Set :=
|	STOP	              : OpCode
|	RETURN	            : OpCode
| ComplexPriceOpcodeMk: ComplexPriceOpcode -> OpCode
| SimplePriceOpcodeMk : SimplePriceOpcode  -> OpCode
.

Inductive CallInfo: Type :=
| CallInfoMk:
  list (EVMWord)(*calldata*) ->
  EVMWord(*this contract address*) ->
  EVMWord(*caller balance*) ->
  EVMWord(*transaction hash*) ->
  EVMWord(*caller address*) ->
  EVMWord(*call eth value*) ->
  list Byte(*this contract code*) ->
  EVMWord(*tx gas price*) ->
  EVMWord(*block hash*) ->
  EVMWord(*block number*) ->
  EVMWord(*block dificulty*) ->
  EVMWord(*block timestamp*) ->
  EVMWord(*gas block limit*) ->
  EVMWord(*miner's address*) ->
  map_n_evmword(*account balances *) ->
  CallInfo.

(*
  match _ with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
  end
 *)
Definition get_calldata(ci: CallInfo): list EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    calldata
  end.

Definition get_thisContractAddress(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    thisContractAddress
  end.

Definition get_callerBalance(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    callerBalance
  end.

Definition get_transactionHash(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    transactionHash
  end.

Definition get_callerAddress(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    callerAddress
  end.

Definition get_callEthValue(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    callEthValue
  end.

Definition get_thisContractCode(ci: CallInfo): list (word ByteLen) :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    thisContractCode
  end.

Definition get_txGasPrice(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    txGasPrice
  end.

Definition get_blockHash(ci: CallInfo):EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    blockHash
  end.

Definition get_blockNumber(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    blockNumber
  end.

Definition get_blockDificulty(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    blockDificulty
  end.

Definition get_gasLimit(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    blockDificulty
  end.

Definition get_miner(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    miner
  end.

Definition get_blockTimestamp(ci: CallInfo): EVMWord :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    blockTimestamp
  end.

Definition get_accountBalances(ci: CallInfo): map_n_evmword :=
  match ci with
  | CallInfoMk calldata thisContractAddress callerBalance transactionHash callerAddress callEthValue thisContractCode txGasPrice blockHash blockNumber blockDificulty blockTimestamp gasLimit miner accountBalances=>
    accountBalances
  end.

Fixpoint getSliceFromMapAux{V: Type}(m: M.t V)(offset: EVMWord)(length : nat)(acc: list V){struct length}: ErrorCode + (list V) :=
  match length with
  | O      =>
    match find offset m with
    | Some v => inr (acc ++ (v :: nil))
    | None   => inl NonexistentMemoryCell
    end
  | S pred =>
    match find offset m  with
    | Some v => getSliceFromMapAux m (wplus offset WTrue) pred (acc ++ (v :: nil))
    | None   => inl NonexistentMemoryCell
    end
  end.

Definition getSliceFromMap{V: Type}(m: M.t V)(offset: EVMWord)(length : nat): ErrorCode + (list V) :=
  getSliceFromMapAux m offset length nil.

Definition stopAction(state: ExecutionState): OpcodeApplicationResult :=
  stopExecutionWithSuccess (state).

Definition addActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    ( fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wplus a b))
      end
    ).

Definition mulActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) =>
        pushItemToExecutionStateStack es (wmult a b)
      end
    ).

Definition subActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => pushItemToExecutionStateStack es (wordSubModulus a b)
      end
    ).

Definition divActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wdiv a b))
      end
    ).

Definition sdivActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wdivZ a b))
      end
    ).

Definition modActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wmod a b))
      end
    ).

Definition smodActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (ZToWord WLen (Z.rem (wordToZ a) (wordToZ b))))
      end
    ).

Definition addmodActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackThreeItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b, N) =>
      let za := wordToZ a in let zb := wordToZ b in let zN := Z.of_N (wordToN N) in
      let zres := Z.rem (za + zb) zN in
      (pushItemToExecutionStateStack es (ZToWord WLen zres))
      end
    ).

Definition mulmodActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackThreeItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b, N) =>
      let za := wordToZ a in let zb := wordToZ b in let zN := Z.of_N (wordToN N) in
      let zres := Z.rem (za * zb) zN in
      (pushItemToExecutionStateStack es (ZToWord WLen zres))
      end
    ).

Definition signextendActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) =>
        match extractByteAsNat b with
        | inl err => failWithErrorCode es err
        | inr n   => (pushItemToExecutionStateStack es (sextWordBytes a n))
        end
      end
    ).

Definition ltActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (boolToWord (wultb a b)))
      end
    ).

Definition gtActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (boolToWord (wugtb a b)))
      end
    ).

Definition sltActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (boolToWord (wsltb a b)))
      end
    ).

Definition sgtActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (boolToWord (wsgtb a b)))
      end
    ).

Definition eqActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (boolToWord (weqb a b)))
      end
    ).

Definition iszeroActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      match tup2 with
      | (es, a) => (pushItemToExecutionStateStack es (boolToWord (weqb a WZero)))
      end
    ).

Definition andActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wand a b))
      end
    ).

Definition orActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wor a b))
      end
    ).

Definition xorActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, b) => (pushItemToExecutionStateStack es (wxor a b))
      end
    ).

Definition notActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      match tup2 with
      | (es, a) => (pushItemToExecutionStateStack es (wnot a))
      end
    ).

Definition byteActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, i, x) =>
        match extractByteAsNat i with
        | inr inat    =>
            match Nat.ltb inat 32 with
            | true  => (pushItemToExecutionStateStack es (withbyte x inat))
            | false => failWithErrorCode es BadShlArgI
            end
        | inl errCode => failWithErrorCode es errCode
        end
      end
    ).

Definition shlActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, i, x) =>
        match extractByteAsNat i with
        | inr inat    =>
            match Nat.ltb inat 257 with
            | true  => (pushItemToExecutionStateStack es (wlshift' x inat))
            | false => failWithErrorCode es BadShrArgI
            end
        | inl errCode => failWithErrorCode es errCode
        end
      end
    ).

Definition shrActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, i, x) =>
        match extractByteAsNat i with
        | inr inat    =>
            match Nat.ltb inat 257 with
            | true  => (pushItemToExecutionStateStack es (wrshift' x inat))
            | false => failWithErrorCode es BadByteArgI
            end
        | inl errCode => failWithErrorCode es errCode
        end
      end
    ).

(*SHA3*)
Definition addressActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (get_thisContractAddress ci)).

Definition balanceActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
  flatMap
  (removeAndReturnFromStackOneItem state)
  (fun tup2 =>
      match tup2 with
      | (es, a) =>
        match find a (get_accountBalances ci) with
        | Some balance => (pushItemToExecutionStateStack es balance)
        | None => failWithErrorCode es NonexistentAddress
        end
      end
    ).

Definition originActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (get_callerAddress ci)).

(*  becasue currently implemnted state of EVM does not support nested contract calls, callser = origin *)
Definition callerActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (get_callerAddress ci)).

Definition callvalueActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (get_callEthValue ci)).

Definition calldataloadActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      match tup2 with (* todo complete*)
      | (es, idxWord) =>
        let i := wordToNat idxWord in
          match nth_error (get_calldata ci) i with
          | Some dataCell => (pushItemToExecutionStateStack es dataCell)
          | None          => failWithErrorCode es BadCallDataLoadArgI
          end
      end
    ).

Definition calldatasizeActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (natToWord WLen (length (get_calldata ci)))).

(*Calldatacopy*)

Definition codesizeActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (natToWord WLen (length (get_thisContractCode ci)))).
(* codecopy *)

Definition gaspriceActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_txGasPrice ci)).

Definition exctcodesizeActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
  flatMap
  (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      match tup2 with
      | (es, address) =>
        match find address (getContractMap_ES es) with
        | Some contract => (pushItemToExecutionStateStack state (natToWord WLen (length contract)))
        | None          => failWithErrorCode es NonexistentMemoryCell
        end
      end
    ).
(* extcodecopy *)

Definition blockhashActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_blockHash ci)).

Definition coinbaseActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_miner ci)).

Definition timestampActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_blockTimestamp ci)).

Definition numberActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_blockNumber ci)).

Definition dificultyActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_blockDificulty ci)).

Definition gaslimitActionPure(state: ExecutionState)(ci: CallInfo): OpcodeApplicationResult :=
    (pushItemToExecutionStateStack state (get_gasLimit ci)).

Definition popActionPure(state: ExecutionState): OpcodeApplicationResult :=
    flatMap
    (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      runningExecutionWithState (fst tup2)
    ).

Definition mloadActionPure(state: ExecutionState): OpcodeApplicationResult :=
  flatMap
  (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      match tup2 with
      | (es, key) =>
        match find key (getMemory_ES es) with
        | Some wrd => (pushItemToExecutionStateStack state wrd)
        | None     => failWithErrorCode es NonexistentMemoryCell
        end
      end
    ).

Definition mstoreActionPure(state: ExecutionState): OpcodeApplicationResult :=
  flatMap
  (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, key, value) => runningExecutionWithState (setMemory_ES es (update (key, value) (getMemory_ES es)) )
      end
    ).

Definition mstore8ActionPure(state: ExecutionState): OpcodeApplicationResult :=
  flatMap
  (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, key, value) => runningExecutionWithState (setMemory_ES es (update (key, wand value W0xFF) (getMemory_ES es)) )
      end
    ).

Definition sloadActionPure(state: ExecutionState): OpcodeApplicationResult :=
  flatMap
  (removeAndReturnFromStackOneItem state)
    (fun tup2 =>
      match tup2 with
      | (es, key) =>
        match find key (getStorage_ES es) with
        | Some wrd => (pushItemToExecutionStateStack state wrd)
        | None     => failWithErrorCode es NonexistentMemoryCell
        end
      end
    ).

Definition sstoreActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, key, value) =>
        let storage := getStorage_ES es in
        let updatedStorageES := setStorage_ES es (update (key, value) storage) in
        match find key storage with
         | Some w =>
          match (weqb w WZero, weqb value WZero)  with
          | (true, true)  => runningExecutionWithState (es, 5000)
          | (true, false) => runningExecutionWithState (updatedStorageES, 20000)
          | (false, _) => runningExecutionWithState (setStorage_ES es (update (key, value) (getStorage_ES es)), 5000)
          end
         | None => runningExecutionWithState (updatedStorageES, 20000)
        end
      end
    ).

Definition pcActionPure(state: ExecutionState)(programCounter: nat): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (natToWord  WLen programCounter)).

Definition msizeActionPure(state: ExecutionState): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (natToWord WLen (mapLength (getMemory_ES state)))).

Definition gasActionPure(state: ExecutionState)(gas: nat): OpcodeApplicationResult :=
  (pushItemToExecutionStateStack state (natToWord WLen gas)).

Definition pushActionPure(bytes: word 5)(w: EVMWord)(state: ExecutionState): OpcodeApplicationResult :=
  let checkedWord := pushWordPass w (wordToNat bytes + 1) in
  (pushItemToExecutionStateStack state checkedWord).

Definition dupActionPure(bytes: word 4)(state: ExecutionState):OpcodeApplicationResult :=
  flatMap
  (peekNthItemFromStack state (wordToNat bytes))
  (fun item =>
    (pushItemToExecutionStateStack state item)
  ).

Definition swapActionPure(bytes: word 4)(state: ExecutionState): OpcodeApplicationResult :=
   let stack := getStack_ES state in
   match listSwapWithHead(stack)((wordToNat bytes) + 1)  with
   | Some swappedStack => runningExecutionWithState (setStack_ES state swappedStack)
   | None              => failWithErrorCode state BadPeekArg
   end.

(* LOG*)
(* CREATE *)
(* CALL *)
(* CALLCODE*)
Definition returnActionPure(state: ExecutionState): ExecutionResult :=
    flatMap
    (removeAndReturnFromStackTwoItemsEnder state)
    (fun tup3 =>
      match tup3 with (* todo complete*)
      | (es, offset, length) =>
        match getSliceFromMap (getMemory_ES es) offset (wordToNat length) with
        | inl error => inl (ErrorneousExecutionResultMk error es)
        | inr returndata  => inr (SuccessfulExecutionResultMkWithData es returndata)
        end
      end
    ).

Definition jumpActionPure(state: ExecutionState)(program: list OpCode): OpcodeApplicationResult:=
  flatMap
  (removeAndReturnFromStackOneItem state)
  (fun tup2 =>
    match tup2 with
    | (es, pos) =>
      if N.ltb (wordToN pos) (N.of_nat (length program))
      then
        let posNat := wordToNat pos in
        match nth_error program posNat with
        | Some(SimplePriceOpcodeMk JUMPDEST) => runningExecutionWithState (setPc_ES es posNat)
        | _ => failWithErrorCode es InvalidJumpDest
        end
      else failWithErrorCode es InvalidJumpDest
    end
  ).

Definition jumpiActionPure(state: ExecutionState)(program: list OpCode): OpcodeApplicationResult:=
  flatMap
  (removeAndReturnFromStackTwoItems state)
  (fun tup3 =>
    match tup3 with
    | (es, pos, cond) =>
      if weqb cond WZero
      then runningExecutionWithState es
      else if N.ltb (wordToN pos) (N.of_nat (length program))
           then
             let posNat := wordToNat pos in
             match nth_error program posNat with
             | Some(SimplePriceOpcodeMk JUMPDEST) => runningExecutionWithState (setPc_ES es posNat)
             | _ => failWithErrorCode es InvalidJumpDest
             end
           else failWithErrorCode es InvalidJumpDest
    end
  ).

Definition calldatacopyActionPure(state: ExecutionState)(ci: CallInfo): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackThreeItems state)
  (fun tup4 =>
    match tup4 with
    | (es, destOffset, offset, length) =>
      match getSliceFromList (get_calldata ci) (wordToNat offset) (wordToNat length) with
      | Some words => runningExecutionWithState ((insertItemsIntoMemory es (wordToNat destOffset) words), 2 + (List.length words) * 3)
      | None       => failWithErrorCode es NonexistentCallDataCell
      end
    end)
.

Definition codecopyActionPure(state: ExecutionState)(ci: CallInfo): ExecutionResultOr (ExecutionState * nat):=
  flatMap
  (removeAndReturnFromStackThreeItems state)
  (fun tup4 =>
    match tup4 with
    | (es, destOffset, offset, length) =>
      match getSliceFromList (get_thisContractCode ci) (wordToNat offset) (wordToNat length) with
      | Some words => runningExecutionWithState ((insertItemsIntoMemory es (wordToNat destOffset) (zipListOfBytesIntoListOfWords words)), 2 + (List.length words) * 3)
      | None       => failWithErrorCode es NonexistentCallDataCell
      end
    end)
.

Definition extcodecopyActionPure(state: ExecutionState)(ci: CallInfo): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackFourItems state)
  (fun tup5 =>
    match tup5 with
    | (es, addr, destOffset, offset, length) =>
      match find addr (getContractMap_ES es) with
      | Some contract =>
        match getSliceFromList (contract) (wordToNat offset) (wordToNat length) with
        | Some words => runningExecutionWithState ((insertItemsIntoMemory es (wordToNat destOffset) (zipListOfBytesIntoListOfWords words)), 700 + (List.length words) * 3)
        | None       => failWithErrorCode es NonexistentCallDataCell
        end
      | None => failWithErrorCode es NonexistentContract
      end
    end)
.

Definition log0ActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackTwoItems state)
  (fun tup3 =>
    match tup3 with
    | (es, offset, length) =>
      match getSliceFromMap (getMemory_ES es) offset (wordToNat length) with
        | inl error => failWithErrorCode es error
        | inr logData  =>
          let log := Log0 logData in
          let logs := getLog_ES es in
          let es2 := setLog_ES es logs in
            runningExecutionWithState (es2, 375 + (List.length logData * 8 * 32))
        end
      end
    ).

Definition log1ActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackThreeItems state)
  (fun tup4 =>
    match tup4 with
    | (es, offset, length, topic0) =>
      match getSliceFromMap (getMemory_ES es) offset (wordToNat length) with
        | inl error => failWithErrorCode es error
        | inr logData  =>
          let log := Log1 topic0 logData  in
          let logs := getLog_ES es in
          let es2 := setLog_ES es logs in
            runningExecutionWithState (es2, 2 * 375 + (List.length logData * 8 * 32))
        end
      end
    ).

Definition log2ActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackFourItems state)
  (fun tup5 =>
    match tup5 with
    | (es, offset, length, topic0, topic1) =>
      match getSliceFromMap (getMemory_ES es) offset (wordToNat length) with
        | inl error => failWithErrorCode es error
        | inr logData  =>
          let log := Log2 topic0 topic1 logData  in
          let logs := getLog_ES es in
          let es2 := setLog_ES es logs in
            runningExecutionWithState (es2, 3 * 375  + (List.length logData * 8 * 32))
        end
      end
    ).

Definition log3ActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat) :=
  flatMap
  (removeAndReturnFromStackFiveItems state)
  (fun tup6 =>
    match tup6 with
    | (es, offset, length, topic0, topic1, topic2) =>
      match getSliceFromMap (getMemory_ES es) offset (wordToNat length) with
        | inl error => failWithErrorCode es error
        | inr logData  =>
          let log := Log3 topic0 topic1 topic2 logData  in
          let logs := getLog_ES es in
          let es2 := setLog_ES es logs in
            runningExecutionWithState  (es2, 4 * 375  + (List.length logData * 8 * 32))
        end
      end
    ).

Definition log4ActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat)  :=
  flatMap
  (removeAndReturnFromStackSixItems state)
  (fun tup6 =>
    match tup6 with
    | (es, offset, length, topic0, topic1, topic2, topic3) =>
      match getSliceFromMap (getMemory_ES es) offset (wordToNat length) with
        | inl error => failWithErrorCode es error
        | inr logData  =>
          let log := Log4 topic0 topic1 topic2 topic3 logData  in
          let logs := getLog_ES es in
          let es2 := setLog_ES es logs in
            runningExecutionWithState  (es2, 5 * 375  + (List.length logData * 8 * 32))
        end
      end
    ).

(*DELEGATECALL*)
(*SELFDESTRUCT*)
Definition expCost(pow: word WLen): nat :=
  if weqb pow WZero
  then 10%nat
  else 10%nat + 10%nat * (1%nat + ((log2Orzero pow)/ 8%nat)).

Definition expActionPure(state: ExecutionState): ExecutionResultOr (ExecutionState * nat)  :=
  flatMap
  (removeAndReturnFromStackTwoItems state)
    (fun tup3 =>
      match tup3 with
      | (es, a, pow) =>
        let resN := expmod (wordToN a) (wordToN pow) (wordModulus) in
        let res := NToWord WLen resN in
        attach (pushItemToExecutionStateStack es res) (expCost pow)
      end
    ).

Definition opcodeProgramStateChange(opc: SimplePriceOpcode)(state: ExecutionState)(ci: CallInfo)(gas pc: nat)(program: list OpCode): OpcodeApplicationResult :=
  match opc with
  | ADD	          => addActionPure state
  | MUL	          => mulActionPure state
  | SUB	          => subActionPure state
  | DIV	          => divActionPure state
  | SDIV	        => sdivActionPure state
  | MOD	          => modActionPure state
  | SMOD	        => smodActionPure state
  | ADDMOD	      => addmodActionPure state
  | MULMOD	      => mulmodActionPure state
  | SIGNEXTEND	  => signextendActionPure state
  | LT	          => ltActionPure state
  | GT	          => gtActionPure state
  | SLT	          => sltActionPure state
  | SGT	          => sgtActionPure state
  | EQ	          => eqActionPure state
  | ISZERO	      => iszeroActionPure state
  | AND	          => andActionPure state
  | OR	          => orActionPure state
  | XOR	          => xorActionPure state
  | NOT	          => notActionPure state
  | BYTE          => byteActionPure state
  | ADDRESS	      => addressActionPure state ci
  | BALANCE	      => balanceActionPure state ci
  | ORIGIN	      => originActionPure state ci
  | CALLER	      => callerActionPure state ci
  | CALLVALUE	    => callvalueActionPure state ci
  | CALLDATALOAD	=> calldataloadActionPure state ci
  | CALLDATASIZE	=> calldatasizeActionPure state ci
  | CODESIZE	    => codesizeActionPure state ci
  | GASPRICE	    => gaspriceActionPure state ci
  | EXTCODESIZE	  => exctcodesizeActionPure state ci
  | BLOCKHASH	    => blockhashActionPure state ci
  | COINBASE	    => coinbaseActionPure state ci
  | TIMESTAMP	    => timestampActionPure state ci
  | NUMBER	      => numberActionPure state ci
  | DIFFICULTY  	=> dificultyActionPure state ci
  | GASLIMIT	    => gaslimitActionPure state ci
  | POP	          => popActionPure state
  | MLOAD	        => mloadActionPure state
  | MSTORE	      => mstoreActionPure state
  | MSTORE8	      => mstore8ActionPure state
  | SLOAD	        => sloadActionPure state
  | PC	          => pcActionPure state pc
  | MSIZE	        => msizeActionPure state
  | GAS	          => gasActionPure state gas
  | JUMPDEST	    => runningExecutionWithState state
  | PUSH arg word	=> pushActionPure arg word state
  | DUP arg	      => dupActionPure arg state
  | SWAP	arg     => swapActionPure arg state
  | CREATE	      => failWithErrorCode state NotImplemented
  | JUMP          => jumpActionPure state program
  | JUMPI         => jumpiActionPure state program
(*   | _   => stopExecutionWithSuccess (state) *)
  end.

Definition opcodeProgramStateChangeComplex(opc: ComplexPriceOpcode)(state: ExecutionState)(ci: CallInfo)(gas pc: nat)(program: list OpCode): ExecutionResultOr (ExecutionState* nat) :=
  match opc with
  |	EXP           => expActionPure state
  |	SHA3          => failWithErrorCode state NotImplemented
  |	CALLDATACOPY  => calldatacopyActionPure state ci
  |	CODECOPY      => codecopyActionPure state ci
  |	EXTCODECOPY   => extcodecopyActionPure state ci
  |	SSTORE        => sstoreActionPure state
  |	LOG0          => log0ActionPure state
  |	LOG1          => log1ActionPure state
  |	LOG2          => log2ActionPure state
  |	LOG3          => log3ActionPure state
  |	LOG4          => log4ActionPure state
  |	CALL          => failWithErrorCode state NotImplemented
  |	CALLCODE      => failWithErrorCode state NotImplemented
  |	DELEGATECALL  => failWithErrorCode state NotImplemented
  |	SELFDESTRUCT  => failWithErrorCode state NotImplemented
  end.

(* Super ugly but i don't wan to bother with well-founded stuff.*)
(* Check Nat.eqb.
Check bool. *)

Fixpoint actOpcode(gas programCounter: nat)(ec: ExecutionState)(program: list OpCode)(callInfo: CallInfo){struct gas}: ExecutionResult :=
    match gas with
    | S predGas =>
      match (nth_error program programCounter) with
      | Some opc =>
        match opc with
        | STOP                        => inr (SuccessfulExecutionResultMk ec)
        |	RETURN	                    => returnActionPure ec
        | ComplexPriceOpcodeMk opcode =>
          match opcodeProgramStateChangeComplex opcode ec callInfo gas programCounter program with
          | inl result => inr (SuccessfulExecutionResultMk ec)
          | inr (updatedState, reducedGas) =>
            actOpcode (predGas - (reducedGas) - 1) (S programCounter) updatedState program callInfo
          end
        | SimplePriceOpcodeMk opcode  =>
          match opcodeProgramStateChange opcode ec callInfo gas programCounter program with
          | inl result       => result
          | inr updatedState => (* reduce gas and go on*)(* gas - gasCost = (gas - 1) - (gasCost - 1)*)
            actOpcode (predGas - ((simplePriceOpcodePrice opcode) -1)) (S programCounter) updatedState program callInfo
          end
        end
      | None     => inl (ErrorneousExecutionResultMk InvalidJumpDest ec)
      end
    | O         =>
      match (Nat.eqb programCounter (S(length program))) with
      | true  => inr (SuccessfulExecutionResultMk ec)
      | false => inl (ErrorneousExecutionResultMk  OutOfGas ec)
      end
    end.

Fixpoint actOpcodeWithInstructionsLimitation(maxinstructions gas programCounter: nat)(ec: ExecutionState)(program: list OpCode)(callInfo: CallInfo){struct maxinstructions}: ExecutionResult :=
    match maxinstructions with
    | S instructionsLeft =>
      match (nth_error program programCounter) with
      | Some opc =>
        match opc with
        | STOP                        => inr (SuccessfulExecutionResultMk ec)
        |	RETURN	                    => returnActionPure ec
        | ComplexPriceOpcodeMk opcode => inr (SuccessfulExecutionResultMk ec) (* TODO change to the opcodes implementation*)
        | SimplePriceOpcodeMk opcode  =>
          match opcodeProgramStateChange opcode ec callInfo gas programCounter program with
          | inl result       => result
          | inr updatedState => (* reduce gas and go on*)(* gas - gasCost = (gas - 1) - (gasCost - 1)*)
            let gasLeft := gas - (simplePriceOpcodePrice opcode) in
            let gasPositive := Nat.ltb (simplePriceOpcodePrice opcode) gas in
            let gasZero := Nat.eqb gas (simplePriceOpcodePrice opcode) in
            let over := Nat.eqb programCounter (S(length program)) in
              match (gasPositive, gasZero, over) with
              | (true, _, _)     => actOpcodeWithInstructionsLimitation (instructionsLeft)(gasLeft)(S programCounter) updatedState program callInfo
              | (_, true, true)  => inr (SuccessfulExecutionResultMk ec)
              | (false, _, _)    => inl (ErrorneousExecutionResultMk  OutOfGas ec)
              end

          end
        end
      | None     => inl (ErrorneousExecutionResultMk InvalidJumpDest ec)
      end
    | O         =>
      match (Nat.eqb programCounter (S(length program))) with
      | true  => inr (SuccessfulExecutionResultMk ec)
      | false => inl (ErrorneousExecutionResultMk  OutOfGas ec)
      end
    end.
(* Facts about opcodes *)

Definition rightProj{A B: Type}(s: A+B): option B :=
match s with
| inr b => Some b
| inl _ => None
end.

Lemma liftedSome{T: Type}: forall t1 t2: T, t1 = t2 <-> Some t1 = Some t2. Proof.
intros.
split.
intros.
rewrite H.
trivial.
intros.
injection H as H.
apply H.
Defined.

Lemma liftSome{T: Type}: forall t1 t2: T, t1 = t2 -> Some t1 = Some t2. Proof.
apply liftedSome.
Defined.

Lemma unliftSome{T: Type}: forall t1 t2: T, Some t1 = Some t2 -> t1 =t2. Proof.
apply liftedSome.
Defined.

Lemma listsEqualHeads{T: Type}: forall t1 t2: T, forall tail: list T, t1 :: tail = t2 :: tail <-> t1 = t2. Proof.
intros.
split.
intros.
injection H as H.
rewrite H.
trivial.
intros.
rewrite H.
trivial.
Defined.

Lemma listLengthApp{T: Type}: forall h: T, forall l t: list T, h :: t = l -> length l = S (length t). Proof.
intros.
intros.
rewrite <- H.
(* cut (forall T: Type, forall t: T, forall tail: list T, (t :: nil) ++ tail = t :: tail). *)
cut (h :: t = (h :: nil) ++ t). intros. rewrite H0. rewrite app_length.
cut (length (h :: nil) = 1). intros. rewrite H1.
trivial.
unfold length.
trivial.
unfold app.
trivial.
Defined.

Lemma natLtbPlusOne: forall n m: nat, n <? m = true -> S n <? S m = true.
Proof.
intros.
tauto.
Qed.

Lemma listAppLength{T: Type}: forall n: nat, forall h t l: list T, length l < n -> l = h ++ t -> length (t) < n. Proof.
intros.
rewrite H0 in H.
rewrite app_length in H.
lia.
Qed.

Lemma rightCrossover: forall n m: nat, n < m -> n <? m = true. Proof.
Admitted.

Lemma leftCrossover: forall n m: nat, n <? m = true -> n < m. Proof.
Admitted.
Ltac unfoldUtilDefinitions :=
unfold
mapO, rightProj,attach, "*",
getStack_ES, removeAndReturnFromStackOneItem, removeAndReturnFromStackTwoItems, removeAndReturnFromStackThreeItems, pushItemToExecutionStateStack,
getStack_ES, failWithErrorCode, runningExecutionWithState, setStack_ES, flatMap.

Ltac unfoldUtilDefinitionsIn H :=
unfold
mapO, rightProj, attach, "*",
getStack_ES, removeAndReturnFromStackOneItem, removeAndReturnFromStackTwoItems, removeAndReturnFromStackThreeItems, pushItemToExecutionStateStack, failWithErrorCode, runningExecutionWithState, setStack_ES, flatMap in H.

Ltac cutRewrite bla hname:=
cut(bla); only 1 : intro hname; only 1 :rewrite hname.

Ltac cutRewriteInL bla hname hnameTarg:=
cut(bla); only 1 : intro hname; only 1 : rewrite <- hname in hnameTarg.

Ltac cutRewriteInR bla hname hnameTarg:=
cut(bla); only 1 : intro hname; only 1 : rewrite -> hname in hnameTarg.

Theorem addActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := addActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(wplus w1 w2 :: tail).
Proof.
intros es w1 w2 tail preStack post postStack H H0.
destruct es.
subst preStack. subst postStack. subst post.
unfold addActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem mulActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := mulActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(wmult w1 w2 :: tail). Proof.
intros es w1 w2 tail preStack post postStack H H0.
destruct es.
subst preStack. subst postStack. subst post.
unfold mulActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem subActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := subActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(wordSubModulus w1 w2 :: tail). Proof.
intros es w1 w2 tail preStack post postStack H H0.
destruct es.
subst preStack. subst postStack. subst post.
unfold subActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem divActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := divActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(wdiv w1 w2 :: tail). Proof.
intros es w1 w2 tail preStack post postStack H H0.
destruct es.
subst preStack. subst postStack. subst post.
unfold divActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem sdivActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := sdivActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(wdivZ w1 w2 :: tail). Proof.
intros es w1 w2 tail preStack post postStack H H0.
destruct es.
subst preStack. subst postStack. subst post.
unfold sdivActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem modActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := modActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(wmod w1 w2 :: tail). Proof.
intros es w1 w2 tail preStack post postStack H H0.
destruct es.
subst preStack. subst postStack. subst post.
unfold modActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem smodActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := smodActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
let res := ZToWord WLen (Z.rem (wordToZ w1) (wordToZ w2)) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(res :: tail). Proof.
intros es w1 w2 tail preStack post postStack res H H0.
destruct es.
subst preStack. subst postStack. subst post. subst res.
unfold smodActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem addmodActionPureSuccess:
forall es: ExecutionState,
forall w1 w2 w3: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := addmodActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
let res := ZToWord WLen (Z.rem ((wordToZ w1) + (wordToZ w2)) (Z.of_N (wordToN w3))) in
length preStack < 1024 -> preStack = w1 :: w2 :: w3 :: tail ->
postStack = Some(res  :: tail). Proof.
intros es w1 w2 w3 tail preStack post postStack res H H0.
destruct es.
subst preStack. subst postStack. subst post. subst res.
unfold addmodActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: w3 :: nil) ++ tail = w1 :: w2 :: w3 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: w3 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem mulmodActionPureSuccess:
forall es: ExecutionState,
forall w1 w2 w3: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := mulmodActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
let res := ZToWord WLen (Z.rem ((wordToZ w1) * (wordToZ w2)) (Z.of_N (wordToN w3))) in
length preStack < 1024 -> preStack = w1 :: w2 :: w3 :: tail ->
postStack = Some(res  :: tail). Proof.
intros es w1 w2 w3 tail preStack post postStack res H H0.
destruct es.
subst preStack. subst postStack. subst post. subst res.
unfold mulmodActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
cutRewrite (length tail <? 1024 = true) H1.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: w3 :: nil) ++ tail = w1 :: w2 :: w3 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: w3 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem expActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let post := expActionPure es in
let postStack := mapO (rightProj post) (fst * getStack_ES) in
let res := NToWord WLen (expmod (wordToN w1) (wordToN w2) (wordModulus)) in
length preStack < 1024 -> preStack = w1 :: w2 :: tail ->
postStack = Some(res :: tail). Proof.
intros es w1 w2 tail preStack post postStack res H H0.
destruct es.
subst preStack. subst postStack. subst post. subst res.
unfold expActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
unfold "*" .
unfold fst.
cutRewrite (length tail <? 1024 = true) H1.
unfold map.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H1 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.

Theorem signextendActionPureSuccess:
forall es: ExecutionState,
forall w1 w2: EVMWord,
forall tail: list EVMWord,
let preStack := getStack_ES es in
let b := rightProj (extractByteAsNat w2) in
let res := mapO b (fun bb => sextWordBytes w1 bb) in
let post := signextendActionPure es in
let postStack := mapO (rightProj post) (getStack_ES) in
length preStack < 1024 -> weqb (wlshift' w2 8%nat) WZero = true -> preStack = w1 :: w2 :: tail ->
postStack = mapO res (fun h => h :: tail). Proof.
intros es w1 w2 tail preStack b res post postStack H H1 H0.
destruct es.
subst preStack. subst postStack. subst post. subst res. subst b.
unfold signextendActionPure.
unfoldUtilDefinitions.
unfoldUtilDefinitionsIn H.
unfoldUtilDefinitionsIn H0.
rewrite H0.
unfold extractByteAsNat.
rewrite H1.
cutRewrite (length tail <? 1024 = true) H2.
rewrite <- liftedSome.
rewrite listsEqualHeads.
trivial.
cutRewriteInL ((w1 :: w2 :: nil) ++ tail = w1 :: w2 :: tail) H2 H0. rewrite H0 in H.
rewrite rightCrossover. trivial.
apply (listAppLength 1024 (w1 :: w2 :: nil) tail l).
rewrite <- H0 in H.
apply H.
assumption.
unfold "++".
trivial.
Qed.


Require Export Andasl.
Require Export Andasr.
Section ml.
Variables A B C:Prop.
Theorem Andas: and (and A B) C <-> and A (and B C).
Proof.
    split.
    (* intro H0. *)
    apply Andasl.
    (* assumption. *)
    (* intro H1. *)
    apply Andasr.
    (* assumption. *)
Qed.
End ml.

Check Andas.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (x : natural) (y : natural) : natural := plus (Succ x) y.


Require Import Omega.
Require Import ineqchain.
Require Import Coq.Classes.Morphisms.

Fixpoint ack (x y : nat) : nat :=
  match x with
  | 0 => S y
  | S x' => let fix ackn (y : nat) :=
               match y with
               | 0 => ack x' 1
               | S y' => ack x' (ackn y')
               end
           in ackn y
  end.

Proposition ack_1_y_eq_SSy :
  forall (y : nat), ack 1 y = S (S y).
Proof.
  induction y.
  - @ goal : (ack 1 0 = 2).
    Left
    = 2.
    = Right.
  - @ goal : (ack 1 (S y) = S (S (S y))).
    @ IHy  : (ack 1 y = S (S y)).
    Left
    = (ack 1 (S y)).
    = (ack 0 (ack 1 y)).
    = (ack 0 (S (S y)))      { by IHy }.
    = (S (S (S y))).
    = Right.
Qed.

Proposition ack_SSy_le_ack_Sx_y :
  forall (x y : nat), S (S y) <= ack (S x) y.
Proof.
  induction x.
  - intros y.
    @ goal : (S (S y) <= ack 1 y).
    Left
    = (S (S y)).
    = (ack 1 y)   { by ack_1_y_eq_SSy }.
    = Right.
  - induction y.
    + @ goal : (2 <= ack (S (S x)) 0).
      @ IHx :
        (forall y : nat, S (S y) <= ack (S x) y).
      Right
      =  (ack (S (S x)) 0).
      =  (ack (S x) 1).
      >= (S (S 1))         { by IHx }.
      >= 2                 { omega }.
      = Left.
    + @ goal :
        (S (S (S y)) <= ack (S (S x)) (S y)).
      @ IHx  :
        (forall y : nat, S (S y) <= ack (S x) y).
      @ IHy  :
        (S (S y) <= ack (S (S x)) y).
      Right
      =  (ack (S (S x)) (S y)).
      =  (ack (S x) (ack (S (S x)) y)).
      >= (S (S (ack (S (S x)) y))) { by IHx }.
      >= (S (S (S (S y))))         { by IHy }.
      >= (S (S (S y)))             { omega }.
      = Left.
Qed.

Proposition Sy_le_ack_x_y :
  forall (x y : nat), y < ack x y.
Proof.
  induction x.
  - intros y.
    @ goal : (y < ack 0 y).
    Left
    = y.
    < (S y)            { omega }.
    = Right.
  - intros y.
    @ goal : (y < ack (S x) y).
    Right
    =  (ack (S x) y).
    >= (S (S y))       { by ack_SSy_le_ack_Sx_y }.
    >  y               { omega }.
    = Left.
Qed.

Proposition ack_x_y_lt_ack_x_Sy :
  forall (x y : nat), ack x y < ack x (S y).
Proof.
  induction x.
  - intros y.
    @ goal : (ack 0 y < ack 0 (S y)).
    Right
    = (ack 0 (S y)).
    = (S (S y)).
    > (S y)  { omega }.
    = (ack 0 y).
    = Left.
  - intros y.
    @ goal : (ack (S x) y < ack (S x) (S y)).
    Right
    =  (ack (S x) (S y)).
    =  (ack x (ack (S x) y)).
    >  (ack (S x) y)     { by Sy_le_ack_x_y }.
    =  Left.
Qed.

Program Instance ack_monotone_y : Proper (eq ++> le ++> le) (ack).
Next Obligation.
Proof.
  unfold respectful.
  intros x y H x0 y0 H0.
  rewrite H.
  induction H0.
  - reflexivity.
  - Left
    =  (ack y x0).
    <= (ack y m)     { by IHle }.
    <= (ack y (S m)) { by ack_x_y_lt_ack_x_Sy }.
    =  Right.
Qed.

Proposition ack_x_Sy_le_ack_Sx_y :
  forall (x y : nat), ack x (S y) <= ack (S x) y.
Proof.
  intros x y; revert x.
  induction y.
  - intros x.
    @ goal : (ack x 1 <= ack (S x) 0).
    Left
    = (ack (S x) 0).
    = (ack x 1).
    = Right.
  - intros x.
    @ goal : (ack x (S (S y)) <= ack (S x) (S y)).
    @ IHy  : (forall x : nat, ack x (S y) <= ack (S x) y).
    Left
    =  (ack x (S (S y))).
    <= (ack x (ack (S x) y))  { by ack_SSy_le_ack_Sx_y }.
    =  (ack (S x) (S y)).
    =  Right.
Qed.

Proposition ack_x_y_le_ack_Sx_y :
  forall (x y : nat), ack x y < ack (S x) y.
Proof.
  intros x y.
  Left
  =  (ack x y).
  <  (ack x (S y)) { by ack_x_y_lt_ack_x_Sy }.
  <= (ack (S x) y) { by ack_x_Sy_le_ack_Sx_y }.
  =  Right.
Qed.

Program Instance ack_monotone_x : Proper (le ++> eq ++> le) (ack).
Next Obligation.
Proof.
  unfold respectful.
  intros x y H x0 y0 H0.
  rewrite H0.
  induction H.
  - reflexivity.
  - Left
    =  (ack x y0).
    <= (ack m y0)     { by IHle }.
    <= (ack (S m) y0) { by ack_x_y_le_ack_Sx_y }.
    =  Right.
Qed.

Proposition ack_c1_ack_c2_x_le_ack_c3_x :
  forall (x c1 c2 : nat), exists (c3 : nat),
      ack c1 (ack c2 x) <= ack c3 x.
Proof.
  intros x c1 c2.
  exists (S (S (max c1 c2))).
  Left
  =  (ack c1 (ack c2 x)).
  <= (ack (max c1 c2) (ack c2 x))
       { because (c1 <= max c1 c2) by (apply Nat.le_max_l) }.
  <= (ack (max c1 c2) (ack (S (max c1 c2)) x))
       { because (c2 <= S (max c1 c2)) by (rewrite <- Nat.le_max_r; omega) }.
  =  (ack (S (max c1 c2)) (S x)).
  <= (ack (S (S (max c1 c2))) x)  { by ack_x_Sy_le_ack_Sx_y }.
  =  Right.
Qed.


CoInductive CoNat : Set :=
| Zero : CoNat
| Succ : CoNat -> CoNat.

CoInductive CoEq : CoNat -> CoNat -> Prop :=
| coeq_base : CoEq Zero Zero
| coeq_next : forall x y, CoEq x y -> CoEq (Succ x) (Succ y).

(* assists with deconstruction in proofs *)
Definition decomp (x : CoNat) : CoNat :=
  match x with
    | Zero => Zero
    | Succ x' => Succ x'
  end.

Lemma decomp_eql : forall x, x = decomp x.
  intro x. case x. simpl. auto.
  intros. simpl. auto.
Defined.

CoFixpoint plus (x: CoNat) (y: CoNat) : CoNat :=
  match x with
    | Zero => y
    | Succ x' => Succ (plus x' y)
  end.

Require Import List.
Fixpoint sum (xs:list CoNat) : CoNat :=
  match xs with
    | nil => Zero
    | cons x xs' => plus x (sum xs')
  end.

CoInductive CoList : Set :=
| CoNil : CoList
| CoCons : CoNat -> CoList -> CoList.

Definition decompl (xs : CoList) : CoList :=
  match xs with
    | CoNil => CoNil
    | CoCons x' xs' => CoCons x' xs'
  end.

Lemma decompl_eql : forall x, x = decompl x.
  intro x. case x. simpl. auto.
  intros. simpl. auto.
Defined.

(*
CoFixpoint sumlen (xs: CoList) : CoNat :=
  match xs with
    | CoNil => Zero
    | CoCons x' xs' => Succ (plus x' (sumlen xs'))
  end.
*)

CoFixpoint f (x : CoNat) (xs : CoList) :=
  match x with
    | Zero => match xs with
                | CoNil => Zero
                | CoCons x' xs' => Succ (f x' xs')
              end
    | Succ x' => Succ (f x' xs)
  end.

Definition sumlen (xs : CoList) :=
  match xs with
    | CoNil => Zero
    | CoCons x' xs' => Succ (f x' xs')
  end.

CoFixpoint f (x : CoNat) (xs : CoList) :=
  match x with
    | Zero => match xs with
                | CoNil => Zero
                | CoCons x' xs' => Succ (f x' xs')
              end
    | Succ x' => Succ (f x' xs)
  end.

Definition sum (xs : List) :=
  match xs with
    | CoNil => Zero
    | CoCons x' xs' => Succ (f x' xs')
  end.

Infix "::" := CoCons (at level 60, right associativity).

Lemma test : sumlen (Zero::Zero::(Succ((Succ(Zero))))::CoNil) = Succ(Succ(Succ(Zero))).
Proof.
  intros. rewrite (decomp_eql (sumlen (Zero :: Zero :: Succ (Succ Zero) ::CoNil))). simpl.
  rewrite (decomp_eql (f Zero (Zero :: Succ (Succ Zero) :: CoNil))). simpl.
  rewrite (decomp_eql (f Zero (Succ (Succ Zero) :: CoNil))). simpl.
  rewrite (decomp_eql (f (Succ (Succ Zero)) CoNil)). simpl.
  rewrite (decomp_eql (f (Succ Zero) CoNil)). simpl.
  rewrite (decomp_eql (f Zero CoNil)). simpl.

g = (% x'. (% xs'. (case x' of
                      | Succ(x') => Succ(((g x') xs'))
                      | Zero => (f xs'))));
f = (% xs. (case xs of
              | Cons(x',xs') => case x' of
                                  | Zero => Succ(f xs')
                                  | Succ(x') => Succ(Succ(g x' xs'))
              | Nil => Zero));


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section weak_inverse_projection_postulate_bachmann_s_lotschnittaxiom.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Formalization of a proof from Bachmann's article "Zur Parallelenfrage" *)

Lemma weak_inverse_projection_postulate__bachmann_s_lotschnittaxiom :
  weak_inverse_projection_postulate -> bachmann_s_lotschnittaxiom.
Proof.
intro hrap.
cut (forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD,
        Perp A1 A2 B1 B2 -> Perp A1 A2 C1 C2 -> Perp B1 B2 D1 D2 ->
        Col A1 A2 IAB -> Col B1 B2 IAB ->
        Col A1 A2 IAC -> Col C1 C2 IAC ->
        Col B1 B2 IBD -> Col D1 D2 IBD ->
        Coplanar IAB IAC IBD C1 -> Coplanar IAB IAC IBD C2 ->
        Coplanar IAB IAC IBD D1 -> Coplanar IAB IAC IBD D2 ->
       ~ Col IAB IAC IBD ->
        exists I, Col C1 C2 I /\ Col D1 D2 I).

  {
  clear hrap; intro lotschnitt.
  intros P Q R P1 R1 HPQ HQR HPerQ HPerP HPerR HCop1 HCop2.
  destruct (eq_dec_points P P1).
    subst; exists R; Col.
  destruct (eq_dec_points R R1).
    subst; exists P; Col.
  assert (HNCol : ~ Col P Q R) by (apply per_not_col; auto).
  destruct (lotschnitt P Q Q R P P1 R R1 Q P R) as [S [HS1 HS2]]; Col; Perp; Cop.
  exists S; auto.
  }

  {
  intros A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD HPerpAB HPerpAC HPerpBD.
  intros HCol1 HCol2 HCol3 HCol4 HCol5 HCol6 HCop1 HCop2 HCop3 HCop4 HNC1.
  assert (Col IAB IAC A1) by (assert_diffs; ColR).
  assert (Col IAB IAC A2) by (assert_diffs; ColR).
  assert (Col IAB IBD B1) by (assert_diffs; ColR).
  assert (Col IAB IBD B2) by (assert_diffs; ColR).
  assert (Coplanar IAB IAC IBD A1) by Cop.
  assert (Coplanar IAB IAC IBD A2) by Cop.
  assert (Coplanar IAB IAC IBD B1) by Cop.
  assert (Coplanar IAB IAC IBD B2) by Cop.
  assert (HNC2 : ~ Col A1 A2 D1).
    {
    apply par_strict_not_col_1 with D2; apply par_not_col_strict with IBD;
    Col; try (intro; apply HNC1; assert_diffs; ColR).
    apply l12_9 with B1 B2; Perp; CopR.
    }
  assert (HNC3 : ~ Col B1 B2 C1).
    {
    apply par_strict_not_col_1 with C2; apply par_not_col_strict with IAC;
    Col; try (intro; apply HNC1; assert_diffs; ColR).
    apply l12_9 with A1 A2; Perp; CopR.
    }
  assert (HParA : Par_strict A1 A2 D1 D2).
    apply par_not_col_strict with D1; Col; apply l12_9 with B1 B2; Perp; CopR.
  assert (HParB : Par_strict B1 B2 C1 C2).
    apply par_not_col_strict with C1; Col; apply l12_9 with A1 A2; Perp; CopR.
  assert (HNCol3 : ~ Col IAC B1 B2) by (apply par_not_col with C1 C2; Par; ColR).
  assert (HNCol4 : ~ Col IBD A1 A2) by (apply par_not_col with D1 D2; Par; ColR).
  assert (HNCol5 : ~ Col IAB C1 C2) by (apply par_not_col with B1 B2; Par; ColR).
  assert (HNCol6 : ~ Col IAB D1 D2) by (apply par_not_col with A1 A2; Par; ColR).
  assert (HPQ : IAC <> IAB) by (assert_diffs; auto).
  assert (HQR : IAB <> IBD) by (assert_diffs; auto).
  rename IAB into Q; rename IAC into P; rename IBD into R.
  assert (Per P Q R).
    {
    apply perp_per_2; apply perp_col2 with A1 A2; Col;
    apply perp_sym; apply perp_col2 with B1 B2; Col; Perp.
    }
  assert (HNCol7 : ~ Col P Q R) by (apply per_not_col; trivial).
  destruct (angle_bisector P Q R) as [M [HM1 HM2]]; auto.
  assert (HSuma : SumA P Q M P Q M P Q R).
    assert_diffs; apply conga3_suma__suma with P Q M M Q R P Q R; CongA; SumA.
  assert (HAcute : Acute P Q M).
  { apply nbet_sams_suma__acute with P Q R; auto.
      intro HBet; apply HNCol7; Col.
    destruct (sams_dec P Q M P Q M); trivial.
    assert_diffs.
    exfalso; apply (lea__nlta P Q M P Q R).
      exists M; split; CongA.
    apply obtuse_per__lta; trivial.
    apply nsams__obtuse; auto.
  }

  assert (HC3 : exists C3, Col C1 C2 C3 /\ OS P Q R C3).
  { destruct (diff_col_ex3 C1 C2 P) as [C0]; Col; spliter.
    destruct (cop_not_par_same_side P Q C0 P P R) as [C3 []]; Col.
      intro; apply HNCol5; ColR.
      assert (Coplanar P Q R C0); [|Cop].
      assert_diffs; apply col_cop2__cop with C1 C2; Col; Cop.
    exists C3; split; trivial; ColR.
  }
  destruct HC3 as [C3 [HCol7 HOS1]].
  destruct (hrap P Q M P Q R P C3) as [S [HS1 HS2]]; trivial.
    apply out_trivial; auto.
    assert_diffs; auto.
    assert (HP := HPerpAC); destruct HP as [P' [_ [_ [HP1 [HP2 HP3]]]]].
    assert (P = P'); [|treat_equalities; apply HP3; Col].
    elim (perp_not_col2 _ _ _ _ HPerpAC); intro; assert_diffs;
    [apply l6_21 with A1 A2 C1 C2|apply l6_21 with A1 A2 C2 C1]; Col.
    assert (Coplanar P Q R M) by Cop.
    assert (Coplanar P Q R C3); [|CopR].
    assert_diffs; apply col_cop2__cop with C1 C2; Col; Cop.

  assert (HD3 : exists D3, Col D1 D2 D3 /\ OS R Q P D3).
  { destruct (diff_col_ex3 D1 D2 R) as [D0]; Col; spliter.
    destruct (cop_not_par_same_side R Q D0 R R P) as [D3 []]; Col.
      intro; apply HNCol6; ColR.
      assert (Coplanar P Q R D0); [|CopR].
      assert_diffs; apply col_cop2__cop with D1 D2; Col; Cop.
    exists D3; split; trivial; ColR.
  }
  destruct HD3 as [D3 [HCol8 HOS2]].
  destruct (hrap R Q M R Q P R D3) as [T [HT1 HT2]]; Perp.
    apply (acute_conga__acute P Q M); CongA.
    assert_diffs; apply conga3_suma__suma with P Q M P Q M P Q R; CongA.
    apply out_trivial; auto.
    assert_diffs; auto.
    assert (HP := HPerpBD); destruct HP as [R' [_ [_ [HR1 [HR2 HR3]]]]].
    assert (R = R'); [|treat_equalities; apply HR3; Col].
    elim (perp_not_col2 _ _ _ _ HPerpBD); intro; assert_diffs;
    [apply l6_21 with B1 B2 D1 D2|apply l6_21 with B1 B2 D2 D1]; Col.
    assert (Coplanar P Q R M) by Cop.
    assert (Coplanar P Q R D3); [|CopR].
    assert_diffs; apply col_cop2__cop with D1 D2; Col; Cop.

  assert (HOut : Out Q S T) by (apply l6_7 with M; trivial; apply l6_6; assumption).
  assert (HCol9 : Col C1 C2 S) by (assert_diffs; ColR).
  assert (HCol10 : Col D1 D2 T) by (assert_diffs; ColR).
  destruct (col_dec C1 C2 T).
    exists T; Col.
  destruct (col_dec D1 D2 S).
    exists S; Col.
  destruct HOut as [HSQ [HTQ [HBet|HBet]]].
  - assert (HTS : TS C1 C2 R T).
      apply l9_8_2 with Q.
      repeat split; Col; exists S; Col.
      apply l12_6, par_strict_col2_par_strict with B1 B2; Par; Col.
    assert_diffs.
    destruct HTS as [_ [_ [I [HI1 HI2]]]].
    exists I; split; ColR.
  - assert (HTS : TS D1 D2 P S).
      apply l9_8_2 with Q.
      repeat split; Col; exists T; Col.
      apply l12_6, par_strict_col2_par_strict with A1 A2; Par; Col.
    assert_diffs.
    destruct HTS as [_ [_ [I [HI1 HI2]]]].
    exists I; split; ColR.
  }
Qed.

End weak_inverse_projection_postulate_bachmann_s_lotschnittaxiom.


Require Import Tapl.Stlc.Base.

(* Our presentation of simply typed lambda calculus has a single base type, Unit. *)
Inductive type : Type :=
  | ty_unit  : type
  | ty_arrow : type → type → type.

Inductive term : Type :=
  | tm_var  : nat → term
  | tm_abs  : type → term → term
  | tm_app  : term → term → term
  | tm_unit : term.

Coercion tm_var : nat >-> term.

(* Values *)

Definition context := list type.
Inductive wf : context -> term -> Prop :=
  | wf_var  : forall G i,
         (exists T, get i G = Some T)
      -> wf G (tm_var i)
  | wf_abs  : forall G T t,
         wf (T :: G) t
      -> wf G (tm_abs T t)
  | wf_app  : forall G t1 t2,
         wf G t1
      -> wf G t2
      -> wf G (tm_app t1 t2)
  | wf_unit : forall G,
      wf G tm_unit.
Global Hint Constructors wf : core.

Definition closed (t: term) := wf nil t.

Inductive wnfX : term → Prop :=
  | wnf_val : ∀ T t, wnfX (tm_abs T t)
  | wnf_unit : wnfX tm_unit.
Global Hint Constructors wnfX : core.

Definition value (t : term) := wnfX t ∧ closed t.

(* Substitution *)

(* lift shifts all the free variables over by 1 *)

Fixpoint lift (k : nat) (t : term) :=
  match t with
  | tm_var i => match compare i k with
                | Lt => tm_var i
                | _  => tm_var (S i)
                end
  | tm_abs T t' => tm_abs T (lift (S k) t')
  | tm_app t1 t2 => tm_app (lift k t1) (lift k t2)
  | tm_unit => tm_unit
  end.

(*
Fixpoint lift (k : nat) (t : term) :=
  match t with
  | tm_var i => if leb k i
                then tm_var (S i)
                else tm_var i
  | tm_abs T t' => tm_abs T (lift (S k) t')
  | tm_app t1 t2 => tm_app (lift k t1) (lift k t2)
  | tm_unit => tm_unit
  end.
*)
(* [k -> s]t *)
(* substX replaces the k'th free variable with s in t.
   if s has free variables, s is lifted when substituting over binders to make sure the free variables in s are correct.
   All free variables j > k are shifted down one, to account for the fact that the k'th free variable has been substituted.
*)
Fixpoint substX (k : nat) (s : term) (t : term) :=
  match t with
  | tm_var i => match compare i k with
                | Eq => s
                | Lt => tm_var i
                | Gt => tm_var (pred i)
                end
  | tm_abs T t' => tm_abs T (substX (S k) (lift 0 s) t')
  | tm_app t1 t2 => tm_app (substX k s t1) (substX k s t2)
  | tm_unit => tm_unit
  end.

(* Examples *)
(* [0 -> (λ.T 0)] (1 0 2) = 0 (λ.T 0) 1*)
Example ex1 : substX 0 (tm_abs ty_unit 0) (tm_app (tm_app 1 0) 2)
            = tm_app (tm_app 0 (tm_abs ty_unit 0)) 1.
Proof.
  simpl. reflexivity.
Qed.

(* Evaluation *)

Reserved Notation "t '-->' t'" (at level 40).
Inductive step : term -> term -> Prop :=
  | st_app1 : forall t1 t1' t2,
      t1 --> t1' ->
      tm_app t1 t2 --> tm_app t1' t2
  | st_app2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      tm_app v1 t2 --> tm_app v1 t2'
  | st_appAbs : forall T t1 v2,
      value v2 ->
      tm_app (tm_abs T t1) v2 --> substX 0 v2 t1

where "t '-->' t'" := (step t t').
Global Hint Constructors step : core.

(* multi_step is the reflexive/transitive closure of the step relation *)

Definition multi_step := multi_rel step.
Notation "t '-->*' t'" := (multi_step t t') (at level 40).
(*
Inductive multi_step : term -> term -> Prop :=
  | ms_refl : forall t,
      t -->* t
  | ms_trans : forall t1 t2 t3,
      t1 --> t2 ->
      t2 -->* t3 ->
      t1 -->* t3
where "t '-->*' t'" := (multi_step t t').
*)


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Simple properties about Kleene algebras *)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import Monoid.
Require Import SemiLattice.
Require Import SemiRing.

Set Implicit Arguments.
Unset Strict Implicit.

Section Props0.

  Context `{KA: KleeneAlgebra}.

  (** other induction schemes  *)
  Lemma star_destruct_right_old A B: forall (a: X A A) (b c: X B A), b+c*a <== c  ->  b*a# <== c.
  Proof.
    intros; transitivity (c*a#).
     rewrite <- H; semiring_reflexivity.
     apply star_destruct_right.
     rewrite <- H at -1; auto with algebra.
  Qed.

  Lemma star_destruct_left_old A B: forall (a: X A A) (b c: X A B), b+a*c <== c  ->  a#*b <== c.
  Proof.
    intros; transitivity (a#*c).
     rewrite <- H; semiring_reflexivity.
     apply star_destruct_left.
     rewrite <- H at -1; auto with algebra.
  Qed.

  Lemma star_destruct_right_one A: forall (a c: X A A), 1+c*a <== c  ->  a# <== c.
  Proof.
    intros. rewrite <- (dot_neutral_left (a#)).
    apply star_destruct_right_old. assumption.
  Qed.

  Lemma star_destruct_left_one A: forall (a c: X A A), 1+a*c <== c  ->  a# <== c.
  Proof.
    intros. rewrite <- (dot_neutral_right (a#)).
    apply star_destruct_left_old. assumption.
  Qed.

End Props0.

(** simple tactics to run an induction without having to remember which scheme to use  *)
Ltac star_left_induction :=
  first [ apply star_destruct_left |
          apply star_destruct_left_old |
          apply star_destruct_left_one ].

Ltac star_right_induction :=
  first [ apply star_destruct_right |
          apply star_destruct_right_old |
          apply star_destruct_right_one ].

(** simple properties  *)
Section Props1.

  Context `{KA: KleeneAlgebra}.
  Variable A: T.

  Global Instance star_incr:
  Proper ((leq A A) ==> (leq A A)) (star A).
  Proof.
    intros a b H.
    star_right_induction.
    rewrite H. rewrite star_make_left. reflexivity.
  Qed.

  Global Instance star_compat: Proper ((equal A A) ==> (equal A A)) (star A).
  Proof.
    intros a b H. apply leq_antisym; apply star_incr; apply equal_leq; auto.
  Qed.

  Lemma one_leq_star_a (a: X A A): 1 <== a#.
  Proof.
    rewrite <- star_make_left; auto with algebra.
  Qed.

  Lemma a_leq_star_a (a: X A A): a <== a#.
  Proof.
    rewrite <- star_make_left.
    rewrite <- one_leq_star_a.
    semiring_reflexivity.
  Qed.

  Lemma star_mon_is_one (a: X A A): a <== 1 -> a# == 1.
  Proof.
    intro H.
    apply leq_antisym.
    star_left_induction.
    rewrite H; semiring_reflexivity.
    apply one_leq_star_a.
  Qed.

  Lemma star_one: (1#: X A A) == 1.
  Proof.
    apply star_mon_is_one; reflexivity.
  Qed.

  Lemma star_zero: (0#: X A A) == 1.
  Proof.
    apply star_mon_is_one; apply zero_inf.
  Qed.

  Lemma star_a_a_leq_star_a (a: X A A): a#*a <== a#.
  Proof.
    rewrite <- star_make_left at 2.
    semiring_reflexivity.
  Qed.

  Lemma a_star_a_leq_star_a_a (a: X A A): a*a# <== a#*a.
  Proof.
    star_right_induction.
    rewrite star_a_a_leq_star_a at 1.
    apply plus_destruct_leq; auto.
    rewrite <- one_leq_star_a. semiring_reflexivity.
  Qed.

  Lemma star_make_right (a:X A A): 1+a*a# == a#.
  Proof.
    apply leq_antisym.
    rewrite a_star_a_leq_star_a_a.
    apply plus_destruct_leq.
    apply one_leq_star_a.
    apply star_a_a_leq_star_a.

    star_right_induction.
    rewrite <- star_make_left at 2.
    semiring_reflexivity.
  Qed.

End Props1.

(** hints *)
Global Hint Extern 1 (equal _ _ _ _) => apply star_compat; instantiate: compat algebra.
Global Hint Extern 0 (equal _ _ _ _) => apply star_make_left: algebra.
Global Hint Extern 0 (equal _ _ _ _) => apply star_make_right: algebra.
Global Hint Extern 0 (equal _ _ _ _) => apply star_one: algebra.
Global Hint Extern 0 (equal _ _ _ _) => apply star_zero: algebra.
Global Hint Extern 0 (leq _ _ _ _) => apply a_leq_star_a: algebra.
Global Hint Extern 0 (leq _ _ _ _) => apply one_leq_star_a: algebra.

Hint Rewrite @star_zero @star_one using ti_auto : simpl.
Hint Rewrite @star_mon_is_one using ti_auto : simpl.

(** dual Kleene algebra *)
Module Dual. Section Protect.
  Existing Instance Classes.Dual.Monoid_Ops.
  Existing Instance Classes.Dual.SemiLattice_Ops.
  Existing Instance Classes.Dual.Star_Op.
  Instance KleeneAlgebra `{KA: KleeneAlgebra}: KleeneAlgebra (Dual.Graph G).
  Proof.
    constructor.
    apply (@Dual.IdemSemiRing G). eauto with typeclass_instances.
    exact (@star_make_right _ _ _ _ KA).
    exact (@star_destruct_right _ _ _ _ KA).
    exact (@star_destruct_left _ _ _ _ KA).
  Defined.

End Protect. End Dual.

(** more properties  *)
Section Props2.
  Context `{KA: KleeneAlgebra}.
  Variable A: T.

  Lemma star_trans (a: X A A): a#*a# == a#.
  Proof.
    apply leq_antisym.
    star_right_induction.
    rewrite star_a_a_leq_star_a. reflexivity.
    rewrite <- one_leq_star_a at 3. semiring_reflexivity.
  Qed.

  Lemma star_idem (a: X A A): a## == a#.
  Proof.
    apply leq_antisym.
    star_right_induction.
    rewrite star_trans.
    rewrite (one_leq_star_a a). auto with algebra.
    apply a_leq_star_a.
  Qed.

  Lemma a_star_a_leq_star_a: forall (a: X A A), a*a# <== a#.
  Proof.
    exact (star_a_a_leq_star_a (KA:=Dual.KleeneAlgebra) (A:=A)).
  Qed.

  Lemma star_distr (a b: X A A): (a + b)# == a# * (b*a#)#.
  Proof.
    apply leq_antisym.

    star_left_induction.

    semiring_normalize.
    ac_rewrite (star_make_right (b*a#)).
    rewrite <- (star_make_right a) at 4.
    semiring_reflexivity.

    rewrite <- (star_trans (a+b)).
    apply dot_incr.
     apply star_incr. auto with algebra.
     rewrite <- (star_idem (a+b)). apply star_incr.
    rewrite <- (a_star_a_leq_star_a (a+b)).
    apply dot_incr. auto with algebra.
    apply star_incr. auto with algebra.
  Qed.

  Lemma semicomm_iter_right B (a: X A A) (b: X B B) (c: X B A): c*a <== b*c -> c*a# <== b#*c.
  Proof.
    intro H.
    star_right_induction.
    monoid_rewrite H.
    rewrite <- star_make_left at 2.
    semiring_reflexivity.
  Qed.

  Lemma wsemicomm_iter_right (a b : X A A): a*b <== b#*a  ->  a*b# <== b#*a.
  Proof.
    intros H.
    rewrite <- star_idem at 2.
    apply semicomm_iter_right; assumption.
  Qed.

End Props2.

Global Hint Extern 1 (leq _ _ _ _) => apply star_incr: compat algebra.
Global Hint Extern 0 (equal _ _ _ _) => apply star_idem: algebra.
Global Hint Extern 0 (equal _ _ _ _) => apply star_trans: algebra.

(** more properties, by duality  *)
Section Props3.
  Context `{KA: KleeneAlgebra}.

  Lemma semicomm_iter_left: forall A B (a: X A A) (b: X B B) (c: X A B), a*c <== c*b -> a#*c <== c*b#.
  Proof.
    exact (semicomm_iter_right (KA:=Dual.KleeneAlgebra)).
  Qed.

  Lemma wsemicomm_iter_left: forall A (b a : X A A), a*b <== b*a#  ->  a#*b <== b*a#.
  Proof.
    exact (wsemicomm_iter_right (KA:=Dual.KleeneAlgebra)).
  Qed.

  Lemma comm_iter_left A B (x : X A B) a b:  a * x == x * b -> a# * x == x * b# .
  Proof.
    intro H.
    apply leq_antisym.
    apply semicomm_iter_left, equal_leq. trivial.
    apply semicomm_iter_right, equal_leq. auto.
  Qed.

  Lemma move_star A (a: X A A): a#*a == a*a#.
  Proof. apply comm_iter_left; reflexivity. Qed.

  Lemma move_star2 A B (a: X A B) (b: X B A): (a*b)#*a == a*(b*a)#.
  Proof. apply comm_iter_left. semiring_reflexivity. Qed.

End Props3.

Section Props4.
  Context `{KA: KleeneAlgebra}.

  Lemma comm_iter_right: forall B A (x : X A B) a b,  x * a == b * x -> x * a# == b# * x .
  Proof.
    exact (comm_iter_left (KA:=Dual.KleeneAlgebra)).
  Qed.

End Props4.


Require Import String.
Definition goal := "tesst assures of boolean xor function"%string.

Definition xor (b1 b2 : bool) : bool :=
  match (b1,b2) with
  | (true,  true) => false
  | (false, false) => false
  | _ => true
  end.

(*fasle, false should be false*)
Fact xor1: xor false false = false.
Proof. simpl. reflexivity. Qed.

(*false, true should be true*)
Fact xor2: xor false true = true.
Proof. simpl. reflexivity. Qed.

(*false, false should be false*)
Fact xor3: xor true false = true.
Proof. simpl. reflexivity. Qed.

(*true, true should be false*)
Fact xor4: xor true true = false.
Proof. simpl. reflexivity. Qed.

Require Import String.
Print goal.