(**
 Verified SAR-BP: A verified C implementation of SAR backprojection
 with a certified absolute error bound.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 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 3 of the License (GNU GPL
 v3), or (at your option) any later version.  A verbatim copy of the
 GNU GPL v3 is included in gpl-3.0.txt.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole Verified SAR-BP library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying Verified SAR-BP in your work, please
 consider citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 Verified SAR-BP derives from prior work listed in ACKS along with
 their copyright and licensing information.

 Verified SAR-BP requires third-party libraries listed in ACKS along
 with their copyright information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

Bounds for medium images. Those bounds have been extracted from the
DARPA PERFECT suite ( http://hpc.pnl.gov/PERFECT/ )
*)

Require Import ZArith RAux.
Require Flocq.Core.Fcore_Raux.
Definition abs_data_border: R := (715249/268435456)%R .
Definition abs_data_min: R := (12006781/36028797018963968)%R .
Definition abs_data_max: R := (4211015/4194304)%R .
Definition abs_data_dist: R := (5771023/33554432)%R .

Definition platpos_x_min: R := (14455539/2048)%R .
Definition platpos_x_max: R := (14481547/2048)%R.

Definition platpos_y_min: R := (0)%R .
Definition platpos_y_max: R := (6940197/16384)%R.

Definition platpos_z_min: R := (14481547/2048)%R .
Definition platpos_z_max: R := (14481547/2048)%R.

Definition dxdy := Eval compute in (4503599627370496 * / Fcore_Raux.Z2R (2 ^ 54))%R.
Definition dR := Eval compute in (4503599627370496 * / Fcore_Raux.Z2R (2 ^ 57))%R.
Definition N_PULSES := (1024)%nat .
Definition N_RANGE := (1024)%Z .
Definition N_RANGE_UPSAMPLED := (8192)%Z .
Definition BP_NPIX_Y := (1024)%nat .
Definition BP_NPIX_X := (1024)%nat .
Definition ku := Eval compute in (7368997658362958 * / Fcore_Raux.Z2R (2 ^ 45))%R.
(*
Definition z0 := Eval compute in (0 * / Fcore_Raux.Z2R (2 ^ 1074))%R.
*)
Definition z0_low := 0%R.
Definition z0_high := 0%R.
Definition R0 := Eval compute in (5427189394702336 * / Fcore_Raux.Z2R (2 ^ 39))%R.


From Coq Require Import RelationClasses.
From Mon Require Import SPropBase.
Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect.
Set Warnings "notation-overridden,ambiguous-paths".
From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Crypt Require Import ChoiceAsOrd OrderEnrichedRelativeAdjunctions OrderEnrichedRelativeAdjunctionsExamples TransformingLaxMorph SubDistr Theta_dens LaxFunctorsAndTransf UniversalFreeMap FreeProbProg StateTransformingLaxMorph LaxComp.

Import SPropNotations.

(*
In this file we state transform this morphism
θdens : Frp → Sdistr
into
StT(θdens) : StT(Frp) → StT(SDistr)

We also subsequently make its domain free
θFstd : FrStP → StT(Frp) → stT(SDistr)
*)

Section GetDomainAndCodomain.
  Context {C D1 D2 : ord_category} {J1 : ord_functor C D1} {J12 : ord_functor D1 D2} {J2 : ord_functor C D2}
          {phi : natIso J2 (ord_functor_comp J1 J12)} (psi := ni_inv phi)
          {M1 : ord_relativeMonad J1} {M2: ord_relativeMonad J2}.

  Definition rlmm_domain (smTheta :  relativeLaxMonadMorphism J12 phi M1 M2)
    : ord_relativeMonad J1
    := M1.
  Definition rlmm_codomain (smTheta :  relativeLaxMonadMorphism J12 phi M1 M2)
    : ord_relativeMonad J2
    := M2.

End GetDomainAndCodomain.

Section StT_unaryThetaDens.
  Context {probE : Type -> Type}. (*an interface for probabilistic events*)
  Context {choice_type : Type}
          {chElement : choice_type -> choiceType}.
  Context (prob_handler : forall (T:choiceType),
    probE T -> SDistr T).

  Context {S : choiceType}.

  (*we wish to transform this monad morphism*)
  Let θdens_filled :=
  @unary_theta_dens.

  (*domain and codomain*)
  Let Frp := rlmm_domain θdens_filled.
  (* Eval hnf in rlmm_codomain θdens_filled. (*SDistr*) *)

  (*state transform the domain*)

  Program Definition unaryStateTingAdj :
  leftAdjunctionSituation choice_incl
         (ord_functor_comp (unaryTimesS1 S) choice_incl)
         (ToTheS S) :=
    mkNatIso _ _ _ _ _ _ _.
  Next Obligation.
    move=> [A X]. unshelve econstructor.
      simpl. move=> g a s. exact (g (a,s)).
      move=> g g'. simpl in g. simpl in g'.
      move=> Hg. unfold extract_ord. simpl.
      move=> a.
      unfold extract_ord in Hg. simpl in Hg.
      apply boolp.funext. move=> s.
      apply Hg.
  Defined.
  Next Obligation.
    move=> [A X]. unshelve econstructor.
      simpl. move=> g. move=> [a s]. exact (g a s).
      simpl. move => g g'.
      unfold extract_ord. simpl.
      move=> Hg. move=> [a s].
      specialize (Hg a). destruct Hg.
      reflexivity.
  Defined.
  Next Obligation.
    move=> [A X] [A' X']. move=> [fA fX]. simpl in *.
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    apply boolp.funext. move=> a'. apply boolp.funext. move=> s.
    simpl.
    rewrite /OrderEnrichedRelativeAdjunctionsExamples.ToTheS_obligation_1.
    reflexivity.
  Qed.
  Next Obligation.
    move=> [A X].
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    simpl. apply boolp.funext. move=> a. reflexivity.
  Qed.
  Next Obligation.
    move=> [A X].
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    simpl. apply boolp.funext. move=> [a s]. reflexivity.
  Qed.

  Program Definition unaryStateBeta' :
  lnatTrans (lord_functor_comp
                      (strict2laxFunc (ToTheS S))
                      (strict2laxFunc (ord_functor_id TypeCat)))
            (lord_functor_comp
                      (strict2laxFunc (ord_functor_id TypeCat))
                      (strict2laxFunc (ToTheS S))) :=
    mkLnatTrans _ _.

  Program Definition stT_thetaDens_adj :=
  Transformed_lmla θdens_filled unaryStateTingAdj unaryStateTingAdj unaryStateBeta' _ _.
  Next Obligation.
    move=> A Y. move=> g.
    apply boolp.funext. move=> [ a s]. cbv. reflexivity.
  Qed.

  Definition stT_thetaDens :=  rlmm_from_lmla stT_thetaDens_adj.

End StT_unaryThetaDens.

Section MakeTheDomainFree.
  Context {probE : Type -> Type}. (*an interface for probabilistic events*)
  Context {choice_type : Type}
          {chElement : choice_type -> choiceType}.
  Context {prob_handler : forall (T:choiceType),
    probE T -> SDistr T}.

  Context {S : choiceType}.

  Let unaryIntState_filled :=
  @unaryIntState S.

  Let stT_thetaDens_filled :=
  @stT_thetaDens S.

  (*an auxiliary morphism to connect the dots*)
  Program Definition bridgg :
  relativeMonadMorphism (ord_functor_id _) (trivialChi)
     (rlmm_codomain unaryIntState_filled)
     (rlmm_domain stT_thetaDens_filled) :=
    mkRelMonMorph _ _ _ _ _ _ _.

  (*now... unaryIntState_filled ; bridgg = ppre*)
  Let ppre := rlmm_comp _ _ _ _ _ _ _ (unaryIntState_filled) bridgg.

  (*and then ppre ; stT_thetaDens_filled*)
  Definition thetaFstd := rlmm_comp _ _ _ _ _ _ _ ppre stT_thetaDens_filled.

End MakeTheDomainFree.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                 Xavier Leroy, INRIA Paris                           *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Instruction selection for 64-bit integer operations *)

Require Import Coqlib.
Require Import Compopts.
Require Import AST Integers Floats.
Require Import Op CminorSel.
Require Import SelectOp SplitLong.

Local Open Scope cminorsel_scope.
Local Open Scope string_scope.

Section SELECT.

Context {hf: helper_functions}.

Definition longconst (n: int64) : expr :=
  if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil.

Definition is_longconst (e: expr) :=
  if Archi.splitlong then SplitLong.is_longconst e else
  match e with
  | Eop (Olongconst n) Enil => Some n
  | _ => None
  end.

Definition intoflong (e: expr) :=
  if Archi.splitlong then SplitLong.intoflong e else
  match is_longconst e with
  | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil
  | None =>  Eop Olowlong (e ::: Enil)
  end.

Definition longofint (e: expr) :=
  if Archi.splitlong then SplitLong.longofint e else
  match is_intconst e with
  | Some n => longconst (Int64.repr (Int.signed n))
  | None =>  Eop Ocast32signed (e ::: Enil)
  end.

Definition longofintu (e: expr) :=
  if Archi.splitlong then SplitLong.longofintu e else
  match is_intconst e with
  | Some n => longconst (Int64.repr (Int.unsigned n))
  | None =>  Eop Ocast32unsigned (e ::: Enil)
  end.

(** Original definition:
<<
Nondetfunction notl (e: expr) :=
  if Archi.splitlong then SplitLong.notl e else
  match e with
  | Eop (Olongconst n) Enil => longconst (Int64.not n)
  | Eop Onotl (t1:::Enil) => t1
  | _ => Eop Onotl (e:::Enil)
  end.
>>
*)

Inductive notl_cases: forall (e: expr), Type :=
  | notl_case1: forall n, notl_cases (Eop (Olongconst n) Enil)
  | notl_case2: forall t1, notl_cases (Eop Onotl (t1:::Enil))
  | notl_default: forall (e: expr), notl_cases e.

Definition notl_match (e: expr) :=
  match e as zz1 return notl_cases zz1 with
  | Eop (Olongconst n) Enil => notl_case1 n
  | Eop Onotl (t1:::Enil) => notl_case2 t1
  | e => notl_default e
  end.

Definition notl (e: expr) :=
 if Archi.splitlong then SplitLong.notl e else match notl_match e with
  | notl_case1 n => (* Eop (Olongconst n) Enil *)
      longconst (Int64.not n)
  | notl_case2 t1 => (* Eop Onotl (t1:::Enil) *)
      t1
  | notl_default e =>
      Eop Onotl (e:::Enil)
  end.

(** Original definition:
<<
Nondetfunction andlimm (n1: int64) (e2: expr) :=
  if Int64.eq n1 Int64.zero then longconst Int64.zero else
  if Int64.eq n1 Int64.mone then e2 else
  match e2 with
  | Eop (Olongconst n2) Enil =>
      longconst (Int64.and n1 n2)
  | Eop (Oandlimm n2) (t2:::Enil) =>
      Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil)
  | _ =>
      Eop (Oandlimm n1) (e2:::Enil)
  end.
>>
*)

Inductive andlimm_cases: forall (e2: expr), Type :=
  | andlimm_case1: forall n2, andlimm_cases (Eop (Olongconst n2) Enil)
  | andlimm_case2: forall n2 t2, andlimm_cases (Eop (Oandlimm n2) (t2:::Enil))
  | andlimm_default: forall (e2: expr), andlimm_cases e2.

Definition andlimm_match (e2: expr) :=
  match e2 as zz1 return andlimm_cases zz1 with
  | Eop (Olongconst n2) Enil => andlimm_case1 n2
  | Eop (Oandlimm n2) (t2:::Enil) => andlimm_case2 n2 t2
  | e2 => andlimm_default e2
  end.

Definition andlimm (n1: int64) (e2: expr) :=
 if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.mone then e2 else match andlimm_match e2 with
  | andlimm_case1 n2 => (* Eop (Olongconst n2) Enil *)
      longconst (Int64.and n1 n2)
  | andlimm_case2 n2 t2 => (* Eop (Oandlimm n2) (t2:::Enil) *)
      Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil)
  | andlimm_default e2 =>
      Eop (Oandlimm n1) (e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction andl (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.andl e1 e2 else
  match e1, e2 with
  | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2
  | t1, Eop (Olongconst n2) Enil => andlimm n2 t1
  | _, _ => Eop Oandl (e1:::e2:::Enil)
  end.
>>
*)

Inductive andl_cases: forall (e1: expr) (e2: expr), Type :=
  | andl_case1: forall n1 t2, andl_cases (Eop (Olongconst n1) Enil) (t2)
  | andl_case2: forall t1 n2, andl_cases (t1) (Eop (Olongconst n2) Enil)
  | andl_default: forall (e1: expr) (e2: expr), andl_cases e1 e2.

Definition andl_match (e1: expr) (e2: expr) :=
  match e1 as zz1, e2 as zz2 return andl_cases zz1 zz2 with
  | Eop (Olongconst n1) Enil, t2 => andl_case1 n1 t2
  | t1, Eop (Olongconst n2) Enil => andl_case2 t1 n2
  | e1, e2 => andl_default e1 e2
  end.

Definition andl (e1: expr) (e2: expr) :=
 if Archi.splitlong then SplitLong.andl e1 e2 else match andl_match e1 e2 with
  | andl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *)
      andlimm n1 t2
  | andl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *)
      andlimm n2 t1
  | andl_default e1 e2 =>
      Eop Oandl (e1:::e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction orlimm (n1: int64) (e2: expr) :=
  if Int64.eq n1 Int64.zero then e2 else
  if Int64.eq n1 Int64.mone then longconst Int64.mone else
  match e2 with
  | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2)
  | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil)
  | _ => Eop (Oorlimm n1) (e2:::Enil)
  end.
>>
*)

Inductive orlimm_cases: forall (e2: expr), Type :=
  | orlimm_case1: forall n2, orlimm_cases (Eop (Olongconst n2) Enil)
  | orlimm_case2: forall n2 t2, orlimm_cases (Eop (Oorlimm n2) (t2:::Enil))
  | orlimm_default: forall (e2: expr), orlimm_cases e2.

Definition orlimm_match (e2: expr) :=
  match e2 as zz1 return orlimm_cases zz1 with
  | Eop (Olongconst n2) Enil => orlimm_case1 n2
  | Eop (Oorlimm n2) (t2:::Enil) => orlimm_case2 n2 t2
  | e2 => orlimm_default e2
  end.

Definition orlimm (n1: int64) (e2: expr) :=
 if Int64.eq n1 Int64.zero then e2 else if Int64.eq n1 Int64.mone then longconst Int64.mone else match orlimm_match e2 with
  | orlimm_case1 n2 => (* Eop (Olongconst n2) Enil *)
      longconst (Int64.or n1 n2)
  | orlimm_case2 n2 t2 => (* Eop (Oorlimm n2) (t2:::Enil) *)
      Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil)
  | orlimm_default e2 =>
      Eop (Oorlimm n1) (e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction orl (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.orl e1 e2 else
  match e1, e2 with
  | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2
  | t1, Eop (Olongconst n2) Enil => orlimm n2 t1
  | Eop (Oshllimm n1) (t1:::Enil), Eop (Oshrluimm n2) (t2:::Enil) =>
      if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2
      then Eop (Ororlimm n2) (t1:::Enil)
      else Eop Oorl (e1:::e2:::Enil)
  | Eop (Oshrluimm n2) (t2:::Enil), Eop (Oshllimm n1) (t1:::Enil) =>
      if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2
      then Eop (Ororlimm n2) (t1:::Enil)
      else Eop Oorl (e1:::e2:::Enil)
  | _, _ =>
      Eop Oorl (e1:::e2:::Enil)
  end.
>>
*)

Inductive orl_cases: forall (e1: expr) (e2: expr), Type :=
  | orl_case1: forall n1 t2, orl_cases (Eop (Olongconst n1) Enil) (t2)
  | orl_case2: forall t1 n2, orl_cases (t1) (Eop (Olongconst n2) Enil)
  | orl_case3: forall n1 t1 n2 t2, orl_cases (Eop (Oshllimm n1) (t1:::Enil)) (Eop (Oshrluimm n2) (t2:::Enil))
  | orl_case4: forall n2 t2 n1 t1, orl_cases (Eop (Oshrluimm n2) (t2:::Enil)) (Eop (Oshllimm n1) (t1:::Enil))
  | orl_default: forall (e1: expr) (e2: expr), orl_cases e1 e2.

Definition orl_match (e1: expr) (e2: expr) :=
  match e1 as zz1, e2 as zz2 return orl_cases zz1 zz2 with
  | Eop (Olongconst n1) Enil, t2 => orl_case1 n1 t2
  | t1, Eop (Olongconst n2) Enil => orl_case2 t1 n2
  | Eop (Oshllimm n1) (t1:::Enil), Eop (Oshrluimm n2) (t2:::Enil) => orl_case3 n1 t1 n2 t2
  | Eop (Oshrluimm n2) (t2:::Enil), Eop (Oshllimm n1) (t1:::Enil) => orl_case4 n2 t2 n1 t1
  | e1, e2 => orl_default e1 e2
  end.

Definition orl (e1: expr) (e2: expr) :=
 if Archi.splitlong then SplitLong.orl e1 e2 else match orl_match e1 e2 with
  | orl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *)
      orlimm n1 t2
  | orl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *)
      orlimm n2 t1
  | orl_case3 n1 t1 n2 t2 => (* Eop (Oshllimm n1) (t1:::Enil), Eop (Oshrluimm n2) (t2:::Enil) *)
      if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2 then Eop (Ororlimm n2) (t1:::Enil) else Eop Oorl (e1:::e2:::Enil)
  | orl_case4 n2 t2 n1 t1 => (* Eop (Oshrluimm n2) (t2:::Enil), Eop (Oshllimm n1) (t1:::Enil) *)
      if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2 then Eop (Ororlimm n2) (t1:::Enil) else Eop Oorl (e1:::e2:::Enil)
  | orl_default e1 e2 =>
      Eop Oorl (e1:::e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction xorlimm (n1: int64) (e2: expr) :=
  if Int64.eq n1 Int64.zero then e2 else
  if Int64.eq n1 Int64.mone then notl e2 else
  match e2 with
  | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2)
  | Eop (Oxorlimm n2) (t2:::Enil) => Eop (Oxorlimm (Int64.xor n1 n2)) (t2:::Enil)
  | Eop Onotl (t2:::Enil) => Eop (Oxorlimm (Int64.not n1)) (t2:::Enil)
  | _ => Eop (Oxorlimm n1) (e2:::Enil)
  end.
>>
*)

Inductive xorlimm_cases: forall (e2: expr), Type :=
  | xorlimm_case1: forall n2, xorlimm_cases (Eop (Olongconst n2) Enil)
  | xorlimm_case2: forall n2 t2, xorlimm_cases (Eop (Oxorlimm n2) (t2:::Enil))
  | xorlimm_case3: forall t2, xorlimm_cases (Eop Onotl (t2:::Enil))
  | xorlimm_default: forall (e2: expr), xorlimm_cases e2.

Definition xorlimm_match (e2: expr) :=
  match e2 as zz1 return xorlimm_cases zz1 with
  | Eop (Olongconst n2) Enil => xorlimm_case1 n2
  | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_case2 n2 t2
  | Eop Onotl (t2:::Enil) => xorlimm_case3 t2
  | e2 => xorlimm_default e2
  end.

Definition xorlimm (n1: int64) (e2: expr) :=
 if Int64.eq n1 Int64.zero then e2 else if Int64.eq n1 Int64.mone then notl e2 else match xorlimm_match e2 with
  | xorlimm_case1 n2 => (* Eop (Olongconst n2) Enil *)
      longconst (Int64.xor n1 n2)
  | xorlimm_case2 n2 t2 => (* Eop (Oxorlimm n2) (t2:::Enil) *)
      Eop (Oxorlimm (Int64.xor n1 n2)) (t2:::Enil)
  | xorlimm_case3 t2 => (* Eop Onotl (t2:::Enil) *)
      Eop (Oxorlimm (Int64.not n1)) (t2:::Enil)
  | xorlimm_default e2 =>
      Eop (Oxorlimm n1) (e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction xorl (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.xorl e1 e2 else
  match e1, e2 with
  | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2
  | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1
  | _, _ => Eop Oxorl (e1:::e2:::Enil)
  end.
>>
*)

Inductive xorl_cases: forall (e1: expr) (e2: expr), Type :=
  | xorl_case1: forall n1 t2, xorl_cases (Eop (Olongconst n1) Enil) (t2)
  | xorl_case2: forall t1 n2, xorl_cases (t1) (Eop (Olongconst n2) Enil)
  | xorl_default: forall (e1: expr) (e2: expr), xorl_cases e1 e2.

Definition xorl_match (e1: expr) (e2: expr) :=
  match e1 as zz1, e2 as zz2 return xorl_cases zz1 zz2 with
  | Eop (Olongconst n1) Enil, t2 => xorl_case1 n1 t2
  | t1, Eop (Olongconst n2) Enil => xorl_case2 t1 n2
  | e1, e2 => xorl_default e1 e2
  end.

Definition xorl (e1: expr) (e2: expr) :=
 if Archi.splitlong then SplitLong.xorl e1 e2 else match xorl_match e1 e2 with
  | xorl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *)
      xorlimm n1 t2
  | xorl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *)
      xorlimm n2 t1
  | xorl_default e1 e2 =>
      Eop Oxorl (e1:::e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction shllimm (e1: expr) (n: int) :=
  if Archi.splitlong then SplitLong.shllimm e1 n else
  if Int.eq n Int.zero then e1 else
  if negb (Int.ltu n Int64.iwordsize') then
    Eop Oshll (e1:::Eop (Ointconst n) Enil:::Enil)
  else
    match e1 with
    | Eop (Olongconst n1) Enil =>
        Eop (Olongconst(Int64.shl' n1 n)) Enil
    | Eop (Oshllimm n1) (t1:::Enil) =>
        if Int.ltu (Int.add n n1) Int64.iwordsize'
        then Eop (Oshllimm (Int.add n n1)) (t1:::Enil)
        else Eop (Oshllimm n) (e1:::Enil)
    | Eop (Oleal (Aindexed n1)) (t1:::Enil) =>
        if shift_is_scale n
        then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n))
                                 (Int64.unsigned (Int64.shl' (Int64.repr n1) n)))) (t1:::Enil)
        else Eop (Oshllimm n) (e1:::Enil)
    | _ =>
        if shift_is_scale n
        then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n)) 0)) (e1:::Enil)
        else Eop (Oshllimm n) (e1:::Enil)
    end.
>>
*)

Inductive shllimm_cases: forall (e1: expr) , Type :=
  | shllimm_case1: forall n1, shllimm_cases (Eop (Olongconst n1) Enil)
  | shllimm_case2: forall n1 t1, shllimm_cases (Eop (Oshllimm n1) (t1:::Enil))
  | shllimm_case3: forall n1 t1, shllimm_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil))
  | shllimm_default: forall (e1: expr) , shllimm_cases e1.

Definition shllimm_match (e1: expr)  :=
  match e1 as zz1 return shllimm_cases zz1 with
  | Eop (Olongconst n1) Enil => shllimm_case1 n1
  | Eop (Oshllimm n1) (t1:::Enil) => shllimm_case2 n1 t1
  | Eop (Oleal (Aindexed n1)) (t1:::Enil) => shllimm_case3 n1 t1
  | e1 => shllimm_default e1
  end.

Definition shllimm (e1: expr) (n: int) :=
 if Archi.splitlong then SplitLong.shllimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshll (e1:::Eop (Ointconst n) Enil:::Enil) else match shllimm_match e1 with
  | shllimm_case1 n1 => (* Eop (Olongconst n1) Enil *)
      Eop (Olongconst(Int64.shl' n1 n)) Enil
  | shllimm_case2 n1 t1 => (* Eop (Oshllimm n1) (t1:::Enil) *)
      if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) else Eop (Oshllimm n) (e1:::Enil)
  | shllimm_case3 n1 t1 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil) *)
      if shift_is_scale n then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n)) (Int64.unsigned (Int64.shl' (Int64.repr n1) n)))) (t1:::Enil) else Eop (Oshllimm n) (e1:::Enil)
  | shllimm_default e1 =>
      if shift_is_scale n then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n)) 0)) (e1:::Enil) else Eop (Oshllimm n) (e1:::Enil)
  end.

(** Original definition:
<<
Nondetfunction shrluimm (e1: expr) (n: int) :=
  if Archi.splitlong then SplitLong.shrluimm e1 n else
  if Int.eq n Int.zero then e1 else
  if negb (Int.ltu n Int64.iwordsize') then
    Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil)
  else
    match e1 with
    | Eop (Olongconst n1) Enil =>
        Eop (Olongconst(Int64.shru' n1 n)) Enil
    | Eop (Oshrluimm n1) (t1:::Enil) =>
        if Int.ltu (Int.add n n1) Int64.iwordsize'
        then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil)
        else Eop (Oshrluimm n) (e1:::Enil)
    | _ =>
        Eop (Oshrluimm n) (e1:::Enil)
    end.
>>
*)

Inductive shrluimm_cases: forall (e1: expr) , Type :=
  | shrluimm_case1: forall n1, shrluimm_cases (Eop (Olongconst n1) Enil)
  | shrluimm_case2: forall n1 t1, shrluimm_cases (Eop (Oshrluimm n1) (t1:::Enil))
  | shrluimm_default: forall (e1: expr) , shrluimm_cases e1.

Definition shrluimm_match (e1: expr)  :=
  match e1 as zz1 return shrluimm_cases zz1 with
  | Eop (Olongconst n1) Enil => shrluimm_case1 n1
  | Eop (Oshrluimm n1) (t1:::Enil) => shrluimm_case2 n1 t1
  | e1 => shrluimm_default e1
  end.

Definition shrluimm (e1: expr) (n: int) :=
 if Archi.splitlong then SplitLong.shrluimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) else match shrluimm_match e1 with
  | shrluimm_case1 n1 => (* Eop (Olongconst n1) Enil *)
      Eop (Olongconst(Int64.shru' n1 n)) Enil
  | shrluimm_case2 n1 t1 => (* Eop (Oshrluimm n1) (t1:::Enil) *)
      if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrluimm n) (e1:::Enil)
  | shrluimm_default e1 =>
      Eop (Oshrluimm n) (e1:::Enil)
  end.

(** Original definition:
<<
Nondetfunction shrlimm (e1: expr) (n: int) :=
  if Archi.splitlong then SplitLong.shrlimm e1 n else
  if Int.eq n Int.zero then e1 else
  if negb (Int.ltu n Int64.iwordsize') then
    Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil)
  else
  match e1 with
  | Eop (Olongconst n1) Enil =>
      Eop (Olongconst(Int64.shr' n1 n)) Enil
  | Eop (Oshrlimm n1) (t1:::Enil) =>
      if Int.ltu (Int.add n n1) Int64.iwordsize'
      then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil)
      else Eop (Oshrlimm n) (e1:::Enil)
  | _ =>
      Eop (Oshrlimm n) (e1:::Enil)
  end.
>>
*)

Inductive shrlimm_cases: forall (e1: expr) , Type :=
  | shrlimm_case1: forall n1, shrlimm_cases (Eop (Olongconst n1) Enil)
  | shrlimm_case2: forall n1 t1, shrlimm_cases (Eop (Oshrlimm n1) (t1:::Enil))
  | shrlimm_default: forall (e1: expr) , shrlimm_cases e1.

Definition shrlimm_match (e1: expr)  :=
  match e1 as zz1 return shrlimm_cases zz1 with
  | Eop (Olongconst n1) Enil => shrlimm_case1 n1
  | Eop (Oshrlimm n1) (t1:::Enil) => shrlimm_case2 n1 t1
  | e1 => shrlimm_default e1
  end.

Definition shrlimm (e1: expr) (n: int) :=
 if Archi.splitlong then SplitLong.shrlimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) else match shrlimm_match e1 with
  | shrlimm_case1 n1 => (* Eop (Olongconst n1) Enil *)
      Eop (Olongconst(Int64.shr' n1 n)) Enil
  | shrlimm_case2 n1 t1 => (* Eop (Oshrlimm n1) (t1:::Enil) *)
      if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrlimm n) (e1:::Enil)
  | shrlimm_default e1 =>
      Eop (Oshrlimm n) (e1:::Enil)
  end.

Definition shll (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.shll e1 e2 else
  match is_intconst e2 with
  | Some n2 => shllimm e1 n2
  | None => Eop Oshll (e1:::e2:::Enil)
  end.

Definition shrl (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.shrl e1 e2 else
  match is_intconst e2 with
  | Some n2 => shrlimm e1 n2
  | None => Eop Oshrl (e1:::e2:::Enil)
  end.

Definition shrlu (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.shrlu e1 e2 else
  match is_intconst e2 with
  | Some n2 => shrluimm e1 n2
  | _ => Eop Oshrlu (e1:::e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction addlimm (n: int64) (e: expr) :=
  if Int64.eq n Int64.zero then e else
  match e with
  | Eop (Olongconst m) Enil => longconst (Int64.add n m)
  | Eop (Oleal addr) args   => Eop (Oleal (offset_addressing_total addr (Int64.signed n))) args
  | _                       => Eop (Oleal (Aindexed (Int64.signed n))) (e ::: Enil)
  end.
>>
*)

Inductive addlimm_cases: forall (e: expr), Type :=
  | addlimm_case1: forall m, addlimm_cases (Eop (Olongconst m) Enil)
  | addlimm_case2: forall addr args, addlimm_cases (Eop (Oleal addr) args)
  | addlimm_default: forall (e: expr), addlimm_cases e.

Definition addlimm_match (e: expr) :=
  match e as zz1 return addlimm_cases zz1 with
  | Eop (Olongconst m) Enil => addlimm_case1 m
  | Eop (Oleal addr) args => addlimm_case2 addr args
  | e => addlimm_default e
  end.

Definition addlimm (n: int64) (e: expr) :=
 if Int64.eq n Int64.zero then e else match addlimm_match e with
  | addlimm_case1 m => (* Eop (Olongconst m) Enil *)
      longconst (Int64.add n m)
  | addlimm_case2 addr args => (* Eop (Oleal addr) args *)
      Eop (Oleal (offset_addressing_total addr (Int64.signed n))) args
  | addlimm_default e =>
      Eop (Oleal (Aindexed (Int64.signed n))) (e ::: Enil)
  end.

(** Original definition:
<<
Nondetfunction addl (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.addl e1 e2 else
  match e1, e2 with
  | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2
  | t1, Eop (Olongconst n2) Enil => addlimm n2 t1
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
      Eop (Oleal (Aindexed2 (n1 + n2))) (t1:::t2:::Enil)
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) =>
      Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil)
  | Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
      Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil)
  | Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 =>
      Eop (Oleal (Aindexed2scaled sc n)) (t2:::t1:::Enil)
  | t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) =>
      Eop (Oleal (Aindexed2scaled sc n)) (t1:::t2:::Enil)
  | Eop (Oleal (Aindexed n)) (t1:::Enil), t2 =>
      Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil)
  | t1, Eop (Oleal (Aindexed n)) (t2:::Enil) =>
      Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil)
  | _, _ =>
      Eop (Oleal (Aindexed2 0)) (e1:::e2:::Enil)
  end.
>>
*)

Inductive addl_cases: forall (e1: expr) (e2: expr), Type :=
  | addl_case1: forall n1 t2, addl_cases (Eop (Olongconst n1) Enil) (t2)
  | addl_case2: forall t1 n2, addl_cases (t1) (Eop (Olongconst n2) Enil)
  | addl_case3: forall n1 t1 n2 t2, addl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (Eop (Oleal (Aindexed n2)) (t2:::Enil))
  | addl_case4: forall n1 t1 sc n2 t2, addl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (Eop (Oleal (Ascaled sc n2)) (t2:::Enil))
  | addl_case5: forall sc n1 t1 n2 t2, addl_cases (Eop (Oleal (Ascaled sc n1)) (t1:::Enil)) (Eop (Oleal (Aindexed n2)) (t2:::Enil))
  | addl_case6: forall sc n t1 t2, addl_cases (Eop (Oleal (Ascaled sc n)) (t1:::Enil)) (t2)
  | addl_case7: forall t1 sc n t2, addl_cases (t1) (Eop (Oleal (Ascaled sc n)) (t2:::Enil))
  | addl_case8: forall n t1 t2, addl_cases (Eop (Oleal (Aindexed n)) (t1:::Enil)) (t2)
  | addl_case9: forall t1 n t2, addl_cases (t1) (Eop (Oleal (Aindexed n)) (t2:::Enil))
  | addl_default: forall (e1: expr) (e2: expr), addl_cases e1 e2.

Definition addl_match (e1: expr) (e2: expr) :=
  match e1 as zz1, e2 as zz2 return addl_cases zz1 zz2 with
  | Eop (Olongconst n1) Enil, t2 => addl_case1 n1 t2
  | t1, Eop (Olongconst n2) Enil => addl_case2 t1 n2
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => addl_case3 n1 t1 n2 t2
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) => addl_case4 n1 t1 sc n2 t2
  | Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => addl_case5 sc n1 t1 n2 t2
  | Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 => addl_case6 sc n t1 t2
  | t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) => addl_case7 t1 sc n t2
  | Eop (Oleal (Aindexed n)) (t1:::Enil), t2 => addl_case8 n t1 t2
  | t1, Eop (Oleal (Aindexed n)) (t2:::Enil) => addl_case9 t1 n t2
  | e1, e2 => addl_default e1 e2
  end.

Definition addl (e1: expr) (e2: expr) :=
 if Archi.splitlong then SplitLong.addl e1 e2 else match addl_match e1 e2 with
  | addl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *)
      addlimm n1 t2
  | addl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *)
      addlimm n2 t1
  | addl_case3 n1 t1 n2 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) *)
      Eop (Oleal (Aindexed2 (n1 + n2))) (t1:::t2:::Enil)
  | addl_case4 n1 t1 sc n2 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) *)
      Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil)
  | addl_case5 sc n1 t1 n2 t2 => (* Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) *)
      Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil)
  | addl_case6 sc n t1 t2 => (* Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 *)
      Eop (Oleal (Aindexed2scaled sc n)) (t2:::t1:::Enil)
  | addl_case7 t1 sc n t2 => (* t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) *)
      Eop (Oleal (Aindexed2scaled sc n)) (t1:::t2:::Enil)
  | addl_case8 n t1 t2 => (* Eop (Oleal (Aindexed n)) (t1:::Enil), t2 *)
      Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil)
  | addl_case9 t1 n t2 => (* t1, Eop (Oleal (Aindexed n)) (t2:::Enil) *)
      Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil)
  | addl_default e1 e2 =>
      Eop (Oleal (Aindexed2 0)) (e1:::e2:::Enil)
  end.

Definition negl (e: expr) :=
  if Archi.splitlong then SplitLong.negl e else
  match is_longconst e with
  | Some n => longconst (Int64.neg n)
  | None =>  Eop Onegl (e ::: Enil)
  end.

(** Original definition:
<<
Nondetfunction subl (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.subl e1 e2 else
  match e1, e2 with
  | t1, Eop (Olongconst n2) Enil => addlimm (Int64.neg n2) t1
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
      addlimm (Int64.repr (n1 - n2)) (Eop Osubl (t1:::t2:::Enil))
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 =>
      addlimm (Int64.repr n1) (Eop Osubl (t1:::t2:::Enil))
  | t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
      addlimm (Int64.repr (- n2)) (Eop Osubl (t1:::t2:::Enil))
  | _, _ =>
      Eop Osubl (e1:::e2:::Enil)
  end.
>>
*)

Inductive subl_cases: forall (e1: expr) (e2: expr), Type :=
  | subl_case1: forall t1 n2, subl_cases (t1) (Eop (Olongconst n2) Enil)
  | subl_case2: forall n1 t1 n2 t2, subl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (Eop (Oleal (Aindexed n2)) (t2:::Enil))
  | subl_case3: forall n1 t1 t2, subl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (t2)
  | subl_case4: forall t1 n2 t2, subl_cases (t1) (Eop (Oleal (Aindexed n2)) (t2:::Enil))
  | subl_default: forall (e1: expr) (e2: expr), subl_cases e1 e2.

Definition subl_match (e1: expr) (e2: expr) :=
  match e1 as zz1, e2 as zz2 return subl_cases zz1 zz2 with
  | t1, Eop (Olongconst n2) Enil => subl_case1 t1 n2
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => subl_case2 n1 t1 n2 t2
  | Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 => subl_case3 n1 t1 t2
  | t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) => subl_case4 t1 n2 t2
  | e1, e2 => subl_default e1 e2
  end.

Definition subl (e1: expr) (e2: expr) :=
 if Archi.splitlong then SplitLong.subl e1 e2 else match subl_match e1 e2 with
  | subl_case1 t1 n2 => (* t1, Eop (Olongconst n2) Enil *)
      addlimm (Int64.neg n2) t1
  | subl_case2 n1 t1 n2 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) *)
      addlimm (Int64.repr (n1 - n2)) (Eop Osubl (t1:::t2:::Enil))
  | subl_case3 n1 t1 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 *)
      addlimm (Int64.repr n1) (Eop Osubl (t1:::t2:::Enil))
  | subl_case4 t1 n2 t2 => (* t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) *)
      addlimm (Int64.repr (- n2)) (Eop Osubl (t1:::t2:::Enil))
  | subl_default e1 e2 =>
      Eop Osubl (e1:::e2:::Enil)
  end.

Definition mullimm_base (n1: int64) (e2: expr) :=
  match Int64.one_bits' n1 with
  | i :: nil =>
      shllimm e2 i
  | i :: j :: nil =>
      Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j))
  | _ =>
      Eop (Omullimm n1) (e2:::Enil)
  end.

(** Original definition:
<<
Nondetfunction mullimm (n1: int64) (e2: expr) :=
  if Archi.splitlong then SplitLong.mullimm n1 e2
  else if Int64.eq n1 Int64.zero then longconst Int64.zero
  else if Int64.eq n1 Int64.one then e2
  else match e2 with
  | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2)
  | Eop (Oleal (Aindexed n2)) (t2:::Enil) => addlimm (Int64.mul n1 (Int64.repr n2)) (mullimm_base n1 t2)
  | _ => mullimm_base n1 e2
  end.
>>
*)

Inductive mullimm_cases: forall (e2: expr), Type :=
  | mullimm_case1: forall n2, mullimm_cases (Eop (Olongconst n2) Enil)
  | mullimm_case2: forall n2 t2, mullimm_cases (Eop (Oleal (Aindexed n2)) (t2:::Enil))
  | mullimm_default: forall (e2: expr), mullimm_cases e2.

Definition mullimm_match (e2: expr) :=
  match e2 as zz1 return mullimm_cases zz1 with
  | Eop (Olongconst n2) Enil => mullimm_case1 n2
  | Eop (Oleal (Aindexed n2)) (t2:::Enil) => mullimm_case2 n2 t2
  | e2 => mullimm_default e2
  end.

Definition mullimm (n1: int64) (e2: expr) :=
 if Archi.splitlong then SplitLong.mullimm n1 e2 else if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.one then e2 else match mullimm_match e2 with
  | mullimm_case1 n2 => (* Eop (Olongconst n2) Enil *)
      longconst (Int64.mul n1 n2)
  | mullimm_case2 n2 t2 => (* Eop (Oleal (Aindexed n2)) (t2:::Enil) *)
      addlimm (Int64.mul n1 (Int64.repr n2)) (mullimm_base n1 t2)
  | mullimm_default e2 =>
      mullimm_base n1 e2
  end.

(** Original definition:
<<
Nondetfunction mull (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.mull e1 e2 else
  match e1, e2 with
  | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2
  | t1, Eop (Olongconst n2) Enil => mullimm n2 t1
  | _, _ => Eop Omull (e1:::e2:::Enil)
  end.
>>
*)

Inductive mull_cases: forall (e1: expr) (e2: expr), Type :=
  | mull_case1: forall n1 t2, mull_cases (Eop (Olongconst n1) Enil) (t2)
  | mull_case2: forall t1 n2, mull_cases (t1) (Eop (Olongconst n2) Enil)
  | mull_default: forall (e1: expr) (e2: expr), mull_cases e1 e2.

Definition mull_match (e1: expr) (e2: expr) :=
  match e1 as zz1, e2 as zz2 return mull_cases zz1 zz2 with
  | Eop (Olongconst n1) Enil, t2 => mull_case1 n1 t2
  | t1, Eop (Olongconst n2) Enil => mull_case2 t1 n2
  | e1, e2 => mull_default e1 e2
  end.

Definition mull (e1: expr) (e2: expr) :=
 if Archi.splitlong then SplitLong.mull e1 e2 else match mull_match e1 e2 with
  | mull_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *)
      mullimm n1 t2
  | mull_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *)
      mullimm n2 t1
  | mull_default e1 e2 =>
      Eop Omull (e1:::e2:::Enil)
  end.

Definition mullhu (e1: expr) (n2: int64) :=
  if Archi.splitlong then SplitLong.mullhu e1 n2 else
  Eop Omullhu (e1 ::: longconst n2 ::: Enil).

Definition mullhs (e1: expr) (n2: int64) :=
  if Archi.splitlong then SplitLong.mullhs e1 n2 else
  Eop Omullhs (e1 ::: longconst n2 ::: Enil).

Definition shrxlimm (e: expr) (n: int) :=
  if Archi.splitlong then SplitLong.shrxlimm e n else
  if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil).

Definition divlu_base (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil).
Definition modlu_base (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil).
Definition divls_base (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil).
Definition modls_base (e1: expr) (e2: expr) :=
  if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil).

Definition cmplu (c: comparison) (e1 e2: expr) :=
  if Archi.splitlong then SplitLong.cmplu c e1 e2 else
  match is_longconst e1, is_longconst e2 with
  | Some n1, Some n2 =>
      Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil
  | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil)
  | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil)
  | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil)
  end.

Definition cmpl (c: comparison) (e1 e2: expr) :=
  if Archi.splitlong then SplitLong.cmpl c e1 e2 else
  match is_longconst e1, is_longconst e2 with
  | Some n1, Some n2 =>
      Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil
  | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil)
  | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil)
  | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil)
  end.

Definition longoffloat (e: expr) :=
  if Archi.splitlong then SplitLong.longoffloat e else
  Eop Olongoffloat (e:::Enil).

Definition floatoflong (e: expr) :=
  if Archi.splitlong then SplitLong.floatoflong e else
  Eop Ofloatoflong (e:::Enil).

Definition longofsingle (e: expr) :=
  if Archi.splitlong then SplitLong.longofsingle e else
  Eop Olongofsingle (e:::Enil).

Definition singleoflong (e: expr) :=
  if Archi.splitlong then SplitLong.singleoflong e else
  Eop Osingleoflong (e:::Enil).

End SELECT.


Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Common.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.StringLike.Properties.
Require Fiat.Parsers.MinimalParseOfParse.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section recursive_descent_parser.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {G : pregrammar' Char}.

  Context (Hvalid : is_true (grammar_rvalid G)).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Let rdata' : @parser_removal_dataT' _ G predata := rdp_list_rdata'.
  Local Existing Instance rdata'.

  Context {splitdata : @split_dataT Char _ _}.
  Let data : boolean_parser_dataT :=
    {| split_data := splitdata |}.
  Context {splitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G data}.

  Local Instance optsplitdata : @split_dataT Char _ _
    := { split_string_for_production p_idx str offset len
         := match to_production p_idx with
              | nil => 0::nil
              | _::nil => len::nil
              | it::_
                => match it with
                     | Terminal _ => 1::nil
                     | _ => @split_string_for_production _ _ _ splitdata p_idx str offset len
                   end
            end }.
  Let optdata : boolean_parser_dataT :=
    {| split_data := optsplitdata |}.

  Local Arguments minus !_ !_.
  Local Arguments min !_ !_.

  Local Instance optsplitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G optdata
    := { split_string_for_production_complete := _ }.
  Proof.
    pose proof (@split_string_for_production_complete _ _ _ _ _ splitdata_correct) as H.
    repeat (let x := fresh in intro x; specialize (H x)).
    revert H.
    apply ForallT_impl, ForallT_all; intro.
    apply Forall_tails_impl, Forall_tails_all; intros [|??];
    [ exact (fun x => x) | ].
    intro H;
      repeat (let x := fresh in intro x; specialize (H x));
      revert H.
    simpl in *.
    repeat match goal with
           | _ => assumption
           | [ |- ?R ?x ?x ] => reflexivity
           | [ H : S _ = 0 |- _ ] => clear -H; congruence
           | [ H : 0 = S _ |- _ ] => clear -H; congruence
           | [ H : nil = _::_ |- _ ] => clear -H; congruence
           | [ H : _::_ = nil |- _ ] => clear -H; congruence
           | [ H : _::_ = _::_ |- _ ] => inversion H; clear H
           | _ => progress subst
           | [ |- ?T -> ?T ] => exact (fun x => x)
           | [ |- context[match ?e with Terminal _ => _ | _ => _ end] ]
             => destruct e eqn:?
           | [ |- context[match ?e with nil => _ | _ => _ end] ]
             => destruct e eqn:?
           | _ => progress simpl
           | _ => rewrite Min.min_0_r
           | _ => intro
           | [ |- context[0 = min _ _] ] => exists 0
           | [ |- ?x = ?x ] => reflexivity
           | [ |- _ \/ False ] => left
           | _ => progress destruct_head @sigT
           | _ => progress destruct_head @prod
           | [ H : MinimalParse.minimal_parse_of_item _ _ (take _ (substring _ 0 _)) (Terminal _) |- _ ]
             => exfalso; inversion H; clear H
           | [ H : is_true (take _ (substring _ 0 _) ~= [_]) |- _ ]
             => apply length_singleton in H
           | [ H : length (take _ (substring _ 0 _)) = S _ |- _ ]
             => rewrite take_length, substring_length, <- Nat.sub_min_distr_r, Nat.add_sub, !Min.min_0_r in H
           | [ H : MinimalParse.minimal_parse_of_production _ _ _ nil |- _ ] => inversion H; clear H
           | [ |- MinimalParse.minimal_parse_of_production _ _ _ nil ] => constructor
           | [ H : MinimalParse.minimal_parse_of_item _ _ _ (Terminal _) |- _ ]
             => inversion H; clear H
           | [ |- MinimalParse.minimal_parse_of_item _ _ _ (Terminal _) ]
             => econstructor; [ eassumption | ]
           | [ H : length (drop _ (substring _ _ _)) = 0 |- _ ] => rewrite drop_length, substring_length in H
           | [ |- length (drop _ (substring _ _ _)) = 0 ] => rewrite drop_length, substring_length
           | [ H : ?x = 0 \/ ?T |- _ ]
             => let H' := fresh in
                destruct (Compare_dec.zerop x) as [H'|H'];
                  [ clear H
                  | assert T by (clear -H H'; destruct H; try assumption; try omega); clear H ]
           | [ |- (_ * _)%type ] => split
           | [ |- { _ : nat & _ } ] => eexists; repeat split; [ left; reflexivity | .. ]
           | [ H : ?x + ?y <= _ |- context[(?y + ?x)%nat] ]
             => not constr_eq x y; rewrite (Plus.plus_comm y x)
           | [ H : ?x + ?y <= _, H' : context[(?y + ?x)%nat] |- _ ]
             => not constr_eq x y; rewrite (Plus.plus_comm y x) in H'
           | [ H : context[(?x + 1)%nat] |- _ ] => rewrite (Plus.plus_comm x 1) in H; simpl plus in H
           | [ H : context[min ?x ?y], H' : ?y <= ?x |- _ ] => rewrite (Min.min_r x y) in H by assumption
           | [ H' : ?y <= ?x |- context[min ?x ?y] ] => rewrite (Min.min_r x y) by assumption
           | [ H : _ - _ = 0 |- _ ] => apply Nat.sub_0_le in H
           | [ |- _ - _ = 0 ] => apply Nat.sub_0_le
           | [ H : _ |- _ ] => progress rewrite ?Nat.add_sub, ?Minus.minus_plus in H
           | _ => progress rewrite ?Nat.add_sub, ?Minus.minus_plus, ?Minus.minus_diag, ?Min.min_idempotent
           | [ |- is_true (is_char (take ?x (take ?x _)) _) ]
             => rewrite take_take
           | [ H : is_true (is_char (take ?n ?str) ?ch) |- is_true (is_char ?str ?ch) ]
             => rewrite (take_long str)
               in H
               by (rewrite substring_length, Plus.plus_comm, Min.min_r by assumption; omega)
           | [ H : is_true (is_char (take ?n ?str) ?ch) |- is_true (is_char (take 1 ?str) ?ch) ]
             => apply take_n_1_singleton in H
           | [ |- MinimalParse.minimal_parse_of_production _ _ _ (_::_) ]
             => eapply @MinimalParseOfParse.expand_minimal_parse_of_production_beq;
               [ try assumption.. | eassumption ]
           | [ |- MinimalParse.minimal_parse_of_item _ _ (take 0 _) _ ]
             => eapply @MinimalParseOfParse.expand_minimal_parse_of_item_beq;
               [ try assumption.. | eassumption ]
           | [ |- MinimalParse.minimal_parse_of_item _ _ _ _ ]
             => eapply @MinimalParseOfParse.expand_minimal_parse_of_item_beq;
               [ try assumption.. | eassumption ]
           | [ H : is_true (is_char (take ?x _) _) |- ?R (drop ?x _) (drop 1 _) ]
             => apply length_singleton in H; rewrite take_length, substring_length in H
           | [ H : min ?x ?y = 1
               |- ?R (drop ?x (substring _ ?y _)) (drop 1 (substring _ ?y _)) ]
             => revert H; apply Min.min_case_strong; intros; subst;
                try reflexivity;
                apply bool_eq_empty
           | [ |- context[S ?x - ?x] ]
             => rewrite <- Nat.add_1_r, Minus.minus_plus
           | [ |- context[take ?x (take 0 _)] ]
             => rewrite take_take
           | [ |- context[min _ ?x - ?x] ]
             => rewrite <- Nat.sub_min_distr_r
           | [ H : ?y <= ?x |- context[take ?x (substring ?z ?y ?str)] ]
             => rewrite (take_long (substring z y str))
               by (rewrite substring_length, Plus.plus_comm, Min.min_r by assumption; omega)
           | [ |- context[take ?x (substring ?z ?x ?str)] ]
             => rewrite (take_long (substring z x str))
               by (rewrite substring_length, Plus.plus_comm, Min.min_r by assumption; omega)
           end.
  Qed.
End recursive_descent_parser.


(* En este archivo se incluye la representación del sistema de seguridad de
 * Android y la definición de las propiedades que debe cumplir
 * para ser considerado válido *)
Require Import DefBasicas.
Require Import EqTheorems.
Require Import Maps.
Require Export List.

Section Estado.

(* Parte estática del estado del sistema *)
Record Environment := env {
                            (* Para cada aplicación instalada por el usuario, retorna su manifiesto *)
                            manifest: mapping idApp Manifest;
                            (* Para cada aplicación instalada por el usuario, retorna el certificado con el que fue firmada *)
                            cert: mapping idApp Cert;
                            (* Para cada aplicación instalada por el usuario, retorna la lista de permisos que ella define *)
                            defPerms: mapping idApp (list Perm);
                            (* Reúne la lista de aplicaciones preinstaldas de fábrica *)
                            systemImage: list SysImgApp
                           }.

(* Parte dinámica del estado del sistema *)
Record State := st {
                    (* La lista de aplicaciones instaladas por el usuario *)
                     apps: list idApp;
                     (* Las aplicaciones que ya fueron ejecutadas alguna vez *)
                     (* NOTE: alreadyVerified \subset apps podría ser un invariante nuevo *)
                     alreadyVerified: list idApp;
                    (* Para cada aplicación instalada, retorna la lista de grupos de permisos para los cuales
                     * la aplicación posee algùn permiso otorgado *)
                     grantedPermGroups : mapping idApp (list idGrp);
                    (* Para cada aplicación instalada, retorna la lista de permisos a ella individualmente otorgados *)
                     perms: mapping idApp (list Perm);
                     (* Mapa que indica de qué componente es una instancia cada módulo en ejecución *)
                     running: mapping iCmp Cmp;
                     (* Mapa que indica a qué recursos tiene qué tipo de derecho permanentemente otorgados cada aplicación *)
                     delPPerms: mapping (idApp * CProvider * uri) PType;
                     (* Mapa que indica a qué recursos tiene qué tipo de derecho temporalmente otorgados cada módulo en ejecución *)
                     delTPerms: mapping (iCmp * CProvider * uri) PType;
                     (* Mapa que indica, dado un recurso de una aplicación, qué valor posee *)
                     resCont: mapping (idApp * res) Val;
                    (* La lista de intents que han sido enviados, junto con su remitente *)
                     sentIntents: list (iCmp*Intent)
                    }.

(* Estado del sistema *)
Record System := sys {
                       (* Conformado por una parte estática *)
                       state: State;
                       (* y una dinámica *)
                       environment: Environment
                     }.

End Estado.

Section EstadoValido.

(* La aplicación a forma parte del sistema *)
Definition isAppInstalled (a:idApp) (s:System) : Prop :=
    (* si fue instalada por el usuario *)
    In a (apps (state s)) \/
    (* o estaba preinstalada de fábrica *)
    (exists sysapp:SysImgApp,
    In sysapp (systemImage (environment s)) /\
    idSI sysapp = a).

(* Predicado para verificar si un componente pertence a una aplicación instalada *)
Definition inApp (c:Cmp)(a:idApp)(s:System) : Prop :=
exists (m:Manifest),
(* si existe una aplicación instalada por el usuario *)
(map_apply idApp_eq (manifest (environment s)) a = Value idApp m \/
(* o una preinstalada de fábrica con id a *)
(exists sysapp:SysImgApp,
    In sysapp (systemImage (environment s)) /\
    idSI sysapp = a /\
    manifestSI sysapp=m)
) /\
(* y c pertenece a ella *)
In c (cmp m).

(* Predicado para verificar si el componente que toma como parámetro es un
 * content provider *)
Definition isCProvider (c : Cmp) : Prop :=
match c with
   | cmpCP _ => True
   | _ => False
end.

(* Predicado para verificar si en s existe el recurso apuntado por el URI u en
 * el content provider cp *)
Definition existsRes (cp : CProvider)(u:uri)(s:System) : Prop :=
exists (a:idApp),
inApp (cmpCP cp) a s /\
exists r:res, map_apply uri_eq (map_res cp) u = Value uri r /\
exists v:Val, (map_apply rescontdomeq (resCont (state s))) (a, r) = Value (idApp*res) v.

(* Función que devuelve el id de un componente *)
Definition getCmpId (c:Cmp) : idCmp :=
match c with
   | cmpAct a => idA a
   | cmpSrv s => idS s
   | cmpBR br => idB br
   | cmpCP cp => idC cp
end.

(* Predicado que indica si un permiso es de sistema *)
Parameter isSystemPerm : Perm -> Prop.

(* Predicado para verificar si un permiso fue definido por el usuario en un estado *)
Definition usrDefPerm (p:Perm)(s:System) : Prop :=
(exists (a:idApp) (l: list Perm),
map_apply idApp_eq (defPerms (environment s)) a = Value idApp l /\
In p l) \/ (* Si es definido por una app instalada o *)
(exists sysapp:SysImgApp, In sysapp (systemImage (environment s)) /\
In p (defPermsSI sysapp)). (* es definido por una app de sistema *)

(* Predicado que indica si un permiso existe en el sistema *)
Definition permExists (p:Perm)(s:System) : Prop :=
    isSystemPerm p \/ usrDefPerm p s. (* Un permiso existe si es de sistema o lo define alguna app *)

Variable s:System.

(* No hay dos componentes pertenecientes a aplicaciones instaladas que tengan el mismo identificador *)
Definition allCmpDifferent : Prop :=
forall (c1 c2:Cmp)(a1 a2:idApp),
inApp c1 a1 s ->
inApp c2 a2 s ->
getCmpId c1 = getCmpId c2 -> c1 = c2.

(* Un mismo componente no está asociado a dos aplicaciones distintas *)
Definition notRepeatedCmps : Prop :=
forall (c:Cmp)(a1 a2:idApp),
inApp c a1 s ->
inApp c a2 s ->
a1 = a2.

(* Si un componente está corriendo, éste no puede ser un content provider *)
Definition notCPrunning : Prop :=
forall (ic:iCmp)(c:Cmp),
map_apply iCmp_eq (running (state s)) ic = Value iCmp c ->
~isCProvider c.

(* Si una delegación sobre un content provider que se realizó a través de intents
 * está vigente, entonces la instancia que recibió dicha delegación está ejecutándose
 * y el content provider en cuestión está instalado *)
Definition delTmpRun : Prop :=
forall (ic:iCmp)(cp:CProvider)(u:uri)(pt:PType),
map_apply deltpermsdomeq (delTPerms (state s)) (ic, cp, u) = Value (iCmp*CProvider*uri) pt ->
(exists a1: idApp, inApp (cmpCP cp) a1 s) /\
exists c:Cmp, exists a:idApp, inApp c a s /\
map_apply iCmp_eq (running (state s)) ic = Value iCmp c.

(* Si una instancia está corriendo, el componente del cual es una
 * instancia, está instalado *)
Definition cmpRunAppIns : Prop :=
forall (ic:iCmp)(c:Cmp),
map_apply iCmp_eq (running (state s)) ic = Value iCmp c ->
exists a:idApp, inApp c a s.

(* Todo recurso en el sistema pertenece a una aplicación instalada *)
Definition resContAppInst : Prop :=
forall (a:idApp)(r:res)(v:Val),
map_apply rescontdomeq (resCont (state s)) (a, r) = Value (idApp*res) v ->
isAppInstalled a s.

(* Dada una aplicación y una lista de permisos, indica si esta lista es la de los permisos
 * definidos por la aplicación *)
Definition defPermsForApp (a:idApp) (l:list Perm) : Prop :=
    map_apply idApp_eq (defPerms (environment s)) a = Value idApp l \/
    (exists sysapp:SysImgApp, In sysapp (systemImage (environment s)) /\ defPermsSI sysapp = l /\ idSI sysapp = a).

(* Si dos recursos definidos tienen igual id, son el mismo de la misma aplicación *)
Definition notDupPerm : Prop :=
forall (a a':idApp) (p p':Perm) (l l':list Perm),
defPermsForApp a l ->
defPermsForApp a' l' ->
In p l ->
In p' l' ->
idP p = idP p' ->
(p=p' /\ a=a').

(* Los permisos individualmente otorgados existen *)
Definition grantedPermsExist : Prop:=
    forall (a:idApp) (p:Perm) (l:list Perm), map_apply idApp_eq (perms (state s)) a = Value idApp l -> In p l -> permExists p s.

(* Solo las aplicaciones instalada tienen definido un manifesto, un certificado
 * y un conjunto de recursos *)
Definition statesConsistency : Prop :=
forall (a:idApp),
(In a (apps (state s)) <->
(exists m:Manifest, map_apply idApp_eq (manifest (environment s)) a = Value idApp m)) /\
(In a (apps (state s)) <->
(exists c:Cert, map_apply idApp_eq (cert (environment s)) a = Value idApp c)) /\
(In a (apps (state s)) <->
(exists l:list Perm, map_apply idApp_eq (defPerms (environment s)) a = Value idApp l)) /\
(In a (apps (state s)) \/ (exists sysapp:SysImgApp, In sysapp (systemImage (environment s)) /\ idSI sysapp = a) <->
(exists l:list Perm, (map_apply idApp_eq (perms (state s)) a = Value idApp l))) /\
(In a (apps (state s)) \/ (exists sysapp:SysImgApp, In sysapp (systemImage (environment s)) /\ idSI sysapp = a) <->
(exists l:list idGrp, map_apply idApp_eq (grantedPermGroups (state s)) a = Value idApp l)).

(* Si una aplicación figura como instalada por el usuario, no existe una aplicación
 * preinstalada con el mismo identificador *)
Definition notDupApp : Prop :=
    forall (a:idApp),
    (In a (apps (state s)) -> ~(exists sysapp:SysImgApp,
    In sysapp (systemImage (environment s)) /\
    idSI sysapp = a)).

(* Todas las aplicaciones instaladas tienen identificadores diferentes *)
Definition notDupSysApp : Prop :=
    forall (s1 s2 : SysImgApp),
    In s1 (systemImage (environment s)) /\
    In s2 (systemImage (environment s)) /\
    idSI s1 = idSI s2 -> s1 = s2.

(* Todos los maps representan funciones parciales *)
Definition allMapsCorrect : Prop :=
    map_correct (manifest (environment s)) /\
    map_correct (cert (environment s)) /\
    map_correct (defPerms (environment s)) /\
    map_correct (grantedPermGroups (state s)) /\
    map_correct (perms (state s)) /\
    map_correct (running (state s)) /\
    map_correct (delPPerms (state s)) /\
    map_correct (delTPerms (state s)) /\
    map_correct (resCont (state s)).

(* No existen intents distintos con igual identificador *)
Definition noDupSentIntents : Prop :=
    forall (i i': Intent) (ic ic' : iCmp),
        In (ic,i) (sentIntents (state s)) ->
        In (ic',i') (sentIntents (state s)) ->
        idI i = idI i' ->
        ic=ic' /\ i=i'.

(* Esta proposición vale si y sólo si el estado es válido *)
Definition validstate  : Prop := allCmpDifferent /\
                                 notRepeatedCmps /\
                                 notCPrunning /\
                                 delTmpRun /\
                                 cmpRunAppIns /\
                                 resContAppInst /\
                                 statesConsistency /\
                                 notDupApp /\
                                 notDupSysApp /\
                                 notDupPerm /\
                                 allMapsCorrect /\
                                 grantedPermsExist /\
                                 noDupSentIntents.

End EstadoValido.


From Equations Require Import Equations.
Require Import Equations.Prop.Subterm.

Require Import Psatz.

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Export SystemFR.PolarityLemmas.

Opaque makeFresh.
Opaque PeanoNat.Nat.eq_dec.
Opaque reducible_values.

Definition subset_rc (rc1 rc2: tree -> Prop) := forall v, rc1 v -> rc2 v.

Fixpoint respect_polarities pols (ρ1 ρ2: interpretation) :=
  match ρ1, ρ2 with
  | nil, nil => True
  | (X, rc1) :: ρ1', (Y, rc2) :: ρ2' =>
    X = Y /\
    (~((X, Positive) ∈ pols) -> subset_rc rc2 rc1) /\
    (~((X, Negative) ∈ pols) -> subset_rc rc1 rc2) /\
    respect_polarities pols ρ1' ρ2'
  | _, _ => False
  end.

Lemma respect_polarities_refl:
  forall pols ρ,
    respect_polarities pols ρ ρ.
Proof.
  induction ρ; steps.
Qed.

Lemma invert_twice:
  forall pol, invert_polarity (invert_polarity (pol)) = pol.
Proof.
  destruct pol; steps.
Qed.

Lemma pair_in_invert:
  forall (pols : list (nat * polarity)) (x : nat) pol,
    (x, invert_polarity pol) ∈ pols ->
    (x, pol) ∈ invert_polarities pols.
Proof.
  induction pols; repeat step || rewrite invert_twice.
Qed.

Lemma respect_polarities_invert:
  forall pols ρ1 ρ2,
    respect_polarities pols ρ1 ρ2 ->
    respect_polarities (invert_polarities pols) ρ2 ρ1.
Proof.
  induction ρ1; repeat step || apply_any || apply pair_in_invert.
Qed.

Ltac t_respect_polarities_invert :=
  match goal with
  | H: respect_polarities _ _ _ |- _ =>
    poseNew (Mark 0 "respect_polarities_invert");
    pose proof (respect_polarities_invert _ _ _ H)
  end.

Definition polarity_variance_prop T: Prop :=
  forall pols ρ1 ρ2 v,
    has_polarities T pols ->
    is_erased_type T ->
    wf T 0 ->
    pfv T term_var = nil ->
    respect_polarities pols ρ1 ρ2 ->
    valid_interpretation ρ1 ->
    valid_interpretation ρ2 ->
    [ ρ1 ⊨ v : T ]v ->
    [ ρ2 ⊨ v : T ]v.

Lemma use_respect_polarities:
  forall (pols : list (nat * polarity)) (ρ1 ρ2 : interpretation) (n : nat) (v : tree) P1 P2,
    respect_polarities pols ρ1 ρ2 ->
    ((n, Negative) ∈ pols -> False) ->
    lookup PeanoNat.Nat.eq_dec ρ1 n = Some P1 ->
    lookup PeanoNat.Nat.eq_dec ρ2 n = Some P2 ->
    P1 v ->
    P2 v.
Proof.
  induction ρ1; steps; eauto with eapply_any.
Qed.

Lemma respect_polarities_some_none:
  forall (n : nat) (pols : list (nat * polarity)) (ρ1 ρ2 : interpretation) P,
    respect_polarities pols ρ1 ρ2 ->
    lookup PeanoNat.Nat.eq_dec ρ1 n = Some P ->
    lookup PeanoNat.Nat.eq_dec ρ2 n = None ->
    False.
Proof.
  induction ρ1; steps; eauto.
Qed.

Lemma polarity_variance_fvar: forall m n f, prop_at polarity_variance_prop m (fvar n f).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || destruct_tag || simp_red || step_inversion has_polarities;
    eauto using respect_polarities_some_none.
  eapply use_respect_polarities; eauto 1; steps.
Qed.

#[export]
Hint Immediate polarity_variance_fvar: b_polarity_variance.

Lemma polarity_variance_induction:
  forall T n o pols ρ1 ρ2 v,
    prop_until polarity_variance_prop (n, o) ->
    respect_polarities pols ρ1 ρ2 ->
    has_polarities T pols ->
    type_nodes T < n ->
    is_erased_type T ->
    wf T 0 ->
    pfv T term_var = nil ->
    valid_interpretation ρ1 ->
    valid_interpretation ρ2 ->
    [ ρ1 ⊨ v : T ]v ->
    [ ρ2 ⊨ v : T ]v.
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop; intros.
  eapply_any; eauto 1; repeat step || apply left_lex.
Qed.

Lemma polarity_variance_induction_invert:
  forall T n o pols ρ1 ρ2 v,
    prop_until polarity_variance_prop (n, o) ->
    respect_polarities pols ρ1 ρ2 ->
    has_polarities T (invert_polarities pols) ->
    type_nodes T < n ->
    is_erased_type T ->
    wf T 0 ->
    pfv T term_var = nil ->
    valid_interpretation ρ1 ->
    valid_interpretation ρ2 ->
    [ ρ2 ⊨ v : T ]v ->
    [ ρ1 ⊨ v : T ]v.
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop; intros.
  eapply H with _ (invert_polarities pols) ρ2; eauto 1; repeat step || apply left_lex;
    eauto using respect_polarities_invert.
Qed.

Lemma polarity_variance_induction_open:
  forall T a n o pols ρ1 ρ2 v,
    prop_until polarity_variance_prop (n, o) ->
    respect_polarities pols ρ1 ρ2 ->
    has_polarities T pols ->
    type_nodes T < n ->
    is_erased_type T ->
    wf T 1 ->
    pfv T term_var = nil ->
    is_erased_term a ->
    wf a 0 ->
    pfv a term_var = nil ->
    valid_interpretation ρ1 ->
    valid_interpretation ρ2 ->
    is_erased_type T ->
    [ ρ1 ⊨ v : open 0 T a ]v ->
    [ ρ2 ⊨ v : open 0 T a ]v.
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop; intros.
  eapply_any; eauto 1;
    repeat step || apply left_lex || autorewrite with bsize in * ||
           apply polarity_open;
    eauto with erased fv wf.
Qed.

Lemma polarity_variance_arrow:
  forall m T1 T2, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_arrow T1 T2).
Proof.
  unfold get_measure, prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || step_inversion has_polarities || list_utils || t_reduces_to2 || apply_any;
    try solve [ eapply polarity_variance_induction_invert; try eassumption; steps; eauto with lia ];
    try solve [ eapply polarity_variance_induction_open; try eassumption; steps; eauto with lia ].
Qed.

#[export]
Hint Immediate polarity_variance_arrow: b_polarity_variance.

Lemma polarity_variance_prod:
  forall m T1 T2, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_prod T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || list_utils ||
           step_inversion has_polarities || t_reduces_to2 || apply_any || find_exists;
    try solve [ eapply polarity_variance_induction; try eassumption; steps; eauto with lia ];
    try solve [ eapply polarity_variance_induction_open; try eassumption; steps; eauto with lia ].
Qed.

#[export]
Hint Immediate polarity_variance_prod: b_polarity_variance.

Lemma polarity_variance_sum:
  forall m T1 T2, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_sum T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || list_utils || step_inversion has_polarities || find_exists;
    try solve [ eapply polarity_variance_induction; try eassumption; steps; eauto with lia ].
Qed.

#[export]
Hint Immediate polarity_variance_sum: b_polarity_variance.

Lemma polarity_variance_refine:
  forall m T b, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_refine T b).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || list_utils || step_inversion has_polarities || find_exists;
    try solve [ eapply polarity_variance_induction; try eassumption; steps; eauto with lia ].
Qed.

#[export]
Hint Immediate polarity_variance_refine: b_polarity_variance.

Lemma polarity_variance_type_refine:
  forall m T1 T2,
    prop_until polarity_variance_prop m ->
    prop_at polarity_variance_prop m (T_type_refine T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || step_inversion has_polarities || list_utils || exists p;
    try solve [ eapply polarity_variance_induction; try eassumption; steps; eauto with lia ];
    try solve [ eapply polarity_variance_induction_open; try eassumption; steps;
                eauto with lia erased fv wf ].
Qed.

#[export]
Hint Immediate polarity_variance_type_refine: b_polarity_variance.

Lemma polarity_variance_intersection:
  forall m T1 T2, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_intersection T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || list_utils || step_inversion has_polarities;
    try solve [ eapply polarity_variance_induction; try eassumption; steps;
                eauto with lia erased fv wf ].
Qed.

#[export]
Hint Immediate polarity_variance_intersection: b_polarity_variance.

Ltac reducibility_choice2 :=
  match goal with
  | H: [ _ ⊨ ?v : ?T ]v |- [ _ ⊨ ?v : ?T ]v \/ _ => left
  | H: [ _ ⊨ ?v : ?T ]v |- _ \/ [ _ ⊨ ?v : ?T ]v => right
  end.

Lemma polarity_variance_union:
  forall m T1 T2, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_union T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || step_inversion has_polarities || list_utils || reducibility_choice2;
    try solve [ eapply polarity_variance_induction; try eassumption; steps;
                eauto with lia erased fv erased ].
Qed.

#[export]
Hint Immediate polarity_variance_union: b_polarity_variance.

Lemma polarity_variance_forall:
  forall m T1 T2,
    prop_until polarity_variance_prop m ->
    prop_at polarity_variance_prop m (T_forall T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || step_inversion has_polarities || list_utils.
  eapply polarity_variance_induction_open; eauto 1; repeat step || apply leq_lt_measure || apply_any;
    try lia;
    try solve [ eapply polarity_variance_induction_invert; try eassumption; steps; eauto with lia erased ].
Qed.

#[export]
Hint Immediate polarity_variance_forall: b_polarity_variance.

Lemma polarity_variance_exists:
  forall m T1 T2, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_exists T1 T2).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || step_inversion has_polarities || list_utils || exists a;
    try solve [ eapply polarity_variance_induction; try eassumption; steps; eauto with lia erased ];
    try solve [ eapply polarity_variance_induction_open; try eassumption; steps; eauto with lia erased ].
Qed.

#[export]
Hint Immediate polarity_variance_exists: b_polarity_variance.

Lemma respect_polarities_support:
  forall (pols : list (nat * polarity)) (ρ1 ρ2 : interpretation) X,
    respect_polarities pols ρ1 ρ2 ->
    ~(X ∈ support ρ1) ->
    X ∈ support ρ2 ->
    False.
Proof.
  induction ρ1; steps; eauto.
Qed.

Lemma polarity_variance_abs:
  forall m T, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_abs T).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || step_inversion has_polarities.
  exists (makeFresh ((X :: nil) :: support pols :: support ρ2 :: pfv T type_var :: nil));
    repeat step; try finisher.

  repeat step || t_instantiate_rc || t_reduces_to.

  lazymatch goal with
  | H: [ _ ⊨ _ : _ ]v |- [ (?M,?RC) :: _ ⊨ _ : _ ]v =>
    apply (reducible_rename_one _ _ _ _ _ M) in H
  end; repeat step || finisher.

  lazymatch goal with
  | |- [ (?M,?RC) :: _ ⊨ _ : _ ]v =>
    eapply polarity_variance_induction with _ _ pols ((M,RC) :: ρ1); eauto 1
  end;
    repeat step || autorewrite with bsize in * ||
           apply has_polarities_topen; try finisher;
      eauto 2 with wf fv erased step_tactic.
Qed.

#[export]
Hint Immediate polarity_variance_abs: b_polarity_variance.

Ltac t_dangerous_rec_choice :=
  match goal with
  | H: _ ~>* zero   |- _ => left
  | H: _ ~>* succ _ |- _ => right
  end.

Lemma respect_polarities_cons:
  forall (pols : list (nat * polarity)) (ρ1 ρ2 : interpretation) X pol,
    respect_polarities pols ρ1 ρ2 ->
    respect_polarities ((X, pol) :: pols) ρ1 ρ2.
Proof.
  induction ρ1; steps.
Qed.

Lemma polarity_variance_rec:
  forall m tn T0 Ts, prop_until polarity_variance_prop m -> prop_at polarity_variance_prop m (T_rec tn T0 Ts).
Proof.
  unfold prop_at; intros; unfold polarity_variance_prop;
    repeat step || simp_red || list_utils ||
           step_inversion has_polarities || t_dangerous_rec_choice || find_exists;
    try solve [ eapply polarity_variance_induction; try eassumption; steps;
                eauto with lia erased fv wf].

  define m (makeFresh (pfv T0 type_var :: pfv Ts type_var :: support pols :: support ρ1 :: support ρ2 :: nil)).
  exists n', m;
    repeat step; try finisher.

  define m (makeFresh (pfv T0 type_var :: pfv Ts type_var :: support pols :: support ρ1 :: support ρ2 :: nil)).
  apply (reducible_rename_one _ _ _ _ _ m) in H17;
    repeat step;
      eauto using reducibility_is_candidate;
      try finisher.

  define m (makeFresh (pfv T0 type_var :: pfv Ts type_var :: support pols :: support ρ1 :: support ρ2 :: nil)).
  eapply (polarity_variance_induction _ _ _ ((m, Positive) :: pols) ((m, fun t : tree => [ ρ1 ⊨ t : T_rec n' T0 Ts ]v) :: ρ1)); eauto 1;
    repeat step || list_utils || apply respect_polarities_cons || unfold subset_rc ||
           apply reducibility_is_candidate || autorewrite with bsize in *;
    try finisher;
    try solve [ eapply has_polarities_rename_one; eauto 1; steps; try finisher ];
    eauto with lia;
    eauto with wf fv erased;
    eauto 2 with wf fv erased step_tactic.

  eapply H; eauto 1;
    repeat step || list_utils || apply right_lex || apply PolRec || apply reducibility_is_candidate;
    eauto using lt_index_step;
    eauto 2 with erased fv wf.
Qed.

#[export]
Hint Immediate polarity_variance_rec: b_polarity_variance.

Lemma polarity_variance_aux: forall (m: measure_domain) T, prop_at polarity_variance_prop m T.
Proof.
  induction m using measure_induction; destruct T;
    eauto 2 with b_polarity_variance;
    try solve [ unfold prop_at; intros; unfold polarity_variance_prop in *;
                repeat step || step_inversion has_polarities || simp_red ].
Qed.

Lemma polarity_variance: forall T, polarity_variance_prop T.
Proof.
  intros; eapply polarity_variance_aux; eauto.
Qed.

Lemma positive_grow:
  forall ρ X rc1 rc2 v T pols,
    has_polarities (topen 0 T (fvar X type_var)) ((X, Positive) :: pols) ->
    [ (X, rc1) :: ρ ⊨ v : topen 0 T (fvar X type_var) ]v ->
    subset_rc rc1 rc2 ->
    is_erased_type T ->
    wf T 0 ->
    pfv T term_var = nil ->
    valid_interpretation ρ ->
    reducibility_candidate rc1 ->
    reducibility_candidate rc2 ->
    [ (X, rc2) :: ρ ⊨ v : topen 0 T (fvar X type_var) ]v.
Proof.
  intros.
  eapply (polarity_variance _ _ ((X,rc1) :: ρ)); eauto 1; steps;
    eauto 2 using respect_polarities_refl;
    eauto 2 with erased fv wf step_tactic.
Qed.


(** This file contains the Encoding Relation for the Deflate bit
format. It is the core component of the verified implementation. It is
_axiomatic_, and therefore the single point of failure: It specifies a
compression format, but there is no guarantee that the specified
format is actually what the world understands as "deflate". We refer
to RFC 1951 in this file. *)

Require Import Coq.Logic.Decidable.
Require Import Coq.Arith.Compare_dec.

Require Import Coq.Numbers.NatInt.NZOrder.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Vectors.Vector.
Require Import Coq.Lists.List.
Require Import Coq.Vectors.Fin.
Require Import Coq.Arith.Div2.

Require Import Coq.NArith.BinNatDef.
Require Import Coq.NArith.BinNat.
Require Import Coq.PArith.BinPos.
Require Import NArith.
Require Import Coq.QArith.QArith_base.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Program.

Require Import Shorthand.
Require Import DeflateCoding.
Require Import KraftVec.
Require Import KraftList.
Require Import Combi.
Require Import Transports.
Require Import Prefix.
Require Import LSB.
Require Import Repeat.
Require Import Backreferences.
Require Import StrongDec.

Local Open Scope nat_scope.

(** See RFC 1951, section 3.2.5. *)
Definition repeatCodeExtraBits : list nat :=
  [ d"0" ; d"0" ; d"0" ; d"0" ; d"0" ; d"0" ; d"0" ; d"0" ;
    d"1" ; d"1" ; d"1" ; d"1" ;
    d"2" ; d"2" ; d"2" ; d"2" ;
    d"3" ; d"3" ; d"3" ; d"3" ;
    d"4" ; d"4" ; d"4" ; d"4" ;
    d"5" ; d"5" ; d"5" ; d"5" ;
    d"0" ].

(** See RFC 1951, section 3.2.5. *)
Definition repeatCodeBase : list nat :=
  [ d"3" ; d"4" ; d"5" ; d"6" ; d"7" ; d"8" ; d"9" ; d"10" ;
    d"11" ; d"13" ; d"15" ; d"17" ;
    d"19" ; d"23" ; d"27" ; d"31" ;
    d"35" ; d"43" ; d"51" ; d"59" ;
    d"67" ; d"83" ; d"99" ; d"115" ;
    d"131" ; d"163" ; d"195" ; d"227" ;
    d"258" ].

(** See RFC 1951, section 3.2.5. *)
Definition repeatCodeMax : list nat :=
  [ d"3"; d"4"; d"5"; d"6"; d"7"; d"8"; d"9"; d"10";
    d"12"; d"14"; d"16"; d"18";
    d"22"; d"26"; d"30"; d"34";
    d"42"; d"50"; d"58"; d"66";
    d"82"; d"98"; d"114"; d"130";
    d"162"; d"194"; d"226"; d"257";
    d"258" ].

(** See RFC 1951, section 3.2.5. *)
Definition distCodeExtraBits :=
  [ d"0"  ;  d"0"  ; d"0"  ; d"0" ;
    d"1"  ;  d"1"  ; d"2"  ; d"2" ;
    d"3"  ;  d"3"  ; d"4"  ; d"4" ;
    d"5"  ;  d"5"  ; d"6"  ; d"6" ;
    d"7"  ;  d"7"  ; d"8"  ; d"8" ;
    d"9"  ;  d"9"  ; d"10" ; d"10" ;
    d"11" ; d"11"  ; d"12" ; d"12" ;
    d"13" ; d"13" ].

(** See RFC 1951, section 3.2.5. Notice that these numbers are large,
and may cause warnings by Coq when actually evaluated.  *)
Definition distCodeBase :=
  [ d"1"     ; d"2"     ; d"3"     ; d"4"     ;
    d"5"     ; d"7"     ; d"9"     ; d"13"    ;
    d"17"    ; d"25"    ; d"33"    ; d"49"    ;
    d"65"    ; d"97"    ; d"129"   ; d"193"   ;
    d"257"   ; d"385"   ; d"513"   ; d"769"   ;
    d"1025"  ; d"1537"  ; d"2049"  ; d"3073"  ;
    d"4097"  ; d"6145"  ; d"8193"  ; d"12289" ;
    d"16385" ; d"24577" ].

(** See RFC 1951, section 3.2.5. Notice that these numbers are large,
and may cause warnings by Coq when actually evaluated.  *)
Definition distCodeMax :=
  [ d"1"     ; d"2"     ; d"3"     ; d"4"     ;
    d"6"     ; d"8"     ; d"12"    ; d"16"    ;
    d"24"    ; d"32"    ; d"48"    ; d"64"    ;
    d"96"    ; d"128"   ; d"192"   ; d"256"   ;
    d"384"   ; d"512"   ; d"768"   ; d"1024"  ;
    d"1536"  ; d"2048"  ; d"3072"  ; d"4096"  ;
    d"6144"  ; d"8192"  ; d"12288" ; d"16384" ;
    d"24576" ; d"32768" ].

(* FIXED1 *)
(** See RFC 1951, section 3.2.6. *)
Definition vector_for_fixed_lit_code : vec nat 288 :=
  of_list ((repeat 144 8) ++ (repeat (255 - 143) 9) ++
     (repeat (279 - 255) 7) ++ (repeat (287 - 279) 8)).

(** See RFC 1951, section 3.2.6. *)
Definition vector_for_fixed_dist_code : vec nat 32 :=
   of_list (repeat 32 5).
(* FIXED2 *)

(** For the constant codings, we use our already proved uniqueness and existence predicates *)
Definition fixed_lit_code_ex : { D : deflateCoding 288 | vector_for_fixed_lit_code = Vmap lb (C 288 D)}.
Proof.
  apply existence.
  compute.
  intros Q.
  inversion Q.
Defined.

(** For the constant codings, we use our already proved uniqueness and existence predicates *)
Definition fixed_dist_code_ex : { D : deflateCoding 32 | vector_for_fixed_dist_code = Vmap lb (C 32 D)}.
Proof.
  apply existence.
  compute.
  intros Q.
  inversion Q.
Defined.

Definition fixed_lit_code := proj1_sig fixed_lit_code_ex.
Definition fixed_dist_code := proj1_sig fixed_dist_code_ex.

(* HCLENSNAT1 *)
(** See RFC 1951, section 3.2.7. *)
Definition HCLensNat :=
  [16; 17; 18; 0;  8; 7;  9; 6; 10; 5;
   11;  4; 12; 3; 13; 2; 14; 1; 15].
(* HCLENSNAT2 *)

(* ONEBIT1 *)
Inductive OneBit : bool -> LB -> Prop :=
| oneBit : forall b, OneBit b [b].
(* ONEBIT2 *)

(* NBITS1 *)
Definition nBits (n : nat) : LB -> LB -> Prop :=
  nTimesCons n OneBit.
(* NBITS2 *)

(* NBITSVEC1 *)
Definition nBitsVec (n : nat) (vb : vec bool n) (l : LB)
: Prop := nBits n (to_list vb) l.
(* NBITSVEC2 *)

(** [nBytesDirect n S L] means that [S] is a sequence of the [n] Bytes
in the bit sequence [L] without back references *)

(* ONEBYTE1 *)
Definition OneByte : (Byte + nat*nat)%type -> LB -> Prop :=
  AppCombine (nBitsVec 8) inl.
(* ONEBYTE2 *)

(* NBYTESDIRECT1 *)
Definition nBytesDirect (n : nat)
: SequenceWithBackRefs Byte -> LB -> Prop :=
  nTimesCons n OneByte.
(* NBYTESDIRECT2 *)

(** [readBitsLSB length n l] means that the list [l] of given [length]
encodes the number [n] in least-significant-first bit-order. *)

Definition readBitsLSB (length : nat) : nat -> LB -> Prop :=
  AppCombine (nTimesCons length OneBit) ListToNat.

(** Uncompressed block, no padding. Padding is done in
[OneBlockWithPadding]. See RFC 1951, section 3.2.4. *)

(* UCBD1 *)
Definition UncompressedBlockDirect
  : SequenceWithBackRefs Byte -> LB -> Prop :=
  (readBitsLSB 16) >>=
  fun len  => (readBitsLSB 16) >>=
  fun nlen =>
    (fun swbr lb => len + nlen = 2 ^ 16 - 1 /\
                    nBytesDirect len swbr lb).
(* UCBD2 *)

(** header parsing for dynamically compressed blocks *)

(** [CodingOfSequence l dc] means that the list of natural numbers [l]
is the list of lengths of the coding [dc], ordered by the encoded
characters. For further detail, see [DeflateCoding]. *)

(* CODINGOFSEQUENCE1 *)
Inductive CodingOfSequence {n : nat} (l : list nat)
          (dc : deflateCoding n) :=
| makeCodingOfSequence : forall (eq : ll l = n),
    Vmap lb (C _ dc) = vec_id eq (of_list l) ->
    CodingOfSequence l dc.
(* CODINGOFSEQUENCE2 *)

(** The code length code. *)

(** Raw code length code - a list of [hclen] bit-triples, which encode code lengths from 0 to 7. *)

(* CLCHEADERRAW1 *)
Inductive CLCHeaderRaw
  : forall (hclen : nat) (input : LB) (output : list nat), Prop :=
| zeroCLCHeaderRaw : CLCHeaderRaw 0 nil nil
| succCLCHeaderRaw : forall n i o j m, CLCHeaderRaw n i o ->
   ll m = 3 -> LSBnat m j -> CLCHeaderRaw (S n) (m ++ i) (j :: o).
(* CLCHEADERRAW2 *)

(** Pad the raw header with zeroes, so its length is 19. *)

(* CLCHEADERPADDED1 *)
Inductive CLCHeaderPadded
  (hclen : nat) (input : LB) (output : list nat) : Prop :=
| makeCLCHeaderPadded : forall m output1,
                         CLCHeaderRaw hclen input output1 ->
                         output = output1 ++ repeat m 0 ->
                         ll output = 19 ->
                         CLCHeaderPadded hclen input output.
(* CLCHEADERPADDED2 *)

(** Apply the permutation to the padded header. *)

(* CLCHEADERPERMUTED1 *)
Inductive CLCHeaderPermuted
    (hclen : nat) (input : LB) (output : list nat) : Prop :=
| makeCLCHeaderPermuted :
   forall output1,
        CLCHeaderPadded hclen input output1 ->
        (forall m, nth_error output (nth m HCLensNat 19) =
	           nth_error output1 m) ->
         CLCHeaderPermuted hclen input output.
(* CLCHEADERPERMUTED2*)

(** [CLCHeader hclen output input] means that the code length coding [output] is encoded in thee [hclen]*3 bits (see above) from [input]. *)

(* CLCHEADER1 *)
Inductive CLCHeader
  (hclen : nat) (output : deflateCoding 19) (input : LB) : Prop :=
| makeCLCHeader : forall cooked,
                    CLCHeaderPermuted hclen input cooked ->
                    CodingOfSequence cooked output ->
                    CLCHeader hclen output input.
(* CLCHEADER2 *)

(** This definition is rather complicated, but it makes later
definitions easier, and encodes a pattern that occurs in multiple
places: A code from a coding is followed by some suffix bits, and
encodes a value which must be in a given range.

Let [coding] be a given Deflate coding, [mincode] be a natural number
denoting the minimal encoded code which is allowed, [xbitnums] the
numbers of extra bits for a given encoded code, starting from the
extra bits for [mincode], [bases] the corresponding minimal encoded
values, and [maxs] the corresponding maximal values. Then
[CompressedWithExtraBits coding mincode xbitnums bases maxs n l] means
that the bit list [l] encodes the value [n], according to these
rules. *)

(* CWEB1 *)
Inductive CompressedWithExtraBits
       {m : nat} (coding : deflateCoding m)
       (mincode : nat) (xbitnums bases maxs : list nat)
       : nat -> LB -> Prop :=
| complength
  : forall (base extra code max xbitnum : nat) (bbits xbits : LB),
     dc_enc coding (mincode + code) bbits -> (* code >= mincode *)
     nth_error xbitnums code = Some xbitnum -> (* # of addit. bits*)
     nth_error bases code = Some base -> (* base *)
     nth_error maxs code = Some max -> (* maximum *)
     ll xbits = xbitnum -> (* addit. bits have specified length *)
     LSBnat xbits extra -> (* binary number made by xbits *)
     base + extra <= max ->
     CompressedWithExtraBits coding mincode xbitnums
                   bases maxs (base + extra) (bbits ++ xbits).
(* CWEB2 *)

(** A sequence of code lengths, encoded with the given code length
coding. See RFC 1951 section 3.2.7. We encode into a sequence with
backreferences, because some codes encode repetitions. *)

(* CCLSWBR1 *)
Inductive CommonCodeLengthsSWBR (clc : deflateCoding 19)
  : nat -> SequenceWithBackRefs nat -> LB -> Prop :=
| cswbr0 : CommonCodeLengthsSWBR clc 0 [] []
| cswbrc :
    forall m n brs lb1 input,
      CommonCodeLengthsSWBR clc n brs lb1 ->
      m < 16 ->
      dc_enc clc m input ->
      CommonCodeLengthsSWBR clc (n + 1) (inl m :: brs)
                            (input ++ lb1)
| cswbr16 :
    forall m n brs lb1 input,
      CommonCodeLengthsSWBR clc n brs lb1 ->
      CompressedWithExtraBits clc 16 [2] [3] [6] m input ->
      CommonCodeLengthsSWBR clc (n + m) (inr (m, 1) :: brs)
                            (input ++ lb1)
| cswbr17 :
    forall m n brs lb1 input,
      CommonCodeLengthsSWBR clc n brs lb1 ->
      CompressedWithExtraBits clc 17 [3] [3 - 1] [10 - 1] m input ->
      CommonCodeLengthsSWBR clc (n + m + 1) (inl 0 :: inr (m, 1) :: brs)
                            (input ++ lb1)
| cswbr18 :
    forall m n brs lb1 input,
      CommonCodeLengthsSWBR clc n brs lb1 ->
      CompressedWithExtraBits clc 18 [7] [11 - 1] [138 - 1] m input ->
      CommonCodeLengthsSWBR clc (n + m + 1) (inl 0 :: inr (m, 1) :: brs)
                            (input ++ lb1).
(* CCLSWBR2 *)

(** A sequence of code lengths, encoded with the given code length
coding. Backreferences will be resolved, so only code lengths 0
through 15 remain. *)

(* CCLN1 *)
Inductive CommonCodeLengthsN (clc : deflateCoding 19) (n : nat)
          (B : list nat) (A : LB) : Prop :=
| ccl : forall C, CommonCodeLengthsSWBR clc n C A ->
                  ResolveBackReferences C B ->
                  CommonCodeLengthsN clc n B A.
(* CCLN2 *)

(** After the code lengths are read and repeated, they are split and
then parsed into a literal/lengt and a distance code lengths . *)

(* SCL1 *)
Inductive SplitCodeLengths (clc : deflateCoding 19) (hlit hdist : nat)
          (litlen : vec nat 288) (dist : vec nat 32) (input : LB)
  : Prop :=
| makeSplitCodeLengths :
    forall litlenL distL lm ld,
      ll litlenL = hlit ->
      ll distL = hdist ->
      to_list litlen = litlenL ++ repeat lm 0 ->
      to_list dist = distL ++ repeat ld 0 ->
      CommonCodeLengthsN clc (hlit + hdist) (litlenL ++ distL) input ->
      SplitCodeLengths clc hlit hdist litlen dist input.
(* SCL2 *)

(** From the vector of lengths, encode codings *)

(* LLD1 *)
Inductive LitLenDist (clc : deflateCoding 19) (hlit hdist : nat)
          (litlen : deflateCoding 288) (dist : deflateCoding 32)
          (input : LB) : Prop :=
| makeLitLenDist :
    SplitCodeLengths clc hlit hdist
                     (Vmap lb (C 288 litlen))
                     (Vmap lb (C 32 dist)) input ->
    LitLenDist clc hlit hdist litlen dist input.
(* LLD2 *)

(* LENDIST1 *)
Function CompressedLength (litlen : deflateCoding 288) :=
 CompressedWithExtraBits
   litlen 257 repeatCodeExtraBits repeatCodeBase repeatCodeMax.
Function CompressedDist (dist : deflateCoding 32) :=
 CompressedWithExtraBits
  dist 0 distCodeExtraBits distCodeBase distCodeMax.
(* LENDIST2 *)

(* CSWBR1 *)
Inductive CompressedSWBR
 (litlen : deflateCoding 288) (dist : deflateCoding 32)
 : SequenceWithBackRefs Byte -> LB -> Prop :=
| cswbr_end : forall l, dc_enc litlen 256 l ->
                          CompressedSWBR litlen dist [] l
| cswbr_direct : forall prev_swbr prev_lb l n,
                   dc_enc litlen (ByteToNat n) l ->
                   CompressedSWBR litlen dist prev_swbr prev_lb ->
                   CompressedSWBR litlen dist ((inl n) :: prev_swbr)
		                              (l ++ prev_lb)
| cswbr_backref : forall prev_swbr prev_lb l d lbits dbits,
                    CompressedSWBR litlen dist prev_swbr prev_lb ->
                    CompressedLength litlen l lbits ->
                    CompressedDist dist d dbits ->
                    CompressedSWBR litlen dist
		                   ((inr (l, d)) :: prev_swbr)
		                   (lbits ++ dbits ++ prev_lb).
(* CSWBR2 *)

(* DCH1 *)
Definition DynamicallyCompressedHeader
  : (deflateCoding 288 * deflateCoding 32) -> LB -> Prop :=
  (readBitsLSB 5)
    >>= fun hlit => (readBitsLSB 5)
    >>= fun hdist => (readBitsLSB 4)
    >>= fun hclen => (CLCHeader (hclen + 4))
    >>= fun clc lld =>
          LitLenDist clc (hlit + 257) (hdist + 1) (fst lld) (snd lld).
(* DCH2 *)

(* DCB1 *)
Definition DynamicallyCompressedBlock
  : SequenceWithBackRefs Byte -> LB -> Prop :=
  DynamicallyCompressedHeader
    >>= fun lld => CompressedSWBR (fst lld) (snd lld).
(* DCB2 *)

(** A statically compressed block is a block with defined static codings *)

(* STATIC1 *)
Inductive StaticallyCompressedBlock
             (output : SequenceWithBackRefs Byte) : LB -> Prop :=
| makeSCB :
    forall input,
      CompressedSWBR fixed_lit_code fixed_dist_code output input ->
      StaticallyCompressedBlock output input.
(* STATIC2 *)

(** The natural argument denotes the bits that have already been
read. Padding is assured by making the bit count a multiple of
eight. *)

(* TOPLEVEL5 *)
Inductive OneBlockWithPadding
  (out : SequenceWithBackRefs Byte) : nat -> LB -> Prop :=
| obwpDCB : forall dcb n,
  DynamicallyCompressedBlock out dcb ->
   OneBlockWithPadding out n (false :: true :: dcb)
| obwpSCB : forall scb n, StaticallyCompressedBlock out scb ->
   OneBlockWithPadding out n (true :: false :: scb)
| obwpUCB : forall ucb n m pad,
   UncompressedBlockDirect out ucb ->
   n + ll (false :: false :: pad) = 8 * m ->
   ll pad < 8 ->
   OneBlockWithPadding out n (false :: false :: pad ++ ucb).
(* TOPLEVEL6 *)

(* TOPLEVEL3 *)
Inductive ManyBlocks : nat -> SequenceWithBackRefs Byte
					  -> LB -> Prop :=
| lastBlock : forall n inp out,
                OneBlockWithPadding out (n + 1) inp ->
                ManyBlocks n out (true :: inp)
| middleBlock : forall n inp1 inp2 out1 out2,
    OneBlockWithPadding out1 (n + 1) inp1 ->
    ManyBlocks (n + 1 + ll inp1) out2 inp2 ->
    ManyBlocks n (out1 ++ out2) (false :: inp1 ++ inp2).
(* TOPLEVEL4 *)

(* TOPLEVEL1 *)
Inductive DeflateEncodes (out : LByte) (inp : LB) : Prop :=
| deflateEncodes : forall swbr,
                     ManyBlocks 0 swbr inp ->
                     ResolveBackReferences swbr out ->
                     DeflateEncodes out inp.
(* TOPLEVEL2 *)