(** * Laws about an exponential of a product and a product of exponentials *)
Require Import Category.Core Functor.Core.
Require Import Functor.Prod.
Require Import Functor.Paths.
Require Import Functor.Identity Functor.Composition.Core.
Require Import ExponentialLaws.Law3.Functors.
Require Import Types.Prod ExponentialLaws.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

(** ** [(y × z)ⁿ ≅ yⁿ × zⁿ] *)
Section Law3.
  Context `{Funext}.
  Variables C1 C2 D : PreCategory.

  Lemma helper (c : Functor D C1 * Functor D C2)
  : ((fst o (Datatypes.fst c * Datatypes.snd c))%functor,
     (snd o (Datatypes.fst c * Datatypes.snd c))%functor)%core = c.
  Proof.
    apply path_prod;
    [ apply compose_fst_prod
    | apply compose_snd_prod ].
  Defined.

  Lemma Law
  : functor C1 C2 D o inverse C1 C2 D = 1
    /\ inverse C1 C2 D o functor C1 C2 D = 1.
  Proof.
    split; path_functor;
    [ (exists (path_forall _ _ helper))
    | (exists (path_forall _ _ (fun _ => Functor.Prod.Universal.unique idpath idpath))) ];
    exp_laws_t;
    unfold helper, compose_fst_prod, compose_snd_prod, Functor.Prod.Universal.unique, Functor.Prod.Universal.unique_helper;
    exp_laws_t.
  Qed.
End Law3.


From Coq Require Import ZArith .
From Common Require Import Var .
From mQhasm Require Import zDSL zRadix .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition fe25519_mul : program :=

let         wsize :=   64%nat in

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in

let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in

let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in

let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in

let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
[::
      (*  *)
      (* int64 rp *)
      (* int64 xp *)
      (* int64 yp *)
      (*  *)
      (* input rp *)
      (* input xp *)
      (* input yp *)
      (*  *)
      (* int64 r0 *)
      (* int64 r1 *)
      (* int64 r2 *)
      (* int64 r3 *)
      (* int64 r4 *)
      (*  *)
      (* int64 c1 *)
      (* int64 c2 *)
      (* int64 c3 *)
      (* int64 c4 *)
      (* int64 c5 *)
      (* int64 c6 *)
      (* int64 c7 *)
      (* caller c1 *)
      (* caller c2 *)
      (* caller c3 *)
      (* caller c4 *)
      (* caller c5 *)
      (* caller c6 *)
      (* caller c7 *)
      (* stack64 c1_stack *)
      (* stack64 c2_stack *)
      (* stack64 c3_stack *)
      (* stack64 c4_stack *)
      (* stack64 c5_stack *)
      (* stack64 c6_stack *)
      (* stack64 c7_stack *)
      (* stack64 x119_stack *)
      (* stack64 x219_stack *)
      (* stack64 x319_stack *)
      (* stack64 x419_stack *)
      (*  *)
      (* stack64 rp_stack *)
      (*  *)
      (* # required for the mul template *)
      (* int64 mulr01 *)
      (* int64 mulr11 *)
      (* int64 mulr21 *)
      (* int64 mulr31 *)
      (* int64 mulr41 *)
      (* int64 mulrax *)
      (* int64 mulrdx *)
      (* int64 mult *)
      (* int64 mulredmask *)
      (* stack64 mulx219_stack *)
      (* stack64 mulx319_stack *)
      (* stack64 mulx419_stack *)

      (*  *)

      (* enter crypto_sign_ed25519_amd64_51_fe25519_mul *)

      (*  *)

      (*   c1_stack = c1 *)
      (*   c2_stack = c2 *)
      (*   c3_stack = c3 *)
      (*   c4_stack = c4 *)
      (*   c5_stack = c5 *)
      (*   c6_stack = c6 *)
      (*   c7_stack = c7 *)
      (*   rp_stack = rp *)

      (*  *)
      (* yp = yp *)
      (*  *)
      (*  *)

      (*   #BEGIN MACRO mul *)
      (*   mulrax = *[uint64 *](xp + 24) *)
      (*   mulrax *= 19 *)
      (*   mulx319_stack = mulrax *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   r0 = mulrax *)
      (*   mulr01 = mulrdx *)
zAssign mulrax (zVar x3);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zAssign mulx319 (zVar mulrax);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r0 (zVar mulrax);
zAssign mulr01 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 32) *)
      (*   mulrax *= 19 *)
      (*   mulx419_stack = mulrax *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x4);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zAssign mulx419 (zVar mulrax);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   r1 = mulrax *)
      (*   mulr11 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r1 (zVar mulrax);
zAssign mulr11 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   r2 = mulrax *)
      (*   mulr21 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r2 (zVar mulrax);
zAssign mulr21 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   r3 = mulrax *)
      (*   mulr31 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r3 (zVar mulrax);
zAssign mulr31 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   r4 = mulrax *)
      (*   mulr41 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r4 (zVar mulrax);
zAssign mulr41 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 24) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 24) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx319_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar mulx319);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx319_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar mulx319);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 32) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx419_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar mulx419);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx419_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar mulx419);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx419_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar mulx419);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   mulredmask = *[uint64 *] &crypto_sign_ed25519_amd64_51_REDMASK51 *)
      (*   mulr01 = (mulr01.r0) << 13 *)
      (*   r0 &= mulredmask *)
zSplit tmp r0 (zVar r0) 51;
zAssign mulr01 (zBinop zAdd (zmul2p (zVar mulr01) 13) (zVar tmp));
      (*   mulr11 = (mulr11.r1) << 13 *)
      (*   r1 &= mulredmask *)
      (*   r1 += mulr01 *)
zSplit tmp r1 (zVar r1) 51;
zAssign mulr11 (zBinop zAdd (zmul2p (zVar mulr11) 13) (zVar tmp));
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulr01));
      (*   mulr21 = (mulr21.r2) << 13 *)
      (*   r2 &= mulredmask *)
      (*   r2 += mulr11 *)
zSplit tmp r2 (zVar r2) 51;
zAssign mulr21 (zBinop zAdd (zmul2p (zVar mulr21) 13) (zVar tmp));
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulr11));
      (*   mulr31 = (mulr31.r3) << 13 *)
      (*   r3 &= mulredmask *)
      (*   r3 += mulr21 *)
zSplit tmp r3 (zVar r3) 51;
zAssign mulr31 (zBinop zAdd (zmul2p (zVar mulr31) 13) (zVar tmp));
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulr21));
      (*   mulr41 = (mulr41.r4) << 13 *)
      (*   r4 &= mulredmask *)
      (*   r4 += mulr31 *)
zSplit tmp r4 (zVar r4) 51;
zAssign mulr41 (zBinop zAdd (zmul2p (zVar mulr41) 13) (zVar tmp));
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulr31));
      (*   mulr41 = mulr41 * 19 *)
zAssign mulr41 (zBinop zMul (zVar mulr41) (zConst 19%Z));
      (*   r0 += mulr41 *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulr41));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   mult = r0 *)
      (*   (uint64) mult >>= 51 *)
      (*   mult += r1 *)
zAssign mult (zVar r0);
zSplit mult tmp (zVar mult) 51;
zAssign mult (zBinop zAdd (zVar mult) (zVar r1));
      (*   r1 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r0 &= mulredmask *)
      (*   mult += r2 *)
zAssign r1 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r0 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r2));
      (*   r2 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r1 &= mulredmask *)
      (*   mult += r3 *)
zAssign r2 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r1 (zVar tmp2);
zAssign mult (zBinop zAdd (zVar mult) (zVar r3));
      (*   r3 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r2 &= mulredmask *)
      (*   mult += r4 *)
zAssign r3 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r2 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r4));
      (*   r4 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r3 &= mulredmask *)
zAssign r4 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r3 (zVar tmp2);
      (*   mult *= 19 *)
      (*   r0 += mult *)
      (*   r4 &= mulredmask *)
zAssign mult (zBinop zMul (zVar mult) (zConst 19%Z));
zAssign r0 (zBinop zAdd (zVar r0) (zVar mult));
zAssign r4 (zVar tmp);
      (*   #END MACRO mul *)

      (*  *)
      (* *[uint64 *](rp + 0) = r0 *)
      (* *[uint64 *](rp + 8) = r1 *)
      (* *[uint64 *](rp + 16) = r2 *)
      (* *[uint64 *](rp + 24) = r3 *)
      (* *[uint64 *](rp + 32) = r4 *)
zAssign z0 (zVar r0);
zAssign z1 (zVar r1);
zAssign z2 (zVar r2);
zAssign z3 (zVar r3);
zAssign z4 (zVar r4)
      (*  *)

      (* c1 =c1_stack *)
      (* c2 =c2_stack *)
      (* c3 =c3_stack *)
      (* c4 =c4_stack *)
      (* c5 =c5_stack *)
      (* c6 =c6_stack *)
      (* c7 =c7_stack *)
      (*  *)

      (* leave *)
] .

Definition fe25519_mul_inputs : VS.t :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            y0 :=   5 in
let            y1 :=   6 in
let            y2 :=   7 in
let            y3 :=   8 in
let            y4 :=   9 in
VSLemmas.OP.P.of_list [:: x0; x1; x2; x3; x4; y0; y1; y2; y3; y4].

Definition fe25519_mul_pre : bexp := zTrue.

Definition fe25519_mul_post : bexp :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            y0 :=   5 in
let            y1 :=   6 in
let            y2 :=   7 in
let            y3 :=   8 in
let            y4 :=   9 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (
    (radix51 [::zVar x0; zVar x1; zVar x2; zVar x3; zVar x4])
    @*
    (radix51 [::zVar y0; zVar y1; zVar y2; zVar y3; zVar y4])
  )
  (radix51 [::zVar r0; zVar r1; zVar r2; zVar r3; zVar r4])
  (zConst n25519).

Definition fe25519_mul_spec :=
  {| spre := fe25519_mul_pre;
     sprog := fe25519_mul;
     spost := fe25519_mul_post |}.

From mathcomp Require Import eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_fe25519_mul : valid_zspec (fe25519_mul_inputs, fe25519_mul_spec).
Proof.
  time "valid_fe25519_mul" verify_zspec.
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


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

Require Import Params_Admits Term_Defs Eqb_Evidence AbstractedTypes EqClass.

Require Import Example_Phrases_Demo Example_Phrases_Demo_Admits.

(* notation scope so that strings are interpreted correctly. *)

(* here is the get_data term copied. We want to make sure that the get_data_aspid is only called when the target (0) requests from the source (1)*)
Definition get_data' : Term :=
  asp (
      ASPC ALL EXTD (asp_paramsC get_data_aspid get_data_args source_plc get_data_targid)).

(* ASPIDs are defined by Definition. use eqb_aspid for string comparison *)

(* privacy policy ensures that the sending place (place that sends the request aka the target) can recieve the requested data. In this case, the data should only be shared between source (O) and target (S O) . *)
Fixpoint privPolicy `{H : EqClass ID_Type} (sendPlc:Plc) (t:Term) : bool :=
    match t with
    | asp (ASPC _ _ (asp_paramsC aspid args rp tid)) =>
        match eqb_aspid aspid get_data_aspid with
        | true => andb (eqb sendPlc dest_plc) (eqb rp source_plc)
        | false => true
        end
    | asp _ => true
    | att p t => privPolicy sendPlc t
    | lseq t1 t2 => andb (privPolicy sendPlc t1) (privPolicy sendPlc t2)
    | bseq _ t1 t2 => andb (privPolicy sendPlc t1) (privPolicy sendPlc t2)
    | bpar _ t1 t2 => andb (privPolicy sendPlc t1) (privPolicy sendPlc t2)
    end.

Global Hint Resolve privPolicy : core.

Example privCheck1 `{H : EqClass ID_Type} : privPolicy dest_plc get_data' = true.
Proof.
  destruct H; cbv.
  assert (eqb get_data_aspid get_data_aspid = true). rewrite eqb_leibniz; eauto.
  rewrite H.
  assert (eqb dest_plc dest_plc = true). rewrite eqb_leibniz; eauto.
  rewrite H0.
  assert (eqb source_plc source_plc = true). rewrite eqb_leibniz; eauto.
  rewrite H1. eauto.
Qed.

(*
Definition another_plc : Plc. Admitted.

Example privCheck2 : exists p: Plc, p <> dest_plc -> privPolicy another_plc get_data' = false.
Proof.
  intros. exists another_plc. intros.
  simpl. rewrite eqb_refl. rewrite PeanoNat.Nat.eqb_refl. apply PeanoNat.Nat.eqb_neq in H. rewrite H. auto.
Qed.
*)

Example privCheck2' `{H : EqClass ID_Type} : forall p: Plc, p <> dest_plc -> privPolicy p get_data' = false.
Proof.
  destruct H; cbv; intros.
  assert (eqb get_data_aspid get_data_aspid = true). rewrite eqb_leibniz; eauto.
  rewrite H0.
  assert (eqb p dest_plc = false). {
    destruct (eqb p dest_plc) eqn:E; eauto.
    destruct H; eapply eqb_leibniz. eauto.
  }
  rewrite H1. eauto.
Qed.


(** Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
 *  Jean-Baptiste Tristan, and Edward Gan.
 *
 *  This file is part of RockSalt.
 *
 *  This file is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU General Public License as
 *  published by the Free Software Foundation; either version 2 of
 *  the License, or (at your option) any later version.
 *)

(** CheckDeterministic.v:  This file provides some routines to help try to
 *  prove that parsers are deterministic.  In particular, there's a function
 *  [disjoint_p p1 p2] which when it returns true, ensures that there is no
 *  string of tokens (i.e., bytes) that is accepted by both [p1] and [p2].
 *  This is achieved by computing the intersection of the two [regexps]
 *  corresponding to [p1] and [p2] and trying to show that that intersection
 *  is equivalent to [Zero].
 *
 *  I coded a new version of regexps, here called [rexp] to avoid conflicts
 *  with the definition in [Parser.v], which includes intersection ([And_r]).
 *  To determine if an [rexp] is equivalent to [Zero], we (a) check to see
 *  if the [rexp] is nullable (if so, then it accepts [nil] so it's not
 *  equivalent to [Zero]), and otherwise, calculate the derivative of the
 *  [rexp] with respect to each possible input token, and then recursively
 *  see if the derivatives are zero.  If all of the derivatives are zero,
 *  then the original expression is equivalent to zero.
 *)
Require Import Coqlib.
Require Import Parser.
Require Import Ascii.
Require Import String.
Require Import List.
Require Import Bits.
Require Import Decode.
Require Import Eqdep.
Unset Automatic Introduction.
Set Implicit Arguments.
Open Scope char_scope.
Require ExtrOcamlString.
Require ExtrOcamlNatBigInt.
Require ExtrOcamlNatInt.
Import X86_PARSER_ARG.
Import X86_PARSER.
Import X86_BASE_PARSER.

(** Our regular expressions with intersection ([And_r]).  We need
 *  the support for intersection to test whether two parsers overlap
 *  on strings.  *)
Inductive rexp : Type :=
| Any_r : rexp
| Char_r : char_p -> rexp
| Eps_r : rexp
| Cat_r : rexp -> rexp -> rexp
| Zero_r : rexp
| Alt_r : rexp -> rexp -> rexp
| Star_r : rexp -> rexp
| And_r : rexp -> rexp -> rexp.

(** Denotational semantics of regular expressions. *)
Inductive in_rexp : rexp -> list char_p -> Prop :=
| Any_ri : forall c, in_rexp Any_r (c::nil)
| Char_ri : forall c, in_rexp (Char_r c) (c::nil)
| Eps_ri : in_rexp Eps_r nil
| Cat_ri : forall r1 r2 cs1 cs2 cs,
  in_rexp r1 cs1 -> in_rexp r2 cs2 ->
  cs = cs1 ++ cs2 -> in_rexp (Cat_r r1 r2) cs
| Alt_left_ri : forall r1 r2 cs, in_rexp r1 cs -> in_rexp (Alt_r r1 r2) cs
| Alt_right_ri : forall r1 r2 cs, in_rexp r2 cs -> in_rexp (Alt_r r1 r2) cs
| Star_eps_ri : forall r, in_rexp (Star_r r) nil
| Star_cat_ri : forall r cs1 cs2 cs,
  cs1 <> nil -> in_rexp r cs1 -> in_rexp (Star_r r) cs2 ->
  cs = cs1 ++ cs2 ->
  in_rexp (Star_r r) cs
| And_ri : forall r1 r2 cs, in_rexp r1 cs -> in_rexp r2 cs -> in_rexp (And_r r1 r2) cs.
Hint Constructors in_rexp.

Ltac mysimp :=
  simpl in * ; intros ;
    repeat match goal with
             | [ |- context[char_eq ?x ?y] ] => destruct (char_eq x y) ; auto
             | [ |- _ /\ _ ] => split
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- context[ _ ++ nil ] ] => rewrite <- app_nil_end
             | [ H : exists x, _ |- _ ] => destruct H
             | [ H : _ \/ _ |- _] => destruct H
             | [ H : _ <-> _ |- _] => destruct H
             | [ |- _ <-> _ ] => split
             | [ H : _::_ = _::_ |- _] => injection H ; clear H
             | _ => idtac
           end ; auto.
Ltac s := repeat (mysimp ; subst).

Lemma cons_app A (x:A) (ys:list A) : x :: ys = (x::nil) ++ ys. auto. Qed.

(** I coded [rexp_eq] explicitly to return a [bool], because this seems
 *  to run faster than if we compute a proof of equality. *)
Fixpoint rexp_eq(r1 r2:rexp) : bool :=
  match r1, r2 with
    | Any_r, Any_r => true
    | Any_r, _ => false
    | Char_r c1, Char_r c2 => if char_eq c1 c2 then true else false
    | Char_r _, _ => false
    | Eps_r, Eps_r => true
    | Eps_r, _ => false
    | Cat_r r1 r2, Cat_r r3 r4 => rexp_eq r1 r3 && rexp_eq r2 r4
    | Cat_r _ _, _ => false
    | Zero_r, Zero_r => true
    | Zero_r, _ => false
    | Alt_r r1 r2, Alt_r r3 r4 => rexp_eq r1 r3 && rexp_eq r2 r4
    | Alt_r _ _, _ => false
    | Star_r r1, Star_r r2 => rexp_eq r1 r2
    | Star_r _, _ => false
    | And_r r1 r2, And_r r3 r4 => rexp_eq r1 r3 && rexp_eq r2 r4
    | And_r _ _, _ => false
  end.

(** Proof that [rexp_eq] really does compute equality. *)
Lemma rexp_eq_corr r1 r2 :
  if rexp_eq r1 r2 then r1 = r2 else r1 <> r2.
Proof.
  induction r1 ; destruct r2 ; simpl ; try congruence ; unfold andb in * ;
    repeat
  match goal with
    | [ |- context[if char_eq ?c ?c0 then _ else _] ] =>
      destruct (char_eq c c0) ; subst ; try congruence
    | [ H : (forall r2, if rexp_eq ?r1 r2 then _ else _) |-
            context[if rexp_eq ?r1 ?r2 then _ else _] ] =>
    generalize (H r2) ; clear H ; intro H ; destruct (rexp_eq r1 r2) ; subst
    | _ => try congruence ; auto
  end.
Qed.

Ltac in_inv :=
  match goal with
    | [ H : in_rexp Eps_r _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp Any_r _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (Char_r _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (Cat_r _ _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (Alt_r _ _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp (And_r _ _) _ |- _ ] => inversion H ; clear H ; subst
    | [ H : in_rexp Zero_r _ |- _ ] => inversion H
    | [ |- context [if rexp_eq ?r1 ?r2 then _ else _] ] =>
      generalize (rexp_eq_corr r1 r2) ; intro ;
      destruct (rexp_eq r1 r2) ; try congruence
    | [ H : context [if rexp_eq ?r1 ?r2 then _ else _] |- _ ] =>
      generalize (rexp_eq_corr r1 r2) ; intro ;
      destruct (rexp_eq r1 r2) ; try congruence
    | _ => s
  end.

(** Optimizing [cat] constructor. *)
Definition OptCat_r(r1 r2:rexp) : rexp :=
  match r1, r2 with
    | Zero_r, _ => Zero_r
    | Eps_r, r2 => r2
    | _, Zero_r => Zero_r
    | r1, Eps_r => r1
    | r1, r2 => Cat_r r1 r2
  end.

(** [OptCat_r] is equivalent to [Cat_r]. *)
Lemma opt_cat_r_corr : forall r1 r2 s,
  in_rexp (Cat_r r1 r2) s <-> in_rexp (OptCat_r r1 r2) s.
Proof.
  destruct r1 ; repeat in_inv ; eauto ; destruct r2 ; repeat in_inv ; eauto ;
    try (rewrite cons_app ; eauto ; fail) ;
    try (rewrite app_nil_end ; eauto ; fail).
Qed.
Hint Resolve opt_cat_r_corr.

(** Optimizing [alt] constructor. *)
Definition OptAlt_r(r1 r2:rexp) : rexp :=
  match r1, r2 with
    | Zero_r, r2 => r2
    | r1, Zero_r => r1
    | Char_r true, Char_r false => Any_r
    | Char_r false, Char_r true => Any_r
    | r1, r2 => if rexp_eq r1 r2 then r1 else Alt_r r1 r2
  end.

(** [Alt_r r r] is equivalent to [r] *)
Lemma eq_rexp_alt1 r s:
  in_rexp (Alt_r r r) s <-> in_rexp r s.
Proof.
  repeat in_inv.
Qed.
Hint Resolve eq_rexp_alt1.

(** [OptAlt_r] is equivalent to [Alt]. *)
Lemma opt_alt_r_corr : forall r1 r2 s,
  in_rexp (Alt_r r1 r2) s <-> in_rexp (OptAlt_r r1 r2) s.
Proof.
  destruct r1 ; simpl ; destruct r2 ; unfold andb ; simpl ; repeat in_inv ;
    repeat
    match goal with
      | [ H : _ = _ |- _] => injection H ; clear H ; intros ; subst ; eauto
      | [ |- in_rexp (if ?c then _ else _) _ ] => destruct c ; simpl ; eauto
      | [ H : in_rexp (if ?c then _ else _) _ |- _] => destruct c ; simpl in * ;
        repeat in_inv ; eauto
      | _ => eauto
    end ; destruct c ; eauto.
Qed.
Hint Resolve opt_alt_r_corr.

(** Returns [Eps_r] if [r] accepts the empty string, else returns [Zero_r]. *)
Fixpoint null_r (r:rexp) : rexp :=
  match r with
    | Any_r => Zero_r
    | Char_r _ => Zero_r
    | Eps_r => Eps_r
    | Zero_r => Zero_r
    | Alt_r r1 r2 => OptAlt_r (null_r r1) (null_r r2)
    | Cat_r r1 r2 => OptCat_r (null_r r1) (null_r r2)
    | Star_r r => Eps_r
    | And_r r1 r2 => match null_r r1, null_r r2 with
                       | Zero_r, _ => Zero_r
                       | _, Zero_r => Zero_r
                       | _, _ => Eps_r
                     end
  end.

(** [null_r] returns either [Eps_r] or [Zero_r]. *)
Lemma null_r_eps_zero : forall r, null_r r = Eps_r \/ null_r r = Zero_r.
Proof.
  induction r ; s ;
    repeat
  match goal with
    | [ H : ?r = Eps_r |- _ ] => rewrite H ; clear H ; simpl
    | [ H : ?r = Zero_r |- _ ] => rewrite H ; clear H ; simpl
    | _ => idtac
  end ; auto.
Qed.

(** If [s] is in denotation of [null_r r] then [s] is [nil]. *)
Lemma null_r_corr' : forall r s,
  in_rexp r s ->
  forall r', r = null_r r' -> s = nil.
Proof.
  induction 1 ; intros ; generalize (null_r_eps_zero r') ; intro NEZ ; destruct NEZ ;
    try congruence.
Qed.

Lemma null_r_corr1 : forall r s, in_rexp (null_r r) s -> s = nil.
Proof.
  intros ; eapply null_r_corr' ; eauto.
Qed.

Lemma nil_is_nil_app_nil : forall A (cs1 cs2:list A),
  nil = cs1 ++ cs2 -> cs1 = nil /\ cs2 = nil.
Proof.
  destruct cs1 ; destruct cs2 ; simpl ; intros ; try congruence. auto.
Qed.

(** If [nil] is in the denotation of [r], then it's also in [null_r r]. *)
Lemma null_r_corr2 : forall r s, in_rexp r s -> s = nil -> in_rexp (null_r r) s.
Proof.
  induction 1 ; repeat in_inv ; try congruence ;
    try (apply opt_alt_r_corr ; eauto).
  generalize (nil_is_nil_app_nil _ _ (sym_eq H2)). repeat in_inv.
  apply opt_cat_r_corr. rewrite app_nil_end. eauto.
  generalize (nil_is_nil_app_nil _ _ (sym_eq H3)). repeat in_inv.
  generalize (null_r_eps_zero r1) (null_r_eps_zero r2).
  generalize (IHin_rexp1 (eq_refl _)). generalize (IHin_rexp2 (eq_refl _)).
  repeat in_inv ; rewrite H3 in * ; rewrite H4 in * ; in_inv ; eauto.
Qed.
Hint Resolve null_r_corr2.

(** If [nil] is in the denotation of [null_r r], then it's also in the
 *  denotation of [r]. *)
Lemma null_r_corr3 r : in_rexp (null_r r) nil -> in_rexp r nil.
Proof.
  induction r ; repeat in_inv ;
  try (generalize (proj2 (opt_alt_r_corr _ _ _) H)) ;
  try (generalize (proj2 (opt_and_r_corr _ _ _) H)) ;
    repeat in_inv.
  generalize (proj2 (opt_cat_r_corr _ _ _) H). clear H. repeat in_inv. rewrite H5.
  generalize (nil_is_nil_app_nil _ _ H5). in_inv. rewrite app_nil_end. eauto.
  generalize (null_r_eps_zero r1) (null_r_eps_zero r2) ; intros A1 A2.
  destruct A1 as [A1 | A1]; rewrite A1 in * ;
    destruct A2 as [A2 | A2 ] ; rewrite A2 in * ; eauto.
Qed.

(** If [null_r r] is [Eps_r], then it accepts [nil]. *)
Lemma null_r_corr4 : forall r, null_r r = Eps_r -> in_rexp r nil.
Proof.
  induction r ; simpl ; intros ; try congruence ; eauto ; try (
  generalize (null_r_eps_zero r1) (null_r_eps_zero r2) ; intros H1 H2 ;
    destruct H1 as [H1 | H1 ]; rewrite H1 in * ; simpl in * ; try congruence ;
      destruct H2 as [H2 | H2]; rewrite H2 in * ; simpl in * ; try congruence) ; eauto.
Qed.
Hint Resolve null_r_corr4.

(** Optimizing [And_r r1 r2]. *)
Definition OptAnd_r(r1 r2:rexp) : rexp :=
  match r1, r2 with
    | _, Zero_r => Zero_r
    | Zero_r, _ => Zero_r
    | Eps_r, r2 => null_r r2
    | r1, Eps_r => null_r r1
    | Any_r, Char_r c => Char_r c
    | Char_r c, Any_r => Char_r c
    | Char_r c1, Char_r c2 => if char_eq c1 c2 then Char_r c1 else Zero_r
    | r1, r2 => if rexp_eq r1 r2 then r1 else And_r r1 r2
  end.

Ltac pv_opt :=
  repeat
  match goal with
    | [ |- in_rexp (OptCat_r _ _) _ ] => apply opt_cat_r_corr
    | [ |- in_rexp (OptAlt_r _ _) _ ] => apply opt_alt_r_corr
    | [ H : nil = ?cs1 ++ ?cs2 |- _] => generalize (nil_is_nil_app_nil _ _ H) ; s
    | [ H : in_rexp (OptCat_r _ _) _ |- _ ] =>
      generalize (proj2 (opt_cat_r_corr _ _ _) H) ; clear H ; repeat in_inv
    | [ H : in_rexp (OptAlt_r _ _) _ |- _ ] =>
      generalize (proj2 (opt_alt_r_corr _ _ _) H) ; clear H ; repeat in_inv
    | [ H : in_rexp (null_r ?r) _ |- _ ] =>
      let H1 := fresh "H" in
      let H2 := fresh "H" in
      let H3 := fresh "H" in
      generalize (null_r_corr1 _ H)  ; intro ; subst ;
      generalize (null_r_corr3 _ H) ;
      generalize (null_r_corr2 H (eq_refl _)) ;
      generalize (null_r_eps_zero r) ;
        intros H1 H2 H3 ; destruct H1 ; rewrite H1 in * ; s ; clear H
    | [ H : in_rexp ?r nil |- context [null_r ?r] ] =>
      let H1 := fresh "H" in
      let H2 := fresh "H" in
        generalize (null_r_corr2 H (eq_refl _)) ;
          generalize (null_r_eps_zero r) ;
            intros H1 H2 ; destruct H1 ; rewrite H1 in *
    | [ H : in_rexp (match null_r ?r with | Any_r => _ | Char_r _ => _ | Eps_r => _
                       | Cat_r _ _ => _ | Zero_r => _ | Alt_r _ _ => _ | Star_r _ => _
                         | And_r _ _ => _ end) _ |- _] =>
    let H := fresh "H" in
      generalize (null_r_eps_zero r) ; intros H ; destruct H ; rewrite H in *
    | [ |- in_rexp (And_r _ _) _ ] => constructor
    | [ H : Cat_r _ _ = Cat_r _ _ |- _] => injection H ; clear H ; s
    | [ H : Alt_r _ _ = Alt_r _ _ |- _] => injection H ; clear H ; s
    | [ H : And_r _ _ = And_r _ _ |- _] => injection H ; clear H ; s
    | [ H : Star_r _ = Star_r _ |- _] => injection H ; clear H ; s
    | _ => in_inv ; eauto
  end.

(** [OptAnd_r] is equivalent to [And_r]. *)
Lemma opt_and_r_corr : forall r1 r2 s,
  in_rexp (And_r r1 r2) s <-> in_rexp (OptAnd_r r1 r2) s.
Proof.
  destruct r1 ; simpl ; destruct r2 ; unfold andb ; simpl;
    repeat in_inv ; try congruence ; pv_opt.
Qed.

(** Convert a [parser] to an [rexp]. *)
Fixpoint parser2rexp t (p:parser t) : rexp :=
  match p with
    | Any_p => Any_r
    | Char_p c => Char_r c
    | Eps_p => Eps_r
    | Cat_p t1 t2 r1 r2 => OptCat_r (parser2rexp r1) (parser2rexp r2)
    | Zero_p t => Zero_r
    | Alt_p t r1 r2 => OptAlt_r (parser2rexp r1) (parser2rexp r2)
    | Star_p t r => Star_r (parser2rexp r)
    | Map_p t1 t2 f r => parser2rexp r
  end.

(** If [s] and [v] are in the denotation of [p], then [s] is in the denotation of
 *  [parser2rexp p]. *)
Lemma parse2rexp_corr1 t (p:parser t) s v :
  in_parser p s v -> in_rexp (parser2rexp p) s.
Proof.
  induction 1 ; subst ; repeat in_inv ;
    try (apply opt_alt_r_corr ||apply opt_cat_r_corr) ; eauto.
Qed.

(** If [s] is in the denotation of [parser2rexp p], then there exists some [v],
 *  such that [s] and [v] are in the denotation of [p]. *)
Lemma parse2rexp_corr2 t (p:parser t) s :
  in_rexp (parser2rexp p) s ->
    exists v, in_parser p s v.
Proof.
  induction p ; repeat in_inv ; try (econstructor ; econstructor ; eauto ; fail).
   generalize (proj2 (opt_cat_r_corr (parser2rexp p1) (parser2rexp p2) s) H).
   repeat in_inv. generalize (IHp1 _ H3). generalize (IHp2 _ H4). s.
   repeat econstructor ; eauto.
   generalize (proj2 (opt_alt_r_corr _ _ _) H). repeat in_inv.
   generalize (IHp1 _ H4) ; repeat in_inv. repeat econstructor ; eauto.
   generalize (IHp2 _ H4) ; repeat in_inv. econstructor. eapply Alt_right_pi. eauto.
   Focus 2. generalize (IHp _ H). s. econstructor. econstructor. eauto. eauto.
   generalize s H IHp. clear s H IHp. generalize (parser2rexp p).
   intros r s H. remember (Star_r r) as r'. generalize Heqr'. clear Heqr'.
   induction H ; intros ; try congruence ; injection Heqr' ; intros ; subst ; clear
     Heqr'. exists nil. constructor ; auto. generalize (IHin_rexp2 (eq_refl _) IHp).
   clear IHin_rexp1 IHin_rexp2. intros. destruct H2. generalize (IHp _ H0).
   intros. destruct H3. econstructor. eapply Star_cat_pi. eauto. eauto. auto.
   eauto. auto.
Qed.

(** Returns true if [r] accepts the empty string, false otherwise -- it's
 *  faster to just compute this directly than to call [null_r]. *)
Fixpoint ck_null (r:rexp) : bool :=
  match r with
    | Eps_r => true
    | Char_r _ => false
    | Any_r => false
    | Zero_r => false
    | Alt_r r1 r2 => ck_null r1 || ck_null r2
    | Cat_r r1 r2 => ck_null r1 && ck_null r2
    | And_r r1 r2 => ck_null r1 && ck_null r2
    | Star_r _ => true
  end.

(** [ck_null] is correct. *)
Lemma ck_null_corr r : if ck_null r then in_rexp r nil else ~ in_rexp r nil.
Proof.
  induction r ; simpl ; auto ; try (intro ; in_inv) ;
    repeat
      match goal with
        | [ H : if ck_null ?r then _ else _ |- _ ] => destruct (ck_null r) ; simpl
        | [ |- in_rexp (Cat_r _ _) nil ] =>
          let H := fresh "H" in
          assert (H: @nil char_p = nil ++ nil) ; [ auto | rewrite H ] ; eauto
        | [ |- ~ _ ] => intro ; in_inv
        | [ H : nil = ?cs1 ++ ?cs2 |- _] => generalize (nil_is_nil_app_nil cs1 cs2 H) ;
          clear H ; s
        | [ H : in_rexp ?r ?s, H1 : ~ in_rexp ?r ?s |- _ ] => contradiction H1
        | _ => eauto
      end.
Qed.

(** Calculate the derivative of an [rexp] with respect to a character. *)
Fixpoint deriv_r (r:rexp) (c:char_p) : rexp :=
  match r with
    | Any_r => Eps_r
    | Char_r c' => if char_eq c c' then Eps_r else Zero_r
    | Eps_r => Zero_r
    | Zero_r => Zero_r
    | Alt_r r1 r2 => OptAlt_r (deriv_r r1 c) (deriv_r r2 c)
    | Cat_r r1 r2 =>
      OptAlt_r (OptCat_r (deriv_r r1 c) r2)
               (if ck_null r1 then deriv_r r2 c else Zero_r)
    | Star_r r as r' => OptCat_r (deriv_r r c) r'
    | And_r r1 r2 => OptAnd_r (deriv_r r1 c) (deriv_r r2 c)
  end.

(** Derivative is correct part 1 *)
Lemma deriv_r_corr1 r s :
  in_rexp r s -> forall c cs, s = c::cs -> in_rexp (deriv_r r c) cs.
Proof.
  induction 1 ; try (repeat in_inv ; try congruence ;
    try (apply opt_alt_r_corr) ; try (apply opt_and_r_corr) ;
          try (apply opt_cat_r_corr) ; eauto).
  destruct cs1. simpl in *. subst. apply Alt_right_ri.
  generalize (ck_null_corr r1). destruct (ck_null r1). intros. eauto.
  intros. contradiction H1. s. apply Alt_left_ri. apply opt_cat_r_corr. eauto.
  destruct cs1. congruence. simpl in *. injection H3 ; intros ; subst ; clear H3.
  econstructor ; eauto.
Qed.

(** Derivative is correct part 2 *)
Lemma deriv_r_corr2 r c cs : in_rexp (deriv_r r c) cs -> in_rexp r (c::cs).
Proof.
  induction r ; repeat in_inv. destruct (char_eq c0 c). subst. in_inv. constructor.
  in_inv. generalize (proj2 (opt_alt_r_corr _ _ _) H). clear H ; intro.
  in_inv. generalize (proj2 (opt_cat_r_corr _ _ _) H3). clear H3 ; intro ;
  in_inv. econstructor ; eauto. generalize (ck_null_corr r1).  destruct (ck_null r1).
  intros. assert (c::cs = nil ++ c::cs) ; auto. rewrite H0. eauto. in_inv.
  generalize (proj2 (opt_alt_r_corr _ _ _) H). clear H. repeat in_inv.
  generalize (proj2 (opt_cat_r_corr _ _ _) H). clear H. repeat in_inv.
  eapply Star_cat_ri ; eauto. congruence. generalize opt_and_r_corr.
  repeat in_inv. generalize (proj2 (opt_and_r_corr _ _ _) H). clear H. repeat in_inv.
Qed.

(** A string [c::cs] is in the denotation of [r] iff [cs] is in the
 *  denotation of [deriv_r r c]. *)
Lemma deriv_r_corr r c cs : in_rexp r (c::cs) <-> in_rexp (deriv_r r c) cs.
Proof.
  intros ; split ; intros. eapply deriv_r_corr1; eauto. eapply deriv_r_corr2 ; eauto.
Qed.

(** Extend derivatives to strings -- i.e., lists of characters. *)
Fixpoint derivs_r (r:rexp) (cs:list char_p) : rexp :=
  match cs with
    | nil => r
    | c::cs' => derivs_r (deriv_r r c) cs'
  end.

(** A string [cs1 ++ cs2] is in the denotation of [r] iff the string [cs2] is
 *  in the denotation of [derivs_r r cs1]. *)
Lemma derivs_r_corr cs1 r cs2 : in_rexp r (cs1 ++ cs2) <-> in_rexp (derivs_r r cs1) cs2.
Proof.
  intros ; split ; generalize r cs2 ; clear r cs2 ; induction cs1 ; simpl ; intros ; auto.
  eapply IHcs1. apply deriv_r_corr ; auto.
  apply deriv_r_corr. apply IHcs1. auto.
Qed.

(** Specialization of [deriv] for the case where we are going to take the
 *  derivative with respect to all characters. This avoids doing a case
 *  split on [Any_r] into the characters and provides a big speedup. *)
Fixpoint DerivAny (r:rexp) : rexp :=
  match r with
    | Any_r => Eps_r
    | Char_r _ => Eps_r
    | Zero_r => Zero_r
    | Eps_r => Zero_r
    | Alt_r r1 r2 => OptAlt_r (DerivAny r1) (DerivAny r2)
    | And_r r1 r2 => OptAnd_r (DerivAny r1) (DerivAny r2)
    | Cat_r r1 r2 =>
      OptAlt_r (OptCat_r (DerivAny r1) r2)
               (if ck_null r1 then DerivAny r2 else Zero_r)
    | Star_r r as r' => OptCat_r (DerivAny r) r'
  end.

(** Calculate the derivative of one [rexp] with respect to another.  This is
 *  only meaningful when [r2] is a star-free [rexp] which is why we get an
 *  option out.  As we'll see, we get an over approximation of the set of
 *  strings accepted by the derivative of [r1] with respect to the strings
 *  in [r2].   This provides a fast test for checking whether an intersection
 *  is empty and is in fact sufficient for our needs. *)
Fixpoint Deriv (r1:rexp) (r2:rexp) : option rexp :=
  match r2 with
    | Any_r => Some (DerivAny r1)
    | Char_r c => Some (deriv_r r1 c)
    | Zero_r => Some (Zero_r)
    | Eps_r => Some r1
    | Alt_r ra rb =>
      match Deriv r1 ra with
        | Some Zero_r => Deriv r1 rb
        | Some d1 => match Deriv r1 rb with
                       | Some d2 => Some (OptAlt_r d1 d2)
                       | None => None
                     end
        | None => None
      end
    | Cat_r ra rb =>
      match Deriv r1 ra with
        | Some Zero_r as d => d
        | Some d1 => Deriv d1 rb
        | None => None
      end
    | And_r ra rb =>
      match Deriv r1 ra, Deriv r1 rb with
        | Some d1, Some d2 => Some (OptAnd_r d1 d2)
        | _, _ => None
      end
    | Star_r ra => None
  end.

Ltac Dsimp :=
  match goal with
    | [ H : Some ?x = Some ?y |- _ ] =>
      assert (x = y) ; [injection H ; auto | clear H ; subst]
    | [ H : in_rexp (deriv_r _ ?c) _ |- exists cs, _ /\ _ ] =>
      exists (c::nil) ; split ; [constructor | apply deriv_r_corr ; auto]
    | [ H : (match Deriv ?r1 ?r2 with | Some _ => _ | None => _ end = _) |- _ ] =>
      let d := fresh "d" in
        remember (Deriv r1 r2) as d ; destruct d
    | [ H : Some _ = Deriv _ _ |- _] => generalize (eq_sym H) ; clear H ; intro H
    | [ IH : forall _ _, Deriv _ ?r2 = Some _ -> _, H : Deriv _ ?r2 = Some _ |- _ ] =>
      specialize (IH _ _ H)
    | [ IH : forall _, in_rexp ?r _ -> _, H : in_rexp ?r _ |- _ ] =>
      specialize (IH _ H)
    | [ H : Some _ = None |- _ ] => congruence
    | [ H : None = Some _ |- _ ] => congruence
    | [ H : in_rexp (OptAnd_r _ _) _ |- _] =>
      generalize (proj2 (opt_and_r_corr _ _ _) H) ; clear H ; intro H
    | _ => idtac
  end.

(** If [c::cs'] is in the denotation of [r] then [cs'] is in the denotation
 *  of [DerivAny r]. *)
Lemma DerivAny_corr1 : forall r cs, in_rexp r cs ->
  forall c cs', cs = c::cs' -> in_rexp (DerivAny r) cs'.
Proof.
  induction 1 ; simpl ; repeat (in_inv ; pv_opt) ; try congruence.
  destruct cs1. eapply Alt_right_ri. generalize (ck_null_corr r1).
  destruct (ck_null r1). intros. pv_opt. intros. contradiction H1.
  eapply Alt_left_ri. pv_opt. destruct cs1. pv_opt. congruence. simpl in H3. injection H3.
  intros ; subst. pv_opt. apply opt_and_r_corr. pv_opt.
Qed.

(** If [cs1] is in the denotation of [r2] and [cs1++cs2] is in the denotation of [r1],
 *  then [cs2] is in the denotation of [Deriv r1 r2]. *)
Lemma Deriv_corr1 : forall r2 r1 r3, Deriv r1 r2 = Some r3 ->
  forall cs1 cs2,
    in_rexp r2 cs1 ->
    in_rexp r1 (cs1 ++ cs2) ->
    in_rexp r3 cs2.
Proof.
  induction r2 ; repeat (in_inv ; Dsimp ; pv_opt). eapply DerivAny_corr1 ; eauto.
  apply deriv_r_corr ; auto. rewrite <- app_assoc in H1. destruct r ; Dsimp ; eauto.
  specialize (IHr2_1 _ _ H4 H1). inversion IHr2_1. destruct r ; repeat Dsimp ; pv_opt.
  specialize (IHr2_1 _ _ H5 H1). pv_opt. destruct r ; repeat Dsimp ; pv_opt.
  apply opt_and_r_corr. eauto.
Qed.

(** If [Deriv r1 r2] is [Zero_r], then there is no string in the intersection
 *  of the denotations of [r1] and [r2]. *)
Lemma Deriv_Zero : forall r1 r2,
  Deriv r1 r2 = Some Zero_r ->
  ~ (exists cs, in_rexp (And_r r1 r2) cs).
Proof.
  intros. generalize (Deriv_corr1 H). intros. intro. destruct H1.
  inversion H1. subst ; clear H1. generalize (H0 x nil H6). rewrite <- app_nil_end.
  intros. specialize (H1 H4). inversion H1.
Qed.

(* Note the other direction does not hold, due to And_r:

  Lemma Deriv_corr1 : forall r2 r1 r3, Deriv r1 r2 = Some r3 ->
    forall cs2, in_rexp r3 cs2 -> exists cs1, in_rexp r2 cs1 /\ in_rexp r1 (cs1 ++ cs2).

  The problem is that what we return as the [Deriv] is an over-approximation of
  the set of strings in the derivative of [r1] with respect to the strings in [r2].
  Fortunately, we don't need this fact.
*)

(** Convert a nat representing a byte to a list of bits *)
Definition n2b(n:nat) : list bool :=
  let bs := Word.bits_of_Z 8 (Z_of_nat n) in
    (bs 7)::(bs 6)::(bs 5)::(bs 4)::(bs 3)::(bs 2)::(bs 1)::(bs 0)::nil.

Definition token_id_to_chars := n2b.
Definition num_tokens := 256%nat.
Opaque token_id_to_chars.
Opaque num_tokens.

(** Check whether [r] is equivalent to [Zero_r].  Note that to check whether
 *  [And_r r1 r2] is equivalent to [Zero_r], we take the derivative of [r1]
 *  with respect to [r2] and then check whether the resulting [rexp] is
 *  equivalent to [Zero_r].
 *
 *  Note that [n] here is used for "fuel" so as long as you find some [n]
 *  that returns [true], you know that [r] is equivalent to [Zero_r].
 *)
Fixpoint ckzero (n:nat) (r:rexp) : bool :=
  match n with
    | 0%nat => false
    | S n =>
      match r with
        | Zero_r => true
        | Eps_r => false
        | Any_r => false
        | Char_r _ => false
        | Cat_r r1 r2 => ckzero n r1 || ckzero n r2
        | Alt_r r1 r2 => ckzero n r1 && ckzero n r2
        | Star_r _ => false
        | And_r r1 r2 =>
          match Deriv r1 r2 with
            | Some r => ckzero n r
            | None =>
              negb (ck_null r1 && ck_null r2) &&
              ckzero n (OptAlt_r (OptAnd_r (deriv_r r1 true) (deriv_r r2 true))
                       (OptAnd_r (deriv_r r1 false) (deriv_r r2 false)))
          end
      end
  end.

(** Correctness for [ckzero]:  If [ckzero n r] returns [true] for some [n], then
 *  there is no string in the denotation of [r]. *)
Lemma ckzero_corr n r : ckzero n r = true -> ~(exists s, in_rexp r s).
Proof.
  induction n ; simpl ; intros ; try congruence ; destruct r ; try congruence ; intro ;
    mysimp ; repeat in_inv ; unfold andb, orb, negb in *.
  generalize (IHn r1). destruct (ckzero n r1). intros. apply H0 ; auto. eauto.
  intros. apply (IHn _ H). eauto. generalize (IHn r1). destruct (ckzero n r1).
  intros. apply H0 ; eauto. congruence. generalize (IHn r2). destruct (ckzero n r1) ;
  destruct (ckzero n r2) ; try congruence. intros. apply H0 ; eauto.
  generalize (@Deriv_corr1 r2 r1). intros. remember (Deriv r1 r2) as e.
  destruct e. generalize (H0 r (eq_refl _) x nil H5) (IHn _ H). intros.
  apply H2. exists nil. apply H1. rewrite <- app_nil_end. auto.
  generalize (ck_null_corr r1) (ck_null_corr r2) ;
  destruct (ck_null r1) ; destruct (ck_null r2) ; intros ; try congruence ;
    destruct x ; auto ; generalize (IHn _ H) ; clear H ; intro H ;
    apply H ; clear H ; exists x ; pv_opt ; destruct c ; clear H1 H2 ;
  try (apply Alt_left_ri ; apply opt_and_r_corr ; constructor ; eapply deriv_r_corr1 ; eauto ; fail) ;
    apply Alt_right_ri ; apply opt_and_r_corr ; constructor ; eapply deriv_r_corr1 ; eauto.
Qed.

(** Check whether [r1] and [r2] denote disjoint sets of strings -- we simply
 *  check whether their intersection is equivalent to [Zero_r]. *)
Definition ckdisj_r (n:nat) (r1 r2:rexp) := ckzero n (OptAnd_r r1 r2).

(** Correctness of [ckdisj_r]. *)
Lemma ckdisj_r_corr n r1 r2 : ckdisj_r n r1 r2 = true -> ~(exists s, in_rexp r1 s /\
  in_rexp r2 s).
Proof.
  unfold ckdisj_r ; intros. generalize (ckzero_corr n H).  intros. intro.
  apply H0. mysimp. exists x. apply opt_and_r_corr. auto.
Qed.

(** Lift [ckdisj_r] to operate on parsers. *)
Definition ckdisj_p (n:nat) t (p1:parser t) (p2:parser t) :=
  ckdisj_r n (parser2rexp p1) (parser2rexp p2).

(** Correctness of [ckdisj_p] -- here we see that if [p1] and [p2] are disjoint,
 *  then there is no string [s] and values [v1] and [v2], such that [s] and [v1]
 *  are in the denotation of [p1], and [s] and [v2] are in the denotation of [p2]. *)
Lemma ckdisj_p_corr n t (p1 p2:parser t) :
  ckdisj_p n p1 p2 = true -> ~(exists s, exists v1, exists v2, in_parser p1 s v1 /\
    in_parser p2 s v2).
Proof.
  unfold ckdisj_p. intros. intro. generalize (ckdisj_r_corr _ H). intros. mysimp.
  apply H1. exists x. split ; eapply parse2rexp_corr1 ; eauto.
Qed.

(** Multi [OptAlt_r]. *)
Definition alts_r := List.fold_right OptAlt_r Zero_r.

(** Count up from [i] to [m] and try to check if [r] is equivalent to [Zero_r]
 *  using [i] as the bound.  This tries to avoid checking to deeply when it's
 *  not necessary. *)
Fixpoint ckzeros i m r :=
  match i with
    | 0%nat => false
    | S i => ckzero (m - (S i)) r || ckzeros i m r
  end.

(** Correctness of [ckzeros]. *)
Lemma ckzeros_corr : forall i m r,
  ckzeros i m r = true -> ~ (exists s, in_rexp r s).
Proof.
  induction i ; simpl ; intros. congruence. intro.
  generalize (@ckzero_corr (m - S i) r). intro.
  destruct (ckzero (m - S i) r). apply H1 ; auto. simpl in H.
  apply (IHi _ _ H). auto.
Qed.

(** [check_all_r] checks that all [rexp]s in the list [rs] are mutually disjoint.
 *  I tried a divide and conquer strategy, where we do O(n lg n) tests but it
 *  turns out to be no faster than this rather brute force approach because the
 *  derivatives were growing.  Here, we do O(n^2) tests which is still better
 *  than doing all pair-wise comparisons. *)
Fixpoint check_all_r m (rs:list rexp) :=
  match rs with
    | nil => true
    | r::rs => check_all_r m rs && ckzeros m m (OptAnd_r r (alts_r rs))
  end.

(** Correctness of [check_all_r]:  If [check_all_r m rs] returns [true], then
 *  we know that if [s] is in the denotation of [alts_r rs], then there is some
 *  [r] in [rs], such that [s] is in the denotation of [r], and furthermore,
 *  [s] is not in the denotation of any of the rest of the [rexp]s. *)
Lemma check_all_r_corr m rs :
  check_all_r m rs = true ->
  forall s, in_rexp (alts_r rs) s ->
    exists rs1, exists r, exists rs2,
      rs = rs1 ++ r::rs2 /\
      in_rexp r s /\ ~ in_rexp (alts_r (rs1 ++ rs2)) s.
Proof.
  induction rs ; simpl ; intros. in_inv.
  generalize (proj2 (opt_alt_r_corr a (alts_r rs) s) H0). clear H0. intro.
  remember (check_all_r m rs) as e. destruct e ; simpl in * ; try congruence.
  specialize (IHrs (eq_refl _) s). generalize (ckzeros_corr m m H). intros.
  inversion H0. subst. exists nil. exists a. exists rs. simpl. split ; auto.
  split. auto. intro. apply H1. exists s. apply opt_and_r_corr. eauto. subst.
  specialize (IHrs H5). destruct IHrs. destruct H2. destruct H2. destruct H2.
  destruct H3. subst. exists (a::x). exists x0. exists x1. simpl. split.
  auto. split. auto. intro. apply H1. exists s.
  generalize (proj2 (opt_alt_r_corr _ _ _) H2). clear H2. intro.
  apply opt_and_r_corr.
  constructor. inversion H2. subst. auto. subst. contradiction H4 ; auto.
  apply H5.
Qed.

(** Lift [check_all_r] up to parsers. *)
Definition check_all_p m t (ps:list (parser t)) :=
  check_all_r m (List.map (@parser2rexp _) ps).

Fixpoint check_all_r' m (rs:list rexp) :=
  match rs with
    | nil => true
    | r::rs =>
      check_all_r' m rs &&
      ckzeros m m (OptAnd_r (OptCat_r (alts_r rs) (Star_r Any_r)) (OptCat_r r (Star_r Any_r)))
  end.

Definition check_all_p' m t (ps:list (parser t)) :=
  check_all_r' m (List.map (@parser2rexp _) ps).

Lemma all_instructions_check :
  check_all_p' 3 instruction_parser_list = true.
Proof.
  Time vm_compute. auto.
Qed.

Lemma star_any_all : forall s, in_rexp (Star_r Any_r) s.
Proof.
  induction s. econstructor. replace (a::s) with ((a::nil) ++ s) ; auto.
  eapply Star_cat_ri ; eauto. congruence.
Qed.

Lemma check_all_r'_corr m rs :
  check_all_r' m rs = true ->
  forall s, in_rexp (alts_r rs) s ->
    exists rs1, exists r, exists rs2,
      rs = rs1 ++ r :: rs2 /\
      in_rexp r s /\ ~ exists s2, in_rexp (alts_r (rs1 ++ rs2)) (s ++ s2).
Proof.
  induction rs ; simpl ; intros. in_inv.
  generalize (proj2 (opt_alt_r_corr a (alts_r rs) s) H0). clear H0. intro.
  remember (check_all_r' m rs) as e. destruct e ; simpl in * ; try congruence.
  specialize (IHrs (eq_refl _) s). generalize (ckzeros_corr m m H). intros.
  inversion H0 ; clear H0. subst. exists nil. exists a. exists rs. simpl. split ; auto.
  split ; auto. intro. apply H1. destruct H0. exists (s ++ x). apply opt_and_r_corr.
  econstructor. eapply opt_cat_r_corr. rewrite app_nil_end. econstructor.
  eauto. econstructor. auto. eapply opt_cat_r_corr. generalize (star_any_all x).
  intros. econstructor ; eauto.
  subst. specialize (IHrs H5). destruct IHrs. destruct H0. destruct H0. destruct H0.
  destruct H2. subst. exists (a::x). exists x0. exists x1. simpl. split ; auto.
  split ; auto. intro. destruct H0. generalize (proj2 (opt_alt_r_corr a _ (s++x2)) H0).
  clear H0. intro. inversion H0 ; clear H0 ; subst. clear H Heqe.
  contradiction H1. exists (s ++ x2). apply opt_and_r_corr. constructor.
  apply opt_cat_r_corr. econstructor. eapply H5. eapply (star_any_all x2). auto.
  apply opt_cat_r_corr. econstructor. eapply H8. eapply (star_any_all nil).
  rewrite app_ass. rewrite <- app_nil_end. auto. contradiction H3.
  exists x2. auto.
Qed.

(** Lemma for reasoning about [alts]. *)
Lemma in_alts t (ps:list (parser t)) s v:
  in_parser (alts ps) s v -> in_rexp (alts_r (List.map (@parser2rexp _) ps)) s.
Proof.
  induction ps ; simpl ; intros. unfold never in *. inversion H.
  apply opt_alt_r_corr. inversion H ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. eapply Alt_left_ri. eapply parse2rexp_corr1. eauto.
  eapply Alt_right_ri. eauto.
Qed.

(** A sort of injection lemma for [List.map] over lists. *)
Lemma map_split : forall A B (f:A -> B) (ys1:list B) (y:B) (ys2:list B) (xs:list A),
  List.map f xs = ys1 ++ y::ys2 ->
  exists xs1, exists x, exists xs2,
    xs = xs1 ++ x :: xs2 /\
    ys1 = List.map f xs1 /\
    y = f x /\
    ys2 = List.map f xs2.
Proof.
  induction ys1 ; simpl ; intros ; destruct xs ; simpl in * ; try congruence.
  exists nil. exists a. exists xs. injection H. intros. subst. simpl. auto.
  injection H. intros. subst. specialize (IHys1 y ys2 xs H0). s.
  exists (a0 :: x). exists x0. exists x1. simpl. auto.
Qed.

(** Denotation of [alts] is commutative. *)
Lemma in_alts_comm t (ps1:list (parser t)) (p:parser t) (ps2:list (parser t)) s v :
  in_parser (alts (ps1 ++ p :: ps2)) s v ->
  in_parser (Alt_p p (alts (ps1 ++ ps2))) s v.
Proof.
  induction ps1. simpl. auto. intros. simpl in *. inversion H ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end.  apply Alt_right_pi. apply Alt_left_pi. auto.
  specialize (IHps1 p ps2 s v H4). inversion IHps1 ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. apply Alt_left_pi.   auto. apply Alt_right_pi. apply Alt_right_pi. auto.
Qed.

(** [check_all_p] is correct -- if [check_all_p m ps] returns [true], then
 *  if [s] and [v] are in the denotation of [alts ps], then we know there is
 *  a unique [p] in [ps] such that [s] and [v] are in the denotation of [p],
 *  but that [s] is not in the denotation of any other parser in [ps]. *)
Lemma check_all_p_corr m t (ps:list (parser t)) :
  check_all_p m ps = true ->
  forall s v,
    in_parser (alts ps) s v ->
    (exists ps1, exists p, exists ps2,
      ps = ps1 ++ p :: ps2 /\
      in_parser p s v /\
      ~ exists v' : result_m t, in_parser (alts (ps1 ++ ps2)) s v').
Proof.
  unfold check_all_p. intros. generalize (check_all_r_corr m _ H). intros.
  specialize (H1 s (in_alts _ H0)). destruct H1. destruct H1. destruct H1.
  destruct H1. destruct H2. generalize (map_split (@parser2rexp t) x x0 x1 ps H1).
  intros. mysimp. subst. exists x2. exists x3. exists x4. split. auto.
  generalize (in_alts_comm x2 x3 x4 H0). intros.
  assert (~ exists v', in_parser (alts (x2 ++ x4)) s v'). intro.
  destruct H5. apply H3. generalize (in_alts (x2 ++ x4) H5). rewrite map_app. auto.
  split ; auto. inversion H4 ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. auto. contradiction H5. eauto.
Qed.

Lemma check_all_p'_corr m t (ps:list (parser t)) :
  check_all_p' m ps = true ->
  forall s v,
    in_parser (alts ps) s v ->
    (exists ps1, exists p, exists ps2,
      ps = ps1 ++ p :: ps2 /\
      in_parser p s v /\
      ~ exists s2, exists v' : result_m t, in_parser (alts (ps1 ++ ps2)) (s++s2) v').
Proof.
  unfold check_all_p. intros. generalize (check_all_r'_corr m _ H). intros.
  specialize (H1 s (in_alts _ H0)). destruct H1. destruct H1. destruct H1.
  destruct H1. destruct H2. generalize (map_split (@parser2rexp t) x x0 x1 ps H1).
  intros. mysimp. subst. exists x2. exists x3. exists x4. split. auto.
  generalize (in_alts_comm x2 x3 x4 H0). intros.
  assert (~ exists s2, exists v', in_parser (alts (x2 ++ x4)) (s ++ s2) v'). intro.
  destruct H5. destruct H5.
  apply H3. exists x. generalize (in_alts (x2 ++ x4) H5). rewrite map_app. auto.
  split ; auto. inversion H4 ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. auto. contradiction H5. exists nil. rewrite <- app_nil_end. eauto.
Qed.

(** Check that all of the instruction parsers are mutually disjoint -- if you
 *  pass in a number like 3 this should evaluate to true -- but it takes a
 *  really long time.  So I suggest extracting this function and running it
 *  in ML. *)
Definition check_all_instructions m := check_all_p m instruction_parser_list.

Transparent token_id_to_chars.
Transparent num_tokens.

Lemma all_instructions_disjoint : check_all_instructions 3 = true.
Proof.
  unfold check_all_instructions.
  vm_compute.
  auto.
Qed.

Opaque instruction_parser_list.

Ltac t := repeat
  match goal with
    | [ H : _ /\ _ |- _ ] => destruct H
    | [ H : exists _, _ |- _ ] => destruct H
    | [ |- forall _, _ ] => intros
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end.

(** If [s] and [v] are in the denotation of [alts (p::(ps1++ps2))] then
 *  [s] and [v] are in the denotation of [alts (ps1++p::ps2)]. *)
Lemma in_alts_comm' : forall t (ps1 ps2:list (parser t)) (p:parser t) s v,
  in_parser (alts (p :: (ps1 ++ ps2))) s v ->
  in_parser (alts (ps1 ++ p :: ps2)) s v.
Proof.
  induction ps1. simpl. auto. intros. simpl in *. inversion H  ; clear H ; t.
  eapply Alt_right_pi. eapply IHps1. eapply Alt_left_pi. auto.
  inversion H4  ; clear H4 ; t. eapply Alt_left_pi. auto.
  eapply Alt_right_pi. eapply IHps1. eapply Alt_right_pi. auto.
Qed.

(** If [s] and [v] are in the denotation of [alts (ps1 ++ p :: ps2)], and
 *  [s] and [v] are also in the denotation of [p] and not in the
 *  denotation of [alts (ps1 ++ ps2)], then if we split [ps1++p::ps2] into
 *  some other [ps1'++p'::ps2'] such that [s] and [v] are in [p'], then
 *  [ps1=ps1'] and [p=p'] and [ps2=ps2']. *)
Lemma splits_unique t (ps : list (parser t)) :
  forall s v,
    in_parser (alts ps) s v ->
    forall ps1 p ps2,
      ps = ps1 ++ p :: ps2 ->
      in_parser p s v /\ (~ exists v', in_parser (alts (ps1 ++ ps2)) s v') ->
      forall ps1' p' ps2' v',
        ps = ps1' ++ p' :: ps2' /\ in_parser p' s v' ->
        ps1 = ps1' /\ p = p' /\ ps2 = ps2'.
Proof.
  induction ps. simpl. intros. destruct ps1 ; simpl in * ; congruence. t.
  destruct ps1. injection H0 ; clear H0 ; intros ; subst.
  destruct ps1'. injection H2 ; clear H2 ; intros ; subst ; auto.
  simpl in *. injection H2 ; clear H2 ; intros ; subst. contradiction H4.
  exists v'. eapply in_alts_comm'. simpl. eapply Alt_left_pi ; eauto.
  simpl in *. injection H0 ; intros ; subst ; clear H0.
  destruct ps1' ; simpl in *. injection H2 ; intros ; clear H2 ; subst.
  contradiction H4. exists v'. eapply Alt_left_pi ; eauto.
  injection H2. clear H2 ; intros ; subst. inversion H ; t ; clear H.
  contradiction H4. exists v. eapply Alt_left_pi ; eauto.
  assert (~ exists v', in_parser (alts (ps1 ++ ps2)) s v').
  intro. apply H4. t. exists x. eapply Alt_right_pi. eauto.
  specialize (IHps _ _ H8 ps1 p ps2 (eq_refl _) (conj H1 H) ps1' p' ps2' v' (conj H0 H3)).
  t. subst. auto.
Qed.

(** If [s] and [v] are in the denotation of [alts ps], then there is
 *  some [ps1++p::ps2=ps] such that [s] and [v] are in the denotation of [p]. *)
Lemma in_alts_split : forall t (ps:list (parser t)) s v,
  in_parser (alts ps) s v ->
  exists ps1, exists p, exists ps2,
    ps = ps1 ++ p :: ps2 /\ in_parser p s v.
Proof.
  induction ps ; simpl. unfold never. intros. inversion H.
  intros. inversion H ; clear H ; t. exists nil. exists a. exists ps. auto.
  specialize (IHps s v H4). in_inv. exists (a::x). exists x0. exists x1. auto.
Qed.

(** If [p] is an element of [ps] and [s] and [v] are in the denotation of
 *  [p], then they are also in the denotation of [alts ps]. *)
Lemma elt_in_alts : forall t (p:parser t) (ps:list (parser t)) s v,
  In p ps ->
  in_parser p s v ->
  in_parser (alts ps) s v.
Proof.
  induction ps ; simpl ; intros. contradiction H. destruct H. subst.
  apply Alt_left_pi. auto. apply Alt_right_pi. auto.
Qed.

(** If [s] and [v] are in the denotation of [alts ps1] and [ps1] is
 *  a subset of [ps2], then [s] and [v] are also in [alts ps2]. *)
Lemma subset_in : forall t (ps1 ps2 : list (parser t)) s v,
  in_parser (alts ps1) s v ->
  (forall p, In p ps1 -> In p ps2) ->
  in_parser (alts ps2) s v.
Proof.
  induction ps1. simpl. intros. unfold never in *. inversion H. simpl.
  intros. inversion H ; clear H ; repeat
  match goal with
    | [ H : existT _ _ _ = existT _ _ _ |- _ ] =>
      generalize (inj_pairT2 _ _ _ _ _ H) ; clear H ; intros ; subst
  end. assert (In a ps2).  apply H0. left ; auto. eapply elt_in_alts ; eauto. auto.
Qed.

Lemma in_splits A (x:A) (xs:list A) :
  In x xs -> exists xs1, exists xs2, xs = xs1 ++ x :: xs2.
Proof.
  induction xs ; simpl ; t. contradiction H. destruct H. subst.
  exists nil. exists xs. auto. specialize (IHxs H). t. subst.
  exists (a::x0). exists x1. auto.
Qed.

Lemma splits_in A (x:A) (x1s x2s:list A) :
  In x (x1s ++ x::x2s).
Proof.
  induction x1s ; simpl ; auto.
Qed.

(** If all of the [ps] are disjoint (according to [check_all_p]), then
 *  for each subset [p1s] of [ps], if [s] and [v] are in [alts ps1] then
 *  they are also in [alts ps] and if [s] and [v'] are in [alts ps] then
 *  [s] and [v'] are in [alts p1s].  *)
Lemma parse_split' :
  forall t m (ps:list (parser t)), check_all_p m ps = true ->
  forall p1s s v,
  (forall p, In p p1s -> In p ps) ->
  in_parser (alts p1s) s v ->
  in_parser (alts ps) s v /\
  (forall v', in_parser (alts ps) s v' ->
    in_parser (alts p1s) s v').
Proof.
  t. split. generalize (in_alts_split p1s H1). t. subst. eapply subset_in ; eauto.
  t. generalize (check_all_p_corr m _ H H2). clear m H. t.
  generalize (in_alts_split _ H1). t. assert (In x3 p1s). rewrite H5. apply splits_in.
  generalize (H0 _ H7). intros. generalize (@in_splits _ _ _ H8). t.
  generalize (@splits_unique _ _ _ _ H2 _ _ _ H (conj H3 H4) x5 x3 x6 v (conj H9 H6)).
  t. subst. generalize (in_alts_comm _ _ _ H2). intros. inversion H5 ; t.
  eapply in_alts_comm'. eapply Alt_left_pi. auto. contradiction H4. eauto.
Qed.

(** This lemma tells us that if we take a sublist [ps] of the parsers in the list of
 *  instruction parsers (e.g., used to build a DFA), and if [ps] accepts some string
 *  [s] and produces some value [v], then (a) running the heavyweight parser will also
 *  accept [s] and produce [v], and (b) if the heavyweight parser can produce a
 *  different value [v'] from [s], then [ps] can do that as well.  So if [ps] is
 *  deterministic, then running either [ps] or the heavyweight parser will result
 *  in at most one unique value [v].
 *)
Lemma parse_split :
  forall ps,
    (forall p, In p ps -> In p instruction_parser_list) ->
    forall s v,
      in_parser (alts ps) s v ->
        in_parser (alts instruction_parser_list) s v /\
        (forall v', in_parser (alts instruction_parser_list) s v' -> in_parser (alts ps) s v').
Proof.
  intros. apply (parse_split' 3 instruction_parser_list all_instructions_disjoint _ H H0).
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics.
Require Import Types.
Require Import Cubical.
Require Import WildCat.
Require Import Colimits.Pushout.
Require Import NullHomotopy.
Require Import Truncations.
Require Import Extensions.
Import TrM.

(** * The suspension of a type *)

Generalizable Variables X A B f g n.

Local Open Scope path_scope.

(** TODO: remove and replace with HIT description. *)
(* ** Definition of suspension. *)
(*
Module Export Suspension.

(** We ensure that [Susp X] does not live in a lower universe than [X] *)
Private Inductive Susp (X : Type@{i}) : Type@{i} :=
  | North : Susp X
  | South : Susp X.

Global Arguments North {X}.
Global Arguments South {X}.

Axiom merid : forall (X : Type) (x : X), North = South :> Susp X.
Global Arguments merid {X} x.

Definition Susp_ind {X : Type} (P : Susp X -> Type)
  (H_N : P North) (H_S : P South)
  (H_merid : forall x:X, (merid x) # H_N = H_S)
: forall (y:Susp X), P y
:= fun y => (match y return (_ -> P y)
     with North => (fun _ => H_N) | South => (fun _ => H_S) end) H_merid.

Axiom Susp_ind_beta_merid : forall {X : Type} (P : Susp X -> Type)
  (H_N : P North) (H_S : P South)
  (H_merid : forall x:X, (merid x) # H_N = H_S)
  (x:X),
apD (Susp_ind P H_N H_S H_merid) (merid x) = H_merid x.

End Suspension. *)

(* ** Definition of suspension *)

Definition Susp (X : Type) := Pushout (@const X _ tt) (const tt).
Definition North {X} : Susp X := pushl tt.
Definition South {X} : Susp X := pushr tt.
Definition merid {X} (x : X) : North = South := pglue x.

Definition Susp_ind {X : Type} (P : Susp X -> Type)
  (H_N : P North) (H_S : P South)
  (H_merid : forall x:X, (merid x) # H_N = H_S)
  : forall (y : Susp X), P y.
Proof.
  serapply Pushout_ind.
  - exact (Unit_ind H_N).
  - exact (Unit_ind H_S).
  - exact (H_merid).
Defined.

Definition Susp_ind_dp {X : Type} (P : Susp X -> Type)
  (H_N : P North) (H_S : P South)
  (H_merid : forall x:X, DPath P (merid x) H_N H_S)
  : forall (y : Susp X), P y.
Proof.
  serapply Susp_ind.
  - exact H_N.
  - exact H_S.
  - intro x.
    apply dp_path_transport^-1.
    exact (H_merid x).
Defined.

Definition Susp_ind_beta_merid {X : Type}
  (P : Susp X -> Type) (H_N : P North) (H_S : P South)
  (H_merid : forall x:X, (merid x) # H_N = H_S) (x : X)
  : apD (Susp_ind P H_N H_S H_merid) (merid x) = H_merid x.
Proof.
  serapply Pushout_ind_beta_pglue.
Defined.

Definition Susp_ind_dp_beta_merid {X : Type}
  (P : Susp X -> Type) (H_N : P North) (H_S : P South)
  (H_merid : forall x:X, DPath P (merid x) H_N H_S) (x : X)
  : dp_apD (Susp_ind_dp P H_N H_S H_merid) (merid x) = H_merid x.
Proof.
  apply dp_apD_path_transport.
  serapply Susp_ind_beta_merid.
Defined.

(** We want to allow the user to forget that we've defined suspension in this way. *)
Arguments Susp : simpl never.
Arguments North : simpl never.
Arguments South : simpl never.
Arguments merid : simpl never.
Arguments Susp_ind_beta_merid : simpl never.

(* ** Non-dependent eliminator. *)

Definition Susp_rec {X Y : Type}
  (H_N H_S : Y) (H_merid : X -> H_N = H_S)
: Susp X -> Y.
Proof.
  apply (Susp_ind (fun _ => Y) H_N H_S).
  intros x. exact (transport_const _ _ @ H_merid x).
Defined.

Global Arguments Susp_rec {X Y}%type_scope H_N H_S H_merid%function_scope _.

Definition Susp_rec_beta_merid {X Y : Type}
  {H_N H_S : Y} {H_merid : X -> H_N = H_S} (x:X)
: ap (Susp_rec H_N H_S H_merid) (merid x) = H_merid x.
Proof.
  apply (cancelL (transport_const (merid x) H_N)).
  transitivity (apD (Susp_rec H_N H_S H_merid) (merid x)).
  - symmetry; refine (apD_const (Susp_rec H_N H_S H_merid) _).
  - refine (Susp_ind_beta_merid (fun _ : Susp X => Y) _ _ _ _).
Defined.

(** ** Eta-rule. *)

(** The eta-rule for suspension states that any function out of a suspension is equal to one defined by [Susp_ind] in the obvious way. We give it first in a weak form, producing just a pointwise equality, and then turn this into an actual equality using [Funext]. *)
Definition Susp_eta_homot {X : Type} {P : Susp X -> Type} (f : forall y, P y)
  : f == Susp_ind P (f North) (f South) (fun x => apD f (merid x)).
Proof.
  unfold pointwise_paths. refine (Susp_ind _ 1 1 _).
  intros x.
  refine (transport_paths_FlFr_D
    (g := Susp_ind P (f North) (f South) (fun x : X => apD f (merid x)))
    _ _ @ _); simpl.
  apply moveR_pM. apply (concat (concat_p1 _)), (concatR (concat_1p _)^).
  apply ap, inverse. refine (Susp_ind_beta_merid _ _ _ _ _).
Defined.

Definition Susp_eta_homot_dp {X : Type} {P : Susp X -> Type} (f : forall y, P y)
  : f == Susp_ind_dp P (f North) (f South) (fun x => dp_apD f (merid x)).
Proof.
  unfold pointwise_paths. refine (Susp_ind_dp _ 1 1 _).
  intros x.
  apply dp_paths_FlFr_D.
  cbn.
  refine (concat_pp_p _ _ _ @ _).
  apply moveR_Vp.
  refine (concat_1p _ @ _ @ (concat_p1 _)^).
  apply (equiv_inj dp_path_transport).
  refine (dp_path_transport_apD _ _ @ _).
  refine (_ @ (dp_path_transport_apD f (merid x))^).
  serapply Susp_ind_dp_beta_merid.
Defined.

Definition Susp_rec_eta_homot {X Y : Type} (f : Susp X -> Y)
: f == Susp_rec (f North) (f South) (fun x => ap f (merid x)).
Proof.
  refine (Susp_ind _ 1 1 _).
  intro x.
  refine ((transport_paths_FlFr _ _) @ _). apply moveR_Mp.
  refine ((Susp_rec_beta_merid _) @ _). hott_simpl.
  refine (_ @ (ap_V f _)). f_ap.
  refine (inv_V _)^.
Defined.

Definition Susp_eta `{Funext}
  {X : Type} {P : Susp X -> Type} (f : forall y, P y)
  : f = Susp_ind P (f North) (f South) (fun x => apD f (merid x))
:= path_forall _ _ (Susp_eta_homot f).

Definition Susp_rec_eta `{Funext} {X Y : Type} (f : Susp X -> Y)
  : f = Susp_rec (f North) (f South) (fun x => ap f (merid x))
:= path_forall _ _ (Susp_rec_eta_homot f).

(** ** Functoriality *)

Definition functor_susp {X Y : Type} (f : X -> Y)
  : Susp X -> Susp Y.
Proof.
  serapply Susp_rec.
  - exact North.
  - exact South.
  - intros x; exact (merid (f x)).
Defined.

Definition ap_functor_susp_merid {X Y : Type} (f : X -> Y) (x : X)
  : ap (functor_susp f) (merid x) = merid (f x).
Proof.
  serapply Susp_rec_beta_merid.
Defined.

(** ** Universal property *)

Definition equiv_Susp_rec `{Funext} (X Y : Type)
: (Susp X -> Y) <~> { NS : Y * Y & X -> fst NS = snd NS }.
Proof.
  unshelve econstructor.
  { intros f.
    exists (f North , f South).
    intros x. exact (ap f (merid x)). }
  simple refine (isequiv_adjointify _ _ _ _).
  - intros [[N S] m].
    exact (Susp_rec N S m).
  - intros [[N S] m].
    apply ap, path_arrow. intros x; apply Susp_rec_beta_merid.
  - intros f.
    symmetry.
    refine (Susp_eta f @ _).
    unfold Susp_rec; apply ap.
    apply path_forall; intros x.
    apply apD_const.
Defined.

(** Using wild 0-groupoids, the universal property can be proven without funext.  A simple equivalence of 0-groupoids between [Susp X -> Y] and [{ NS : Y * Y & X -> fst NS = snd NS }] would not carry all the higher-dimensional information, but if we generalize it to dependent functions, then it does suffice. *)
Section UnivProp.
  Context (X : Type) (P : Susp X -> Type).

  (** Here is the domain of the equivalence: sections of [P] over [Susp X]. *)
  Definition Susp_ind_type := forall z:Susp X, P z.

  Local Instance is01cat_Susp_ind_type : Is01Cat Susp_ind_type.
  Proof. apply is01cat_forall; intros; apply is01cat_paths. Defined.

  Local Instance is0gpd_Susp_ind_type : Is0Gpd Susp_ind_type.
  Proof. apply is0gpd_forall; intros; apply is0gpd_paths. Defined.

  (** The codomain is a sigma-groupoid of this family, consisting of input data for [Susp_ind]. *)
  Definition Susp_ind_data' (NS : P North * P South)
    := forall x:X, DPath P (merid x) (fst NS) (snd NS).

  Local Instance is01cat_Susp_ind_data' NS : Is01Cat (Susp_ind_data' NS).
  Proof. apply is01cat_forall; intros; apply is01cat_paths. Defined.

  Local Instance is0gpd_Susp_ind_data' NS : Is0Gpd (Susp_ind_data' NS).
  Proof. apply is0gpd_forall; intros; apply is0gpd_paths. Defined.

  (** Here is the codomain itself. *)
  Definition Susp_ind_data := sig Susp_ind_data'.

  Local Instance is01cat_Susp_ind_data : Is01Cat Susp_ind_data.
  Proof. rapply is01cat_sigma. Defined.

  Local Instance is0gpd_Susp_ind_data : Is0Gpd Susp_ind_data.
  Proof. rapply is0gpd_sigma. Defined.

  (** Here is the functor. *)
  Definition Susp_ind_inv : Susp_ind_type -> Susp_ind_data.
  Proof.
    intros f.
    exists (f North,f South).
    intros x.
    exact (dp_apD f (merid x)).
  Defined.

  Local Instance is0functor_susp_ind_inv : Is0Functor Susp_ind_inv.
  Proof.
    constructor; unfold Susp_ind_type; cbn.
    intros f g p.
    unshelve econstructor.
    - apply path_prod; apply p.
    - intros x.
      rewrite transport_path_prod, !transport_forall_constant; cbn.
      apply equiv_ds_transport_dpath.
      exact (dp_apD_nat p (merid x)).
  Defined.

  (** And now we can prove that it's an equivalence. *)
  Definition equiv0gpd_Susp_ind_inv : IsEquiv0Gpd Susp_ind_inv.
  Proof.
    constructor.
    - intros [[n s] g].
      exists (Susp_ind_dp P n s g); cbn.
      exists idpath.
      intros x; cbn.
      apply Susp_ind_dp_beta_merid.
    - intros f g [p q]; cbn in *.
      serapply Susp_ind_dp; cbn.
      1:exact (ap fst p).
      1:exact (ap snd p).
      intros x; specialize (q x).
      apply equiv_sq_dp_D.
      apply equiv_ds_transport_dpath.
      rewrite transport_forall_constant in q.
      rewrite <- (eta_path_prod p) in q.
      rewrite transport_path_prod in q.
      exact q.
  Defined.

End UnivProp.

(** The full non-funext version of the universal property should be formulated with respect to a notion of "wild hom-oo-groupoid", which we don't currently have.  However, we can deduce statements about full higher universal properties that we do have, for instance the statement that a type is local for [functor_susp f] -- expressed in terms of [ooExtendableAlong] -- if and only if all its identity types are local for [f].  (We will use this in [Modalities.Localization] for separated subuniverses.)  To prove this, we again generalize it to the case of dependent types, starting with naturality of the above 0-dimensional universal property. *)

Section UnivPropNat.
  (** We will show that [Susp_ind_inv] for [X] and [Y] commute with precomposition with [f] and [functor_susp f]. *)
  Context {X Y : Type} (f : X -> Y) (P : Susp Y -> Type).

  (** We recall all those instances from the previous section. *)
  Local Existing Instances is01cat_Susp_ind_type is0gpd_Susp_ind_type is01cat_Susp_ind_data' is0gpd_Susp_ind_data' is01cat_Susp_ind_data is0gpd_Susp_ind_data.

  (** Here is an intermediate family of groupoids that we have to use, since precomposition with [f] doesn't land in quite the right place. *)
  Definition Susp_ind_data'' (NS : P North * P South)
    := forall x:X, DPath P (merid (f x)) (fst NS) (snd NS).

  Local Instance is01cat_Susp_ind_data'' NS : Is01Cat (Susp_ind_data'' NS).
  Proof. apply is01cat_forall; intros; apply is01cat_paths. Defined.

  Local Instance is0gpd_Susp_ind_data'' NS : Is0Gpd (Susp_ind_data'' NS).
  Proof. apply is0gpd_forall; intros; apply is0gpd_paths. Defined.

  (** We decompose "precomposition with [f]" into a functor_sigma of two fiberwise functors.  Here is the first. *)
  Definition functor_Susp_ind_data'' (NS : P North * P South)
    : Susp_ind_data' Y P NS -> Susp_ind_data'' NS
    := fun g x => g (f x).

  Local Instance is0functor_functor_Susp_ind_data'' NS
    : Is0Functor (functor_Susp_ind_data'' NS).
  Proof.
    constructor.
    intros g h p a.
    exact (p (f a)).
  Defined.

  (** And here is the second.  This one is actually a fiberwise equivalence of types at each [x]. *)
  Definition equiv_Susp_ind_data' (NS : P North * P South) (x : X)
    : DPath P (merid (f x)) (fst NS) (snd NS)
      <~> DPath (P o functor_susp f) (merid x) (fst NS) (snd NS).
  Proof.
    etransitivity.
    - apply (equiv_transport (fun p => DPath P p (fst NS) (snd NS))).
      symmetry; apply ap_functor_susp_merid.
    - symmetry.
      apply (dp_compose (functor_susp f) P (merid x)).
  Defined.

  Definition functor_Susp_ind_data' (NS : P North * P South)
    : Susp_ind_data'' NS -> Susp_ind_data' X (P o functor_susp f) NS.
  Proof.
    serapply (functor_forall idmap); intros x.
    apply equiv_Susp_ind_data'.
  Defined.

  Local Instance is0functor_functor_Susp_ind_data' NS
    : Is0Functor (functor_Susp_ind_data' NS).
  Proof.
    constructor.
    intros g h q x.
    cbn; apply ap, ap.
    exact (q x).
  Defined.

  (** And therefore a fiberwise equivalence of 0-groupoids. *)
  Local Instance isequiv0gpd_functor_Susp_ind_data' NS
    : IsEquiv0Gpd (functor_Susp_ind_data' NS).
  Proof.
    constructor.
    - intros g.
      unshelve econstructor.
      + intros x.
        apply ((equiv_Susp_ind_data' NS x)^-1).
        exact (g x).
      + intros x.
        apply eisretr.
    - intros g h p x.
      apply (equiv_inj (equiv_Susp_ind_data' NS x)).
      exact (p x).
  Defined.

  (** Now we put them together. *)
  Definition functor_Susp_ind_data
    : Susp_ind_data Y P -> Susp_ind_data X (P o functor_susp f)
    := fun NSg => (NSg.1 ; (functor_Susp_ind_data' NSg.1 o
                             (functor_Susp_ind_data'' NSg.1)) NSg.2).

  Local Instance is0functor_functor_Susp_ind_data
    : Is0Functor functor_Susp_ind_data.
  Proof.
    refine (is0functor_sigma _ _
           (fun NS => functor_Susp_ind_data' NS o functor_Susp_ind_data'' NS)).
  Defined.

  (** Here is the "precomposition with [functor_susp f]" functor. *)
  Definition functor_Susp_ind_type
    : Susp_ind_type Y P -> Susp_ind_type X (P o functor_susp f)
    := fun g => g o functor_susp f.

  Local Instance is0functor_functor_Susp_ind_type
    : Is0Functor functor_Susp_ind_type.
  Proof.
    constructor.
    intros g h p a.
    exact (p (functor_susp f a)).
  Defined.

  (** And here is the desired naturality square. *)
  Definition Susp_ind_inv_nat
    : (Susp_ind_inv X (P o functor_susp f)) o functor_Susp_ind_type
      $=> functor_Susp_ind_data o (Susp_ind_inv Y P).
  Proof.
    intros g; exists idpath; intros x.
    change (dp_apD (fun x0 : Susp X => g (functor_susp f x0)) (merid x) =
            (functor_Susp_ind_data (Susp_ind_inv Y P g)).2 x).
    refine (dp_apD_compose (functor_susp f) P (merid x) g @ _).
    cbn; apply ap.
    apply (moveL_transport_V (fun p => DPath P p (g North) (g South))).
    exact (apD (dp_apD g) (ap_functor_susp_merid f x)).
  Defined.

  (** From this we can deduce a equivalence between extendability, which is definitionally equal to split essential surjectivity of a functor between forall 0-groupoids. *)
  Definition extension_iff_functor_susp
    : (forall g, ExtensionAlong (functor_susp f) P g)
      <-> (forall NS g, ExtensionAlong f (fun x => DPath P (merid x) (fst NS) (snd NS)) g).
  Proof.
    (** The proof is by chaining logical equivalences. *)
    transitivity (SplEssSurj functor_Susp_ind_type).
    { reflexivity. }
    etransitivity.
    { refine (isesssurj_iff_commsq Susp_ind_inv_nat); try exact _.
      all:apply equiv0gpd_Susp_ind_inv. }
    etransitivity.
    { refine (isesssurj_iff_sigma _ _
                (fun NS => functor_Susp_ind_data' NS o functor_Susp_ind_data'' NS)). }
    apply iff_functor_forall; intros [N S]; cbn.
    etransitivity.
    { apply iffL_isesssurj; exact _. }
    reflexivity.
  Defined.

  (** We have to close the section now because we have to generalize [extension_iff_functor_susp] over [P]. *)

End UnivPropNat.

(** Now we can iterate, deducing [n]-extendability. *)
Definition extendable_iff_functor_susp
           {X Y : Type} (f : X -> Y) (P : Susp Y -> Type) (n : nat)
  : (ExtendableAlong n (functor_susp f) P)
    <-> (forall NS, ExtendableAlong n f (fun x => DPath P (merid x) (fst NS) (snd NS))).
Proof.
  revert P. induction n as [|n IHn]; intros P; [ split; intros; exact tt | ].
  (** It would be nice to be able to do this proof by chaining logcal equivalences too, especially since the two parts seem very similar.  But I haven't managed to make that work. *)
  split.
  - intros [e1 en] [N S]; split.
    + apply extension_iff_functor_susp.
      exact e1.
    + cbn; intros h k.
      pose (h' := Susp_ind_dp P N S h).
      pose (k' := Susp_ind_dp P N S k).
      specialize (en h' k').
      assert (IH := fst (IHn _) en (1,1)); clear IHn en.
      cbn in IH.
      refine (extendable_postcompose' n _ _ f _ IH); clear IH.
      intros y.
      etransitivity.
      1:symmetry; apply equiv_sq_dp_D.
      etransitivity.
      1:apply equiv_ds_transport_dpath.
      subst h' k'; cbn.
      apply equiv_concat_lr.
      * symmetry. exact (Susp_ind_dp_beta_merid P N S h y).
      * exact (Susp_ind_dp_beta_merid P N S k y).
  - intros e; split.
    + apply extension_iff_functor_susp.
      intros NS; exact (fst (e NS)).
    + intros h k.
      apply (IHn _).
      intros [p q].
      specialize (e (h North, k South)).
      cbn in *; apply snd in e.
      refine (extendable_postcompose' n _ _ f _ (e _ _)); intros y.
      etransitivity.
      2:apply equiv_sq_dp_D.
      etransitivity.
      2:symmetry;apply equiv_ds_transport_dpath.
      etransitivity.
      2:apply (equiv_moveR_transport_p (fun y0 : P North => DPath P (merid y) y0 (k South))).
      reflexivity.
Defined.

(** As usual, deducing oo-extendability is trivial. *)
Definition ooextendable_iff_functor_susp
           {X Y : Type} (f : X -> Y) (P : Susp Y -> Type)
  : (ooExtendableAlong (functor_susp f) P)
    <-> (forall NS, ooExtendableAlong f (fun x => DPath P (merid x) (fst NS) (snd NS))).
Proof.
  split; intros e.
  - intros NS n.
    apply extendable_iff_functor_susp.
    exact (e n).
  - intros n.
    apply extendable_iff_functor_susp.
    intros NS; exact (e NS n).
Defined.

(** ** Nullhomotopies of maps out of suspensions *)

Definition nullhomot_susp_from_paths {X Z: Type} (f : Susp X -> Z)
  (n : NullHomotopy (fun x => ap f (merid x)))
: NullHomotopy f.
Proof.
  exists (f North).
  refine (Susp_ind _ 1 n.1^ _); intros x.
  refine (transport_paths_Fl _ _ @ _).
  apply (concat (concat_p1 _)), ap. apply n.2.
Defined.

Definition nullhomot_paths_from_susp {X Z: Type} (H_N H_S : Z) (f : X -> H_N = H_S)
  (n : NullHomotopy (Susp_rec H_N H_S f))
: NullHomotopy f.
Proof.
  exists (n.2 North @ (n.2 South)^).
  intro x. apply moveL_pV.
  transitivity (ap (Susp_rec H_N H_S f) (merid x) @ n.2 South).
  - apply whiskerR, inverse, Susp_rec_beta_merid.
  - refine (concat_Ap n.2 (merid x) @ _).
    apply (concatR (concat_p1 _)), whiskerL. apply ap_const.
Defined.

(** ** Contractibility of the suspension *)

Global Instance contr_susp (A : Type) `{Contr A}
  : Contr (Susp A).
Proof.
  unfold Susp; exact _.
Defined.

(** ** Connectedness of the suspension *)

Global Instance isconnected_susp {n : trunc_index} {X : Type}
  `{H : IsConnected n X} : IsConnected n.+1 (Susp X).
Proof.
  apply isconnected_from_elim.
  intros C H' f. exists (f North).
  assert ({ p0 : f North = f South & forall x:X, ap f (merid x) = p0 })
    as [p0 allpath_p0] by (apply (isconnected_elim n); apply H').
  apply (Susp_ind (fun a => f a = f North) 1 p0^).
  intros x.
  apply (concat (transport_paths_Fl _ _)).
  apply (concat (concat_p1 _)).
  apply ap, allpath_p0.
Defined.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Bprime Cprime T : Universe, ((wd_ A Cprime /\ (wd_ O A /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ A Bprime /\ (wd_ C Bprime /\ (wd_ O C /\ (wd_ O B /\ (wd_ B Cprime /\ (wd_ Bprime Cprime /\ (col_ O A C /\ (col_ A Bprime Cprime /\ (col_ A B C /\ (col_ O A Cprime /\ (col_ O A Bprime /\ (col_ O Bprime Cprime /\ (col_ T B Bprime /\ (col_ A C Bprime /\ col_ C T A))))))))))))))))))))))) -> col_ A B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Program.Program.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.
Import List.ListNotations.
Require Import Coq.NArith.NArith.
Require Import MiniP4.Syntax.

Axiom hash: list bool -> list bool.

Fixpoint all_some {A: Type} (l: list (option A)) : option (list A) :=
  match l with
  | [] => Some []
  | x :: l =>
    match x, all_some l with
    | Some x, Some l' => Some (x :: l')
    | _, _ => None
    end
  end.

Definition both_some {A B: Type} (a: option A) (b: option B) : option (A * B) :=
  match a, b with
  | Some a, Some b => Some (a, b)
  | _, _ => None
  end.

Instance bitstring_eq_dec: EqDec bitstring eq := ltac:(typeclasses eauto).
Program Fixpoint val_eqdec (x y: val) : {x = y} + {x <> y} :=
  match x, y with
  | VBits xs, VBits ys => if xs == ys then in_left else in_right
  | VBool x, VBool y => if x == y then in_left else in_right
  | VPair x1 x2, VPair y1 y2 => if val_eqdec x1 y1
                               then if val_eqdec x2 y2
                                    then in_left
                                    else in_right
                               else in_right
  | VUnit, VUnit => in_left
  | _, _ => in_right
  end.
Next Obligation.
  congruence.
Qed.
Next Obligation.
  congruence.
Qed.
Next Obligation.
  intro; subst.
  destruct y.
  - eapply H2; auto.
  - eapply H; auto.
  - eapply H1; auto.
  - eapply H0; auto.
Qed.
Solve All Obligations with (cbn; intros; intuition congruence).

Instance val_eq_dec: EqDec val eq := val_eqdec.

Definition interp_binop (o: binop) '((v1, v2): val * val) : val :=
  match o with
  | Eq => if v1 == v2 then VBits [true] else VBits [false]
  | Neq => if v1 == v2 then VBits [false] else VBits [true]
  end.

Fixpoint to_num (l: list bool) : N :=
  match l with
  | [] => 0
  | true :: l => 1 + 2 * to_num l
  | false :: l => 2 * to_num l
  end.

Fixpoint to_list_positive (n: positive) : list bool :=
  match n with
  | xH => [true]
  | xO n => false :: to_list_positive n
  | xI n => true :: to_list_positive n
  end.

Definition to_list (n: N) : list bool :=
  match n with
  | N0 => [false]
  | Npos n => to_list_positive n
  end.

Program Definition interp_uop (o: uop) (v: val) : option val :=
  match o with
  | Hash =>
    match v with
    | VBits v => Some (VBits (hash v))
    | _ => None
    end
  | Sum =>
    match v with
    | VPair v1 v2 =>
      Some (VBits (match v1, v2 with
                   | VBits b1, VBits b2 => to_list (to_num b1 + to_num b2)%N
                   | _, _ => to_list 0%N
                   end))
    | _ => None
    end
  end.

Fixpoint interp_exp (s: state) (e: exp) : option val :=
  match e with
  | Var x => Env.find x s.(store)
  | EBool b => Some (VBool b)
  | Bits bs => Some (VBits bs)
  | Tuple exp1 exp2 =>
    match interp_exp s exp1, interp_exp s exp2 with
    | Some v1, Some v2 =>
      Some (VPair v1 v2)
    | _, _ => None
    end
  | Proj1 e =>
    match interp_exp s e with
    | Some (VPair v1 _) => Some v1
    | _ => None
    end
  | Proj2 e =>
    match interp_exp s e with
    | Some (VPair _ v2) => Some v2
    | _ => None
    end
  | Tt => Some VUnit
  | BinOp o e1 e2 =>
    option_map (interp_binop o) (both_some (interp_exp s e1) (interp_exp s e2))
  | UOp o e =>
    match interp_exp s e with
    | Some v => interp_uop o v
    | None => None
    end
  end.

Definition set_store (s: state) (e: Env.t name val) : state :=
  {| store := e;
     in_pkt := s.(in_pkt);
     out_pkt := s.(out_pkt) |}.

Definition set_in_pkt (s: state) (pk: list bool) : state :=
  {| store := s.(store);
     in_pkt := pk;
     out_pkt := s.(out_pkt) |}.

Definition grow_out_pkt (s: state) (pk: list bool) : state :=
  {| store := s.(store);
     in_pkt := s.(in_pkt);
     out_pkt := s.(out_pkt) ++ pk |}.

Definition set_type_env (s: def_state) (e: Env.t name typ) : def_state :=
  {| type_env := e;
     tables := s.(tables);
     rules := s.(rules) |}.

Definition set_tables (s: def_state) (e: Env.t name table) : def_state :=
  {| type_env := s.(type_env);
     tables := e;
     rules := s.(rules) |}.

Definition splitn {A} (n: nat) (l: list A) : list A * list A :=
  (firstn n l, skipn n l).

Fixpoint extr (pk: list bool) (t: typ) : option (val * list bool) :=
  match t with
  | Bit n =>
    let '(h, pk) := splitn n pk in
    Some (VBits h, pk)
  | Bool =>
    let '(h, pk) := splitn 1 pk in
    match h with
    | [b] => Some (VBool b, pk)
    | _ => None
    end
  | Prod t1 t2 =>
    match extr pk t1 with
    | Some (v1, pk) =>
      match extr pk t2 with
      | Some (v2, pk) =>
        Some (VPair v1 v2, pk)
      | None => None
      end
    | None => None
    end
  | Unit => Some (VUnit, pk)
  end.

Definition interp_extr (s: state) (x: name) (t: typ) : option state :=
  match extr s.(in_pkt) t with
  | Some (v, pk) =>
    Some {| store := Env.bind x v s.(store);
            in_pkt := pk;
            out_pkt := s.(out_pkt) |}
  | None => None
  end.

Fixpoint emit (v: val) : list bool :=
  match v with
  | VBits bs => bs
  | VBool b => [b]
  | VPair v1 v2 =>
    emit v1 ++ emit v2
  | VUnit => []
  end.

Definition interp_emit (s: state) (v: val) : option state :=
  let bs := emit v in
  Some (grow_out_pkt s bs).

Fixpoint find_rule (k: val) (rules: list rule) : option rule :=
  match rules with
  | r :: rules =>
    if k == r.(rule_match)
    then Some r
    else find_rule k rules
  | [] => None
  end.

Definition assign (s: state) (x: name) (v: val) : state :=
  set_store s (Env.bind x v s.(store)).

Definition bind_arg (s: state) : (name * typ) * val -> state :=
  fun '((x, _), v) => assign s x v.

Definition bind_args (ps: list (name * typ)) (args: list val) (s: state) : option state :=
  if List.length ps == List.length args
  then Some (List.fold_left bind_arg (List.combine ps args) s)
  else None.

Fixpoint interp_act (s: state) (a: action) : option state :=
  match a with
  | ActAssign x e =>
    option_map (assign s x) (interp_exp s e)
  | ActSeq a1 a2 =>
    match interp_act s a1 with
    | Some s => interp_act s a2
    | None => None
    end
  | ActNop =>
    Some s
  end.

Definition interp_table (s: state) (tbl: table) (rules: list rule) : option state :=
  match interp_exp s tbl.(table_key) with
  | Some key =>
    match find_rule key rules with
    | Some r =>
      interp_act s (List.nth r.(rule_action) tbl.(table_acts) ActNop)
    | None => None
    end
  | None => None
  end.

Fixpoint interp_cmd (fuel: nat) (d: def_state) (s: state) (c: cmd) : option state :=
  match fuel with
  | 0 => None
  | S fuel =>
    match c with
    | Assign x e =>
      option_map (assign s x) (interp_exp s e)
    | Nop => Some s
    | Seq c1 c2 =>
      match interp_cmd fuel d s c1 with
      | Some s =>
        interp_cmd fuel d s c2
      | None => None
      end
    | If e c1 c2 =>
      match interp_exp s e with
      | Some (VBits [true]) =>
        interp_cmd fuel d s c1
      | Some _ =>
        interp_cmd fuel d s c2
      | None =>
        None
      end
    | Assume e
    | Assert e =>
      match interp_exp s e with
      | Some (VBits [true]) =>
        Some s
      | Some _ => None
      | None => None
      end
    | Extr x =>
      match Env.find x d.(type_env) with
      | Some t => interp_extr s x t
      | None => None
      end
    | Emit x =>
      match Env.find x s.(store) with
      | Some v => interp_emit s v
      | None => None
      end
    | Apply t =>
      match Env.find t d.(tables), Env.find t d.(rules) with
      | Some tbl, Some rules => interp_table s tbl rules
      | _, _ => None
      end
    end
  end.

Program Fixpoint interp_defn (fuel: nat) (ds: def_state) (s: state) (d: defn) : option (def_state * state) :=
  match d with
  | VarDecl t x e =>
    option_map (fun v => (set_type_env ds (Env.bind x t ds.(type_env)),
                       assign s x v))
               (interp_exp s e)
  | Table t keys acts =>
    Some (set_tables ds (Env.bind t {| table_key:=keys; table_acts := acts |} ds.(tables)), s)
  end.

Fixpoint interp_defns (fuel: nat) (ds: def_state) (s: state) (defs: list defn) : option (def_state * state) :=
  match defs with
  | [] => Some (ds, s)
  | d :: defs =>
    match interp_defn fuel ds s d with
    | Some (ds, s) => interp_defns fuel ds s defs
    | None => None
    end
  end.

Definition interp_prog (fuel: nat) (ds: def_state) (s: state) (p: prog) : option state :=
  let '(defs, c) := p in
  match interp_defns fuel ds s defs with
  | Some (ds, s) =>
    interp_cmd fuel ds s c
  | None =>
    None
  end.


Require Export Iron.Language.SimpleData.ExpBase.

(* Get the data constructor of an alternative. *)
Fixpoint dcOfAlt (aa: alt) : datacon :=
 match aa with
 | AAlt dc _ _ => dc
 end.
Hint Unfold dcOfAlt.

(* Get the alternative body that matches a given constructor. *)
Fixpoint getAlt (dc: datacon) (alts: list alt) {struct alts}
                : option alt :=
 match alts with
 |  nil  => None

 |  AAlt dc' tsArgs x :: alts'
 => if datacon_beq dc dc'
     then Some (AAlt dc' tsArgs x)
     else getAlt dc alts'
 end.

(* If we get a single alternative from a list,
   then that alternative was in the list. *)
Lemma getAlt_in
 :  forall dc alt alts
 ,  getAlt dc alts = Some alt
 -> In alt alts.
Proof.
 intros.
 induction alts.
  false.
  destruct a as [dc' tsArgs x].
  simpl in H.
  breaka (datacon_beq dc dc').
   inverts H.
   apply datacon_beq_eq in HeqX; auto.
Qed.

(* Given a data constructor, if one of the alternatives in a
   list matches that data constructor then we can get the other
   information about the alternative from the list. *)
Lemma getAlt_exists
 :  forall d alts
 ,  In d (map dcOfAlt alts)
 -> (exists tsArgs x, getAlt d alts = Some (AAlt d tsArgs x)).
Proof.
 intros.
 induction alts.
  simpl in H. false.
  simpl in H. inverts H.
   destruct a. simpl.
   breaka (datacon_beq d d).
    exists l. exists e. auto.
    apply datacon_beq_false in HeqX. false.
   lets D: IHalts H0.
   destruct a. simpl.
    breaka (datacon_beq d d0).
     apply datacon_beq_eq in HeqX. subst. auto.
     exists l. exists e. auto.
Qed.