(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .
Axiom context_WhyType : WhyType context.
Existing Instance context_WhyType.

(* Why3 assumption *)
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.

(* Why3 assumption *)
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

(* Why3 goal *)
Theorem WP_parameter_reduction : forall (t:term),
  match t with
  | S => True
  | K => True
  | (App t1 t2) => forall (result:term), ((relTR t1 result) /\
      (is_value result)) ->
      match result with
      | K => True
      | S => True
      | (App K v1) => forall (us:term), ((relTR t2 us) /\ (is_value us)) ->
          (relTR t v1)
      | (App S v1) => True
      | (App (App S v1) v2) => True
      | _ => True
      end
  end.
intuition.
destruct t; intuition.
destruct result; intuition.
destruct result1; intuition.
apply relTR_transitive with (App (App K result2) t2); auto.
apply red_star_left; auto.
apply relTR_transitive with (App (App K result2) us); auto.
apply red_star_right; auto.
assert (is_value result2).
simpl in H1; auto.
eapply StepTransRefl.
apply BaseTransRefl.
apply (red_K Hole); auto.
red; auto.
destruct result1_1; auto.
Qed.


(**

CoqDVM is a Verifier with Proof Carrying Code for a subset of Dalvik Virtual Machine (DVM).
This subset of Dalvik Virtual Machine is made keeping Occam's Razor in mind.

* Goals

CoqDVM targets to prove security related aspects on Dalvik bytecode, making use of Coq. Reason to use
Coq is to be able to prove correctness of implementations and theorems about DVM at the same time.
Dalvik bein Register Based and with support for Objects and arrays makes the said properties more interesting.
Milestones in order can be written as:
- Designing a simple subset of Dalvik
- Providing functionality over this small subset
- Testing then enhanching subset with more instruction
- Prove theorems about DVM implementation
  - Progress Theorem
  - Preservation Theorem
  - Heap Soundness Theorem

* Overview

To begin with, lets take top to bottom view approach. Which means we will go
to deeper level of abstractions after describing top level abstractions.
CoqDVM from topmost view can be broken into following units:
- General Units providing universal functions
- Syntax Defining Units provide syntax used by CoqDVM
- Semantic Defining Units which basically are an implementation for given syntax
- Proof Units formed by files carrying relations and theorems over CoqDVM

** General Units

This part of CoqDVM is made by Helpers Module and DList Module. Both of these files provide
generic functionality. Helper provides functions and definitions as general as Option for monads
fold, map, filter for list operations. List on other hand provides a Parameterised module on lists
with list function alog with their Relation eqvivalents. The benefits of having a relation equivalent
are from proof perspective as they aren't bound by termination coditions, which is key feature writing
multi step relation for CoqDVM. We will discuss this further during Instruction Module which is part
of semantic defining units.

** Syntax Defining Units

This part is formed by modules Primitives Defs Program DvmState and Method.

*** Primitives

Primitives Module defines Primitive types of Coqdoc along with arithmetic over primitives,
Cast & Compare operation on primitives and also fuction to genrate equivalent natural(nat) or
generate primitive provided type and natural. Primitives Modules also hosts definition of
Operators in CoqDVM.

*** Defs

Defs module as the name suggest defines the core syntax of CoqDVM, key definitions worth
mentioning are:
- Constant (Not defined in primitives)
- lhs & rhs (Almost as their name suggest except there is no equality)
- Instruction (Defines Syntax for valid instructions)
- Method, Field, Class (For object oriented features)
- Val (Values that register can hold, allows refrences)
- Object & Array (Semantic Domain for the former in Heap)
- Program (Allowed program definition, note no verification on class/method/field links is done, its done on runtime)

*** Method & Program

These are very small modules, which basically provide few simple operation on their corresponding Semantic Domain.
- Program basically allows one to fetch its constituent Classes, Methods & Fields.
- Method allows to get next program counter provided current counter, getting instruction at given counter etc.

*** DvmState

DvmState is as much part of semantic defining unit as much it is for syntax definitions. In DvmState we
introduce DVMState which is syntax definition for current state of CoqDVM. In DvmState we also
introduce deltaState, which we use to represent unit changes between two DVMState's. So any changes CoqDVM
undergoes on execution of one or more Instructions is mapped into a list of deltaState. Then we finally
introduce mkChange and mkChanges, which determine given a DVMState and deltaState / list deltaState respectively,
the final DVMState based on both these inputs, which CoqDVM should be in.

** Semantic Definining Units

The semantics for CoqDVM is covered by modules DvmState(already described), Eval, DType and Instructions.

*** Eval

Eval module consists mainly of three important fixpoint definitions and their relation equivalents, which are
- evalReg : it take a register location as input followed by current state, and produces value for asked Register
- evalLhs : it takes an expression of semantic domain lhs followed by state producing its computed value
- evalRhs : Just like previous two function this one computes value for expression of domain rhs in a given state.

*** DType

DType modules deals with operations on composite types. It can primarily be said to deal with following three operations

- createObject : returns a newly created object(No constructors called yet) of input type, this definition is used by
  instruction new
- createArray : returns a newly created 1 dimensional array of given type, this definition is used by newarr instrucction
- cast : This instruction does type casting for composite types.

*** Instructions

Instructions modules is a huge module, since it provide semantics for each and every instruction in CoqDVM.
We take tagcode of given instruction, appending its name with eval & first letter capitalised we get name for its
implementation definition. For e.g. : implementation of nop is given in evalNop, branch is given in evalBranch.
Finally we couple all these definition together in single definition evalInst which given an Instruction, current State
and Program returns list deltaState which can be used to compute next State using mkChanges defined in DvmState.
And to add more simplicity we define stepFix and multiStepFix which given State and Program take step based on what
current instruction is, by application of evalInst and mkChanges.

** Proof Units

This part of CoqDVM is still upgrading, currently it consists of modules Example, Consistency and Progress.

*** Consistency

We define inductive definitions of relation which take care of necessities to compute corresponding execution unit.
For example consistentEvalReg n st will have an evidence only if Register n is compuptable in state st.
This makes every consistent Relation over states to have evidence for halt state and never for stuck state.
We define consistency relation for each instruction taking care of its parameters as input and then finally couple
them all as single relation on instruction as consistentInst. Consistency has many uses, primary use for it now is
in Progress property and Heap soundness property.

*** Example

This module is completely optional but we have it for testing purpose. Here we have CoqDVM implementation of a source
Java program which we converted into a sub-dalvik equivalent and then we defined in CoqDVM. We make use of example
file in Instructions module where we use multiStepFix on program and state defined in it.

*** Progress

This module is to prove progress property on CoqDVM and is in development right now.

*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m2e224p2e192p2e96m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(* ill example file for yalla library *)

(** * Example of a concrete use of the yalla library: ILL *)

Require Import CMorphisms.

Require Import Injective.
Require Import List_Type_more.
Require Import Permutation_Type_more.
Require Import Permutation_Type_solve.

(** ** 0. load the [yalla] library *)

Require ill_cut.

(** ** 1. define formulas *)
Require Export ill.

Lemma pt2ypt : forall A l1 l2, @Permutation_Type A l1 l2 ->
  @Permutation_Type.Permutation_Type A l1 l2.
Proof.
intros A l1 l2 HP ; induction HP ; econstructor ; eassumption.
Qed.

Lemma ypt2pt : forall A l1 l2, @Permutation_Type.Permutation_Type A l1 l2 ->
  @Permutation_Type A l1 l2.
Proof.
intros A l1 l2 HP ; induction HP ; econstructor ; eassumption.
Qed.

(** ** 2. define embedding into [formulas.formula] *)

Fixpoint ill2ill A :=
match A with
| ivar x    => iformulas.ivar (Some x)
| ione      => iformulas.ione
| itens A B => iformulas.itens (ill2ill A) (ill2ill B)
| ilmap A B => iformulas.ilmap (ill2ill A) (ill2ill B)
| itop      => iformulas.itop
| iwith A B => iformulas.iwith (ill2ill A) (ill2ill B)
| izero     => iformulas.izero
| iplus A B => iformulas.iplus (ill2ill A) (ill2ill B)
| ioc A     => iformulas.ioc (ill2ill A)
end.

Lemma ill2ill_inj : injective ill2ill.
Proof.
intros A.
induction A ; intros B Heq ;
  destruct B ; inversion Heq ;
  try apply IHA in H0 ;
  try apply IHA1 in H0 ;
  try apply IHA2 in H1 ; subst ;
  reflexivity.
Qed.

Lemma ill2ill_map_ioc : forall l,
  map ill2ill (map ioc l) = map iformulas.ioc (map ill2ill l).
Proof with try reflexivity.
induction l...
simpl ; rewrite IHl...
Qed.

Lemma ill2ill_map_ioc_inv : forall l1 l2,
  map iformulas.ioc l1 = map ill2ill l2 ->
    { l2' | l2 = map ioc l2' /\ l1 = map ill2ill l2' }.
Proof with try assumption ; try reflexivity.
induction l1 ; intros l2 Heq ;
  destruct l2 ; inversion Heq...
- exists nil ; split...
- apply IHl1 in H1.
  destruct i ; inversion H0 ; subst.
  destruct H1 as (l2' & Heq1 & H1) ; subst.
  exists (i :: l2') ; split...
Qed.

(** ** 3. define proofs *)

Instance ill_perm {C} : Proper ((@Permutation_Type _) ==> Basics.arrow) (fun l => ill l C).
Proof.
intros l1 l2 HP pi.
eapply ex_ir ; eassumption.
Qed.

(** ** 4. characterize corresponding [ill] fragment *)

Definition ipfrag_ill := ill_def.mk_ipfrag false ill_def.NoIAxioms true.
(*                                         cut           axioms    perm  *)
Definition ill_ll := ill_def.ill ipfrag_ill.

(** ** 5. prove equivalence of proof predicates *)

Lemma ill2illfrag : forall l A, ill l A -> ill_ll (map ill2ill l) (ill2ill A).
Proof with try eassumption ; try reflexivity.
intros l A pi.
induction pi ; rewrite <- (app_nil_l _) ; try (now constructor) ; try rewrite map_app.
- apply pt2ypt in p.
  eapply ill_def.ex_ir...
  apply Permutation_Type_map...
- rewrite app_nil_l ; constructor...
- eapply ill_def.ex_ir.
  + simpl in IHpi2 ; rewrite <- (app_nil_l _) in IHpi2.
    apply (ill_def.lmap_ilr _ _ _ _ _ _ _ IHpi1 IHpi2).
  + simpl ; perm_Type_solve.
- simpl ; rewrite ill2ill_map_ioc.
  apply ill_def.oc_irr.
  rewrite <- ill2ill_map_ioc...
Qed.

Lemma illfrag2ill : forall l A, ill_ll (map ill2ill l) (ill2ill A) -> ill l A.
Proof with try eassumption ; try reflexivity.
intros l A pi.
remember (map ill2ill l) as l0 ; remember (ill2ill A) as A0.
revert l Heql0 A HeqA0 ; induction pi ; intros l' Heql0 A' HeqA0 ; subst ;
  try (inversion f ; fail) ;
  try (destruct A' ; inversion HeqA0 ; subst ; try (decomp_map_Type Heql0 ; subst) ; constructor ;
         try (apply IHpi ; try assumption ; try reflexivity ; fail) ;
         try (apply IHpi1 ; try assumption ; try reflexivity ; fail) ;
         try (apply IHpi2 ; try assumption ; try reflexivity ; fail) ; fail).
- destruct A' ; inversion HeqA0.
  destruct l' ; inversion Heql0 ; destruct l' ; inversion Heql0.
  destruct i0 ; inversion H3 ; subst.
  inversion H4 ; subst.
  apply ax_ir.
- simpl in p.
  apply Permutation_Type_map_inv in p.
  destruct p as [l'' Heq HP].
  apply Permutation_Type_sym in HP.
  apply ypt2pt in HP.
  eapply ex_ir...
  apply IHpi...
- decomp_map_Type Heql0 ; subst.
  simpl in Heql0 ; apply ill2ill_map_ioc_inv in Heql0 ;
    destruct Heql0 as (l & ? & ?) ; subst.
  apply Permutation_Type_map_inv in p ; destruct p as [l' Heq HP] ; subst.
  eapply ex_ir ;
    [ apply IHpi ; try reflexivity ;
      rewrite <- ill2ill_map_ioc ; rewrite <- ? map_app | ]...
  apply ypt2pt.
  apply Permutation_Type_app_head.
  apply Permutation_Type_app_tail.
  symmetry in HP ; apply Permutation_Type_map...
- destruct A' ; inversion HeqA0.
  destruct l' ; inversion Heql0.
  apply one_irr.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0.
  eapply ex_ir.
  + apply one_ilr.
    apply IHpi...
    rewrite <- ? map_app...
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply tens_ilr.
    eapply (ex_ir _ (x1 :: x2 :: l0 ++ l4)).
    * apply (IHpi (l0 ++ x1 :: x2 :: l4))...
      simpl ; rewrite map_app...
    * apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql3 ; subst.
  eapply ex_ir.
  + apply lmap_ilr.
    * apply IHpi1...
    * eapply (ex_ir (l3 ++ x2 :: l7) (x2 :: l3 ++ l7)).
      -- apply IHpi2...
         simpl ; rewrite map_app...
      -- apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply with_ilr1.
    eapply (ex_ir _ (x1 :: l0 ++ l4)).
    * apply (IHpi (l0 ++ x1 :: l4))...
      simpl ; rewrite map_app...
    * apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply with_ilr2.
    eapply (ex_ir _ (x2 :: l0 ++ l4)).
    * apply (IHpi (l0 ++ x2 :: l4))...
      simpl ; rewrite map_app...
    * apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + eapply (zero_ilr (l0 ++ l4)).
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply plus_ilr.
    * eapply (ex_ir _ (x1 :: l0 ++ l4)).
      -- apply (IHpi1 (l0 ++ x1 :: l4))...
         simpl ; rewrite map_app...
      -- apply ypt2pt ; perm_Type_solve.
    * eapply (ex_ir _ (x2 :: l0 ++ l4)).
      -- apply (IHpi2 (l0 ++ x2 :: l4))...
         simpl ; rewrite map_app...
      -- apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- destruct A' ; inversion HeqA0 ; subst.
  apply ill2ill_map_ioc_inv in Heql0.
  destruct Heql0 as (l'' & Heq1 & Heq2) ; subst.
  apply oc_irr.
  apply IHpi...
  symmetry ; apply ill2ill_map_ioc.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply de_ilr.
    eapply (ex_ir _ (x :: l0 ++ l4)).
    * apply (IHpi (l0 ++ x :: l4))...
      simpl ; rewrite map_app...
    * apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply wk_ilr.
    apply (IHpi (l0 ++ l4))...
    simpl ; rewrite map_app...
  + apply ypt2pt ; perm_Type_solve.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql0 ; subst.
  eapply ex_ir.
  + apply co_ilr.
    eapply (ex_ir _ (ioc x :: ioc x :: l0 ++ l4)).
    * apply (IHpi (l0 ++ ioc x :: ioc x :: l4))...
      simpl ; rewrite map_app...
    * apply ypt2pt ; perm_Type_solve.
  + apply ypt2pt ; perm_Type_solve.
- destruct a.
Qed.

(** ** 6. import properties *)

(** *** axiom expansion *)

Lemma ax_gen_r : forall A, ill (A :: nil) A.
Proof.
intro A.
apply illfrag2ill.
apply ill_def.ax_exp_ill.
Qed.

(** *** cut admissibility *)

Lemma cut_r : forall A l1 l2 C,
  ill l1 A -> ill (A :: l2) C -> ill (l1 ++ l2) C.
Proof with try eassumption.
intros A l1 l2 C pi1 pi2.
apply illfrag2ill.
rewrite map_app.
rewrite <- (app_nil_l _).
apply ill2illfrag in pi1.
apply ill2illfrag in pi2.
eapply ill_cut.cut_ir_axfree...
intros a ; destruct a.
Qed.


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.
From Category.Instances Require Import NatTranComp FunctorCategory Product.ProductCategory.

Set Universe Polymorphism.

(* Currying *)
Module Currying.

  Section Currying.

    Context {C D E : Category}.
    Variable F : Functor (ProductCat C D) E.

    Program Definition Curry (X : Obj C) : Functor D E :=
      {|
        FApp := fun Y => FApp F (pair X Y);
        FAppH := fun Y1 Y2 (g : Hom Y1 Y2)
                 => FAppH F (pair (\Id X) g : @Hom (ProductCat C D) (pair X Y1) (pair X Y2))
      |}.
    Next Obligation.
    Proof.
      rewrite <- FAppH_comp_eq.
      rewrite /=.
      rewrite Hom_IdL.
      reflexivity.
    Qed.
    Next Obligation.
      rewrite Functor_id_eq.
      reflexivity.
    Qed.

    Program Definition Curry_Hom {X1 X2 : Obj C} (f : Hom X1 X2) : NatTran (Curry X1) (Curry X2) :=
      {|
        NApp := fun Y => FAppH F (pair f (\Id Y) : @Hom (ProductCat C D) (pair X1 Y) (pair X2 Y))
      |}.
    Next Obligation.
    Proof.
      repeat rewrite <- FAppH_comp_eq.
      rewrite /=.
      repeat rewrite Hom_IdL.
      repeat rewrite Hom_IdR.
      reflexivity.
    Qed.

  End Currying.

End Currying.

Program Definition FunctorCurrying {C D E : Category} (F : Functor (ProductCat C D) E) : Functor C (FunctorCategory D E) :=
  {|
    FApp := fun X => Currying.Curry F X;
    FAppH := fun X1 X2 f => Currying.Curry_Hom F f
  |}.
Next Obligation.
Proof.
  apply: ToNatTranEq.
  rewrite /=.
  apply: functional_extensionality_dep.
  move => W.
  rewrite <- FAppH_comp_eq.
  rewrite /=.
  rewrite Hom_IdL.
  reflexivity.
Qed.
Next Obligation.
Proof.
  apply: ToNatTranEq.
  rewrite /=.
  apply: functional_extensionality_dep.
  move => W.
  rewrite Functor_id_eq.
  reflexivity.
Qed.

(* Uncurrying *)

Program Definition FunctorUncurrying {C D E : Category} (G : Functor C (FunctorCategory D E))
  : Functor (ProductCat C D) E :=
  {|
    FApp := fun X => FApp (FApp G (fst X)) (snd X);
    FAppH := fun X1 X2 p =>
               FAppH (FApp G (fst X2)) (snd p) \o NApp (FAppH G (fst p)) (snd X1)
  |}.
Next Obligation.
Proof.
  rewrite /=.
  repeat rewrite FAppH_comp_eq.
  rewrite (Hom_assoc (FAppH (FApp G o) h2) (FAppH (FApp G o) h0)).
  rewrite (Hom_assoc (FAppH (FApp G o) h2) (NApp (FAppH G h1) o2)).
  apply: f_equal.
  rewrite /=.
  repeat rewrite <- Hom_assoc.
  apply: (f_equal (fun a => a \o NApp (FAppH G h) o4)).
  rewrite <- NatTran_rectangle.
  reflexivity.
Qed.
Next Obligation.
Proof.
  rewrite /=.
  rewrite Functor_id_eq.
  rewrite Hom_IdL.
  rewrite Functor_id_eq.
  rewrite /=.
  reflexivity.
Qed.

Lemma F_currying_uncurrying_eq {C D E : Category} :
  forall (G : Functor C (FunctorCategory D E)),
    FunctorCurrying (FunctorUncurrying G) = G.
Proof.
  move => G.
  apply: ToFunctorEq => X1 X2 f.
  unfold Hom_eq'.
  have: (forall (X : Obj C), FApp (FunctorCurrying (FunctorUncurrying G)) X = FApp G X).
  {
    move => X.
    apply: ToFunctorEq => Y1 Y2 g.
    unfold Hom_eq'.
    rewrite /=.
    apply: eq_Hom_eq'.
    rewrite Functor_id_eq.
    rewrite /=.
    rewrite Hom_IdR.
    reflexivity.
  }
  move => Curry_eqH.
  exists (Curry_eqH X1).
  exists (Curry_eqH X2).
  rewrite /=.
  apply: ToNatTranEq.
  apply: functional_extensionality_dep.
  move => Y.
  rewrite /=.
  rewrite Functor_id_eq.
  rewrite Hom_IdL.
  have: (forall (X : Obj C), FApp (FApp G X) Y = FApp (FApp (FunctorCurrying (FunctorUncurrying G)) X) Y).
  {
    move => X.
    move: (Curry_eqH X) =>->.
    reflexivity.
  }
  move => Curry_eqH'.
  transitivity (NApp (HomId' (Curry_eqH X2)) Y \o (HomId' (Curry_eqH' X2)) \o NApp (FAppH G f) Y).
  {
    apply: f_equal.
    simpl in Curry_eqH'.
    rewrite HomId'_id.
    rewrite Hom_IdL.
    reflexivity.
  }
  transitivity (NApp (FAppH G f) Y \o NApp (HomId' (Curry_eqH X1)) Y \o HomId' (Curry_eqH' X1)).
  {
    rewrite (NApp_HomId'_eq (Curry_eqH X2) Y (eq_sym (Curry_eqH' X2))).
    rewrite (NApp_HomId'_eq (Curry_eqH X1) Y (eq_sym (Curry_eqH' X1))).
    rewrite /=.
    rewrite HomId'_sym_id.
    rewrite Hom_IdR.
    rewrite <- Hom_assoc.
    rewrite HomId'_sym_id.
    rewrite Hom_IdL.
    reflexivity.
  }
  simpl in Curry_eqH'.
  rewrite HomId'_id.
  rewrite Hom_IdR.
  reflexivity.
Qed.

Lemma F_uncurrying_currying_eq {C D E : Category} :
  forall (F : Functor (ProductCat C D) E),
    FunctorUncurrying (FunctorCurrying F) = F.
Proof.
  move => F.
  apply: ToFunctorEq.
  case => X1 X2.
  case => Y1 Y2.
  case.
  rewrite /=.
  move => f1 f2.
  apply eq_Hom_eq'.
  rewrite <- FAppH_comp_eq.
  rewrite /=.
  rewrite Hom_IdL.
  rewrite Hom_IdR.
  reflexivity.
Qed.


Definition reverse_get(M: map K V)(v: V): option K :=
  snd (fold_left (fun '(seen_keys, res) '(ki, vi) =>
                    if in_dec keq ki seen_keys then (seen_keys, res)
                    else (ki :: seen_keys, if veq vi v then Some ki else res))
                 M (empty_set, None)).


Require Export ZArith.
Require Export String.
Require Export maps.

Require Export proof.

Open Scope string_scope.

Set Implicit Arguments.

Inductive Exp : Set :=
   BCon : bool -> Exp
 | EVar : string -> Exp
 | ECon : Z -> Exp
 | EGt : Exp -> Exp -> Exp
 | EPlus : Exp -> Exp -> Exp
with Stmt : Set :=
   SAssign : string -> Exp -> Stmt
 | Seq : Stmt -> Stmt -> Stmt
 | SIf : Exp -> Stmt -> Stmt -> Stmt
 | Skip : Stmt
 | SWhile : Exp -> Stmt -> Stmt
 .

Ltac step_solver := fail.
Ltac trans_solver := econstructor(equate_maps).
Ltac run :=
  first [eapply dtrans;[trans_solver|];try run
        |solve[intros;apply ddone;eauto]
        |eapply dstep;[step_solver|];instantiate;simpl;try run
        ].

(*
Inductive loop_spec : (Stmt * Map string Z) -> ((Stmt * Map string Z) -> Prop) -> Prop :=
  | loop_claim : forall store n rest, store ~= "n" |-> n ->
      loop_spec (Seq (SWhile (EGt (EVar "n") (ECon 0%Z)) (SAssign "n" (EPlus (EVar "n") (ECon (-1)%Z)))) rest, store)
     (fun c => fst c = rest /\ exists n, (n <= 0)%Z /\ snd c ~= "n" |-> n).
 *)

Inductive loop_spec {prog : Set} (wrap : Stmt -> prog -> prog)
    : (prog * Map string Z) -> ((prog * Map string Z) -> Prop) -> Prop :=
  | loop_claim : forall store n rest, store ~= "n" |-> n ->
      loop_spec wrap (wrap (SWhile (EGt (EVar "n") (ECon 0%Z)) (SAssign "n" (EPlus (EVar "n") (ECon (-1)%Z)))) rest, store)
     (fun c => fst c = rest /\ exists n, (n <= 0)%Z /\ snd c ~= "n" |-> n).

Inductive loop_spec_inf {prog : Set} (wrap : Stmt -> prog -> prog)
    : (prog * Map string Z) -> ((prog * Map string Z) -> Prop) -> Prop :=
  | loop_claim_inf : forall store n rest, store ~= "n" |-> n ->
      loop_spec_inf wrap (wrap (SWhile (EGt (ECon 1%Z) (ECon 0%Z)) (SAssign "n" (EPlus (EVar "n") (ECon (-1)%Z)))) rest, store)
     (fun c => False).

Ltac trans_solver ::=
     solve[refine (loop_claim _ _ _);equate_maps] ||
     solve[refine (loop_claim_inf _ _ _);equate_maps].

Ltac example_proof :=
  apply proved_sound;destruct 1;
  eapply sstep;[step_solver|];instantiate;simpl;
  run;
  match goal with
  |[|- context [(?n >? 0)%Z]] => destruct (Z.gtb_spec n 0)
  end;
  run.

(* Now three styles of semantics *)

(* First small step *)
Module small_step.

Inductive exp_step : (Exp * Map string Z) -> (Exp * Map string Z) -> Prop :=
  (* Ordered so we should use the earliest constructor to make progress *)
  | eval_var : forall v z rest store, store ~= v |-> z :* rest ->
      exp_step (EVar v, store) (ECon z, store)
  | eval_gt : forall z1 z2 store,
      exp_step (EGt (ECon z1) (ECon z2), store) (BCon (Z.gtb z1 z2), store)
  | eval_plus : forall z1 z2 store,
      exp_step (EPlus (ECon z1) (ECon z2), store) (ECon (Z.add z1 z2), store)
  | eval_gt_r : forall z e1 e2 store1 store2,
      exp_step (e1, store1) (e2, store2) ->
      exp_step (EGt (ECon z) e1, store1) (EGt (ECon z) e2, store2)
  | eval_gt_l : forall e1 e2 r store1 store2,
      exp_step (e1, store1) (e2, store2) ->
      exp_step (EGt e1 r, store1) (EGt e2 r, store2)
  | eval_plus_r : forall z e1 e2 store1 store2,
      exp_step (e1, store1) (e2, store2) ->
      exp_step (EPlus (ECon z) e1, store1) (EPlus (ECon z) e2, store2)
  | eval_plus_l : forall e1 e2 r store1 store2,
      exp_step (e1, store1) (e2, store2) ->
      exp_step (EPlus e1 r, store1) (EPlus e2 r, store2)
  .

Inductive step : (Stmt * Map string Z) -> (Stmt * Map string Z) -> Prop :=
  | exec_assign : forall v z z0 rest store, store ~= v |-> z0 :* rest ->
      step (SAssign v (ECon z), store) (Skip, (v |-> z :* rest))
  | exec_seq : forall s2 store,
      step (Seq Skip s2, store) (s2, store)
  | exec_if : forall b t e store,
      step (SIf (BCon b) t e, store) (if b then t else e, store)
  | exec_while : forall cond body store,
      step (SWhile cond body, store) (SIf cond (Seq body (SWhile cond body)) Skip, store)
  | exec_assign_1 : forall e1 e2 store1 store2 v,
      exp_step (e1, store1) (e2, store2) ->
      step (SAssign v e1, store1) (SAssign v e2, store2)
  | exec_seq_1 : forall s1 s2 store1 store2 r,
      step (s1, store1) (s2, store2) ->
      step (Seq s1 r, store1) (Seq s2 r, store1)
  | exec_if_1 : forall c1 store1 c2 store2 t e,
      exp_step (c1, store1) (c2, store2) ->
      step (SIf c1 t e, store1) (SIf c2 t e, store2)
 .

Create HintDb step_db discriminated.
Hint Extern 1 (_ ~= _) => equate_maps : step_db.
Hint Constructors step exp_step : step_db.

Ltac step_solver ::= solve[eauto 20 with step_db].

Lemma example : sound step (loop_spec Seq).
Proof. example_proof. Qed.

Lemma example_inf : sound step (loop_spec_inf Seq).
Proof. example_proof. Qed.

End small_step.

(* Now evaluation context *)
Module evaluation_contexts.

Inductive context : Set -> Set :=
   Top : context Stmt
 | EGt_left : Exp -> context Exp -> context Exp
 | EGt_right : Z -> context Exp -> context Exp
 | EPlus_left : Exp -> context Exp -> context Exp
 | EPlus_right : Z -> context Exp -> context Exp
 | SAssign_2 : string -> context Stmt -> context Exp
 | Seq_left : Stmt -> context Stmt -> context Stmt
 | SIf_1 : Stmt -> Stmt -> context Stmt -> context Exp
 .

Fixpoint plug {s : Set} (c : context s) : s -> Stmt :=
  match c with
  | Top => fun t => t
  | EGt_left r c => fun l => plug c (EGt l r)
  | EGt_right l c => fun r => plug c (EGt (ECon l) r)
  | EPlus_left r c => fun l => plug c (EPlus l r)
  | EPlus_right l c => fun r => plug c (EPlus (ECon l) r)
  | SAssign_2 v c => fun t => plug c (SAssign v t)
  | Seq_left r c => fun l => plug c (Seq l r)
  | SIf_1 t e c => fun v => plug c (SIf v t e)
 end.

Inductive step : (Stmt * Map string Z) -> (Stmt * Map string Z) -> Prop :=
  | eval_var : forall c v z rest store, store ~= v |-> z :* rest ->
      step (plug c (EVar v), store) (plug c (ECon z), store)
  | eval_gt : forall c z1 z2 store,
      step (plug c (EGt (ECon z1) (ECon z2)), store) (plug c (BCon (Z.gtb z1 z2)), store)
  | eval_plus : forall c z1 z2 store,
      step (plug c (EPlus (ECon z1) (ECon z2)), store) (plug c (ECon (Z.add z1 z2)), store)
  | exec_assign : forall c v z z0 rest store, store ~= v |-> z0 :* rest ->
      step (plug c (SAssign v (ECon z)), store) (plug c Skip, (v |-> z :* rest))
  | exec_seq : forall c s2 store,
      step (plug c (Seq Skip s2), store) (plug c s2, store)
  | exec_if : forall c b t e store,
      step (plug c (SIf (BCon b) t e), store) (plug c (if b then t else e), store)
  | exec_while : forall c cond body store,
      step (plug c (SWhile cond body), store) (plug c (SIf cond (Seq body (SWhile cond body)) Skip), store)
 .

Ltac split_ctx ctx t k :=
  match t with
  (* stop at redexes *)
  | (Seq Skip ?rest) => k ctx t
  | (SWhile _ _) => k ctx t
  | (SIf (BCon _) _ _) => k ctx t
  | (EGt (ECon _) (ECon _)) => k ctx t
  | (EVar _) => k ctx t
  | (SAssign _ (ECon _)) => k ctx t
  | (EPlus (ECon _) (ECon _)) => k ctx t
  (* else enter *)
  | (Seq ?l ?r) => let ctx' := constr:(Seq_left r ctx) in split_ctx ctx' l k
  | (SIf ?c ?t ?e) => let ctx' := constr:(SIf_1 t e ctx) in split_ctx ctx' c k
  | (EGt (ECon ?z) ?r) => let ctx' := constr:(EGt_right z ctx) in split_ctx ctx' r k
  | (EGt ?l ?r) => let ctx' := constr:(EGt_left r ctx) in split_ctx ctx' l k
  | (SAssign ?v ?e) => let ctx' := constr:(SAssign_2 v ctx) in split_ctx ctx' e k
  | (EPlus (ECon ?z) ?r) => let ctx' := constr:(EPlus_right z ctx) in split_ctx ctx' r k
  | (EPlus ?l ?r) => let ctx' := constr:(EPlus_left r ctx) in split_ctx ctx' l k
  end.
Ltac split_term t :=
  let ctx := constr:Top in split_ctx ctx t ltac:(fun c r => change t with (plug c r)).
Ltac step_solver ::=
  match goal with
  |[|- step (?t, ?store) ?P] => split_term t
  end;econstructor(equate_maps).

Lemma example : sound step (loop_spec Seq).
Proof. example_proof. Qed.

Lemma example_inf : sound step (loop_spec_inf Seq).
Proof. example_proof. Qed.

End evaluation_contexts.

(* Finally k style *)

Module k_style.

Require Import List.

Inductive kitem : Set :=
  | KExp : Exp -> kitem
  | KStmt : Stmt -> kitem
  | KFreezeZ : (Z -> kitem) -> kitem
  | KFreezeB : (bool -> kitem) -> kitem
  .

Inductive step : (list kitem * Map string Z) -> (list kitem * Map string Z) -> Prop :=
  | eval_var : forall c v z rest store, store ~= v |-> z :* rest ->
      step (KExp (EVar v) :: c, store) (KExp (ECon z) :: c, store)
  | eval_gt : forall c z1 z2 store,
      step (KExp (EGt (ECon z1) (ECon z2)) :: c, store) (KExp (BCon (Z.gtb z1 z2)) :: c, store)
  | eval_plus : forall c z1 z2 store,
      step (KExp (EPlus (ECon z1) (ECon z2)) :: c, store) (KExp (ECon (Z.add z1 z2)) :: c, store)
  | exec_assign : forall c v z z0 rest store, store ~= v |-> z0 :* rest ->
      step (KStmt (SAssign v (ECon z)) :: c, store) (KStmt Skip :: c, (v |-> z :* rest))
  | exec_skip : forall c store,
      step (KStmt Skip :: c, store) (c, store)
  | exec_seq : forall c s1 s2 store,
      step (KStmt (Seq s1 s2) :: c, store) (KStmt s1 :: KStmt s2 :: c, store)
  | exec_if : forall c b t e store,
      step (KStmt (SIf (BCon b) t e) :: c, store) (KStmt (if b then t else e) :: c, store)
  | exec_while : forall c cond body store,
      step (KStmt (SWhile cond body) :: c, store)
           (KStmt (SIf cond (Seq body (SWhile cond body)) Skip) :: c, store)

  | cool_z : forall c z f store,
      step (KExp (ECon z) :: KFreezeZ f :: c, store)
           (f z :: c, store)
  | cool_b : forall c b f store,
      step (KExp (BCon b) :: KFreezeB f :: c, store)
           (f b :: c, store)
  | heat_gt_l : forall c e1 e2 store,
      step (KExp (EGt e1 e2) :: c, store)
           (KExp e1 :: KFreezeZ (fun z => KExp (EGt (ECon z) e2)) :: c, store)
  | heat_gt_r : forall c z1 e2 store,
      step (KExp (EGt (ECon z1) e2) :: c, store)
           (KExp e2 :: KFreezeZ (fun z2 => KExp (EGt (ECon z1) (ECon z2))) :: c, store)
  | heat_plus_l : forall c e1 e2 store,
      step (KExp (EPlus e1 e2) :: c, store)
           (KExp e1 :: KFreezeZ (fun z => KExp (EPlus (ECon z) e2)) :: c, store)
  | heat_plus_r : forall c z1 e2 store,
      step (KExp (EPlus (ECon z1) e2) :: c, store)
           (KExp e2 :: KFreezeZ (fun z2 => KExp (EPlus (ECon z1) (ECon z2))) :: c, store)
  | heat_assign : forall c v e store,
      step (KStmt (SAssign v e) :: c, store)
           (KExp e :: KFreezeZ (fun z => KStmt (SAssign v (ECon z))) :: c, store)
  | heat_if : forall c b t e store,
      step (KStmt (SIf b t e) :: c, store)
           (KExp b :: KFreezeB (fun b => KStmt (SIf (BCon b) t e)) :: c, store)
 .

Ltac step_solver ::= econstructor(equate_maps).

Lemma example : sound step (loop_spec (fun s c => KStmt s :: c)).
Proof. example_proof. Qed.

Lemma example_inf : sound step (loop_spec_inf (fun s c => KStmt s :: c)).
Proof. example_proof. Qed.

End k_style.


(* We can reuse the.apa definition of periodic arrival sequence. *)
Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.arrival_sequence prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.implementation.apa.task prosa.classic.implementation.apa.job.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq div.

Module ConcreteArrivalSequence.

  Import Job ArrivalSequence ConcreteTask ConcreteJob SporadicTaskset TaskArrival.

  Section PeriodicArrivals.

    Context {num_cpus: nat}.
    Variable ts: concrete_taskset num_cpus.

    (* At any time t, we release Some job of tsk if t is a multiple of the period,
       otherwise we release None. *)
    Definition add_job (arr: time) (tsk: @concrete_task num_cpus) : option (@concrete_job _) :=
      if task_period tsk %| arr  then
        Some (Build_concrete_job (arr %/ task_period tsk) arr (task_cost tsk) (task_deadline tsk) tsk)
      else
        None.

    (* The arrival sequence at any time t is simply the partial map of add_job. *)
    Definition periodic_arrival_sequence (t: time) := pmap (add_job t) ts.

  End PeriodicArrivals.

  Section Proofs.

    Context {num_cpus: nat}.

    (* Let ts be any concrete task set with valid parameters. *)
    Variable ts: concrete_taskset num_cpus.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Regarding the periodic arrival sequence built from ts, we prove that...*)
    Let arr_seq := periodic_arrival_sequence ts.

    (* ... arrival times are consistent, ... *)
    Theorem periodic_arrivals_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.
    Proof.
      move => j t ARRj.
      rewrite /arrives_at mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ... every job comes from the task set, ... *)
    Theorem periodic_arrivals_all_jobs_from_taskset:
      forall j,
        arrives_in arr_seq j ->
        job_task j \in ts.
    Proof.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ..., jobs have valid parameters, ... *)
    Theorem periodic_arrivals_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.
    Proof.
      rename H_valid_task_parameters into PARAMS.
      unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj; move: ARRj => /mapP [tsk IN SOME].
      unfold add_job in SOME; desf.
      specialize (PARAMS tsk IN); des.
      unfold valid_sporadic_job, valid_realtime_job, job_cost_positive.
      by repeat split; try (by done); apply leqnn.
    Qed.

    (* ... job arrivals satisfy the sporadic task model, ... *)
    Theorem periodic_arrivals_are_sporadic:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Proof.
      move => j j' /eqP DIFF [arr ARR] [arr' ARR'] SAMEtsk LE.
      rewrite eqE /= /job_eqdef negb_and /= SAMEtsk eq_refl orbF in DIFF.
      rewrite 2!mem_pmap in ARR ARR'.
      move: ARR ARR' => /mapP [tsk_j INj SOMEj] /mapP [tsk_j' INj' SOMEj'].
      unfold add_job in SOMEj, SOMEj'; desf; simpl in *;
      move: Heq0 Heq => /dvdnP [k DIV] /dvdnP [k' DIV'].
      {
        rewrite DIV DIV' -mulSnr.
        rewrite leq_eqVlt in LE; move: LE => /orP [/eqP EQ | LESS].
        {
          exfalso; move: DIFF => /negP DIFF; apply DIFF.
          by subst; rewrite EQ !eq_refl.
        }
        subst; rewrite leq_mul2r; apply/orP; right.
        by rewrite ltn_mul2r in LESS; move: LESS => /andP [_ LT].
      }
    Qed.

    (* ... and the arrival sequence has no duplicate jobs. *)
    Theorem periodic_arrivals_is_a_set:
      arrival_sequence_is_a_set arr_seq.
    Proof.
      intros t.
      unfold arr_seq, periodic_arrival_sequence.
      apply (pmap_uniq) with (g := job_task); last by destruct ts.
      by unfold add_job, ocancel; intro tsk; desf.
    Qed.

  End Proofs.

End ConcreteArrivalSequence.


Require Import PathUtils.
Require Import Vector.
Require Import OTPSpace.
Require Import OTPImpl.

Definition IOTP {n} (bits : OTP n) : Type
  := OTP_rec Type (vec Bit n) (vec Bit n) (fun key => ua (@OTPequiv n key)) bits.

Definition IOTPPath {n} (key : vec Bit n) : (ap IOTP (@otpEncrypt n key)) ≡ (ua (@OTPequiv n key))
  := (OTP_rec_otpEncrypt Type (vec Bit n) (vec Bit n) (fun k => ua (@OTPequiv n k))) key.

Definition interp1 {n} {a b : OTP n} (p : a ≡ b) : (equiv (IOTP a) (IOTP b))
  := coe_biject (ap IOTP p).

Definition interp2 {n} {a b : OTP n} (p : a ≡ b) : IOTP a -> IOTP b
  := coe (ap IOTP p).

Theorem pf : (interp2 (otpEncrypt (cons oneb (cons zerob nil))) (cons oneb (cons oneb nil))) ≡ (cons zerob (cons oneb nil)).
Proof.
  assert (H1: (interp2 (otpEncrypt (cons oneb (cons zerob nil))) (cons oneb (cons oneb nil)))
              ≡ (coe (ap IOTP (otpEncrypt (cons oneb (cons zerob nil)))) (cons oneb (cons oneb nil)))).
  { exact idpath. }
  assert (H2: (coe (ap IOTP (otpEncrypt (cons oneb (cons zerob nil)))) (cons oneb (cons oneb nil)))
              ≡ (coe (ua (OTPequiv (cons oneb (cons zerob nil)))) (cons oneb (cons oneb nil)))).
  { exact (ap (fun x => (coe x (cons oneb (cons oneb nil)))) (IOTPPath (cons oneb (cons zerob nil)))). }
  assert (H3: (coe (ua (OTPequiv (cons oneb (cons zerob nil)))) (cons oneb (cons oneb nil)))
              ≡ (Σe_fst (coe_biject (ua (OTPequiv (cons oneb (cons zerob nil))))) (cons oneb (cons oneb nil)))).
  { exact idpath. }
  assert (H4: (Σe_fst (coe_biject (ua (OTPequiv (cons oneb (cons zerob nil))))) (cons oneb (cons oneb nil)))
              ≡ (Σe_fst (OTPequiv (cons oneb (cons zerob nil))) (cons oneb (cons oneb nil)))).
  { exact (ap (fun x => Σe_fst x (cons oneb (cons oneb nil))) (ua_cbj (OTPequiv (cons oneb (cons zerob nil))))). }
  assert (H5: (Σe_fst (OTPequiv (cons oneb (cons zerob nil))) (cons oneb (cons oneb nil)))
              ≡ (cons zerob (cons oneb nil))).
  { exact idpath. }
  rewrite -> H1.
  rewrite -> H2.
  rewrite -> H3; rewrite -> H4; rewrite -> H5.
  exact idpath.
Qed.


Require Import FP.CoreClasses.
Require Import FP.CoreData.
Require Import FP.DerivingEverything.
Require Import FP.Classes.

Import CoreClassesNotation.
Import CoreDataNotation.

Inductive identity A := Identity { run_identity : A }.
Arguments Identity {A} _.
Arguments run_identity {A} _.

Section identity_Bijection.
  Context {A:Type}.

  Global Instance IR_un_identity_eq
    : InjectionRespect (identity A) A run_identity eq eq.
  Proof.
    constructor ; [congruence|].
    unfold Proper,"<==" ; intros ; destruct x,y ; simpl in * ; congruence.
  Qed.

  Global Instance II_Identity_eq
    : InjectionInverse A (identity A) Identity run_identity eq.
  Proof.
    constructor ; auto.
  Qed.
End identity_Bijection.

Module identity_DE_Arg <: DE_Functor_Arg.
  Definition T := identity.
  Definition U := id:Type->Type.
  Definition to : forall {A}, T A -> U A := @run_identity.
  Definition from : forall {A}, U A -> T A := @Identity.
  Definition IR_to {A} : InjectionRespect (T A) (U A) to eq eq := _.
  Definition II_from {A} : InjectionInverse (U A) (T A) from to eq := _.
  Definition _DE_FunctorI : DE_FunctorI' U.
  Proof. econstructor ; econstructor ; eauto with typeclass_instances. Defined.
End identity_DE_Arg.
Module identity_DE := DE_Functor identity_DE_Arg.
Import identity_DE.

Section Proper.
  Context {A} `{! Eqv A }.
  Global Instance Identity_Proper : Proper eqv (@Identity A).
  Proof.
    unfold Proper.
    logical_eqv_intro.
    unfold eqv ; auto.
  Qed.
  Global Instance run_identity_Proper : Proper eqv (@run_identity A).
  Proof.
    unfold Proper.
    logical_eqv_intro.
    destruct x,y ; auto.
  Qed.
End Proper.

Section Monad.
  Definition identity_mret {A} : A -> identity A := Identity.
  Arguments identity_mret {A} _ /.
  Definition identity_mbind {A B} (aM:identity A) (k:A -> identity B) : identity B :=
    k $ run_identity aM.
  Arguments identity_mbind {A B} _ _ /.
  Global Instance identity_Monad : Monad identity :=
    { mret := @identity_mret
    ; mbind := @identity_mbind
    }.

  Global Instance identity_MonadWF : MonadWF identity.
  Proof.
    constructor ; intros ; unfold mret,mbind ; simpl ; logical_eqv.
    unfold Proper ; logical_eqv_intro ; simpl ; logical_eqv.
  Qed.
End Monad.

Section Comonad.
  Definition identity_coret {A} : identity A -> A := run_identity.
  Arguments identity_coret {A} _ /.
  Definition identity_cobind {A B} (aM:identity A) (k:identity A -> B) : identity B :=
    Identity $ k aM.
  Global Instance identity_Comonad : Comonad identity :=
    { coret := @identity_coret
    ; cobind := @identity_cobind
    }.
End Comonad.


Require Import Fiat.QueryStructure.Automation.MasterPlan.

Definition PHOTOS := "Photos".
Definition EVENTS := "Events".

Definition IMAGE_DATA := "ImageData".
Definition PERSONS := "Persons".
Definition EVENT_NAME := "EventName".
Definition DATE := "Date".

(* Represents image data by a list of byte characters *)
Definition DataT := list ascii.

Definition AlbumSchema :=
  Query Structure Schema
    [ relation PHOTOS has
               schema <IMAGE_DATA :: DataT,
                       PERSONS :: list string,
                       EVENT_NAME :: string>;
      relation EVENTS has
               schema <EVENT_NAME :: string,
                       DATE :: nat>
    ]
    enforcing [attribute EVENT_NAME for PHOTOS references EVENTS].

Definition AlbumSig : ADTSig :=
  ADTsignature {
      Constructor "Init"
           : rep,
      Method "AddPhoto"
           : rep * (AlbumSchema#PHOTOS)       -> rep * bool,
      Method "AddEvent"
           : rep * (AlbumSchema#EVENTS)       -> rep * bool,
      Method "PhotosByDateRange"
           : rep * nat * nat                -> rep * (list (AlbumSchema#PHOTOS)),
      Method "PhotosByPersons"
           : rep * (list string)                -> rep * (list (AlbumSchema#PHOTOS))
    }.

Require Import Fiat.QueryStructure.Specification.SearchTerms.ListInclusion.
Require Import Fiat.QueryStructure.Specification.SearchTerms.InRange.

Definition AlbumSpec : ADT AlbumSig :=
  Def ADT {
    rep := QueryStructure AlbumSchema,
    Def Constructor0 "Init" : rep := empty,,

    Def Method1 "AddPhoto" (r : rep) (photo : AlbumSchema#PHOTOS) : rep * bool :=
      Insert photo into r!PHOTOS,

    Def Method1 "AddEvent" (r : rep) (event : AlbumSchema#EVENTS) : rep * bool :=
      Insert event into r!EVENTS,

    Def Method2 "PhotosByDateRange" (r : rep) (startDate : nat) (endDate : nat) : rep * list (AlbumSchema#PHOTOS) :=
      photos <- For (photo in r!PHOTOS)
             (event in r!EVENTS)
             Where (event!EVENT_NAME = photo!EVENT_NAME)
             Where (startDate <= event!DATE <= endDate)
             Return photo;
    ret (r, photos),

    Def Method1 "PhotosByPersons" (r : rep) (persons : list string) : rep * list (AlbumSchema#PHOTOS) :=
      photos <- For (photo in r!PHOTOS)
             Where (IncludedIn persons photo!PERSONS)
             Return photo;
    ret (r, photos)
}%methDefParsing.

Definition SharpenedAlbum :
  FullySharpened AlbumSpec.
Proof.

  (* Uncomment this to see the mostly sharpened implementation *)
  (* partial_master_plan ltac:(CombineIndexTactics InclusionIndexTactics
          ltac:(CombineIndexTactics RangeIndexTactics EqIndexTactics)).*)
  master_plan
    ltac:(CombineIndexTactics InclusionIndexTactics
          ltac:(CombineIndexTactics RangeIndexTactics EqIndexTactics)).
Time Defined.
(*Mem: 1380MB *)

Time Definition AlbumImpl : ComputationalADT.cADT AlbumSig :=
  Eval simpl in (projT1 SharpenedAlbum).
(* Mem: 1028MB *)
Print AlbumImpl.


(** * Combi.Combi.multinomials : Multinomial coefficients *)
(******************************************************************************)
(*       Copyright (C) 2016 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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 the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Multinomial coefficients

******)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun ssrnat eqtype fintype choice seq.
From mathcomp Require Import tuple bigop path div finset.
From mathcomp Require Import perm fingroup action gproduct.
From Combi Require Import tools combclass sorted partition composition permuted.

Require Import cycles cycletype.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GroupScope.

Section PermOnG.

Variable T : finType.
Implicit Type (s t c : {perm T}).

Definition perm_ong S : {set {perm T}} := [set s | perm_on S s].
Lemma group_set_perm_ong S : group_set (perm_ong S).
Proof using.
  apply/group_setP; split => [| s t]; rewrite !inE;
    [exact: perm_on1 | exact: perm_onM].
Qed.
Canonical perm_ong_group S : {group {perm T}} := Group (group_set_perm_ong S).
Lemma card_perm_ong S : #|perm_ong S| = #|S|`!.
Proof using. by rewrite cardsE /= card_perm. Qed.

Lemma perm_ongE S : perm_ong S = 'C(~:S | 'P).
Proof using.
apply/setP => s; rewrite inE; apply/idP/astabP => [Hperm x | Hstab].
- by rewrite inE /= apermE => /out_perm; apply.
- apply/subsetP => x; rewrite unfold_in; apply contraR => H.
  by move/(_ x): Hstab; rewrite inE /= apermE => ->.
Qed.

Lemma restr_perm_commute C s : commute (restr_perm C s) s.
Proof using.
case: (boolP (s \in 'N(C | 'P))) =>
    [HC | /triv_restr_perm ->]; last exact: (commute_sym (commute1 _)).
apply/permP => x; case: (boolP (x \in C)) => Hx; rewrite !permM.
- by rewrite !restr_permE //; move: HC => /astabsP/(_ x)/= ->.
- have:= restr_perm_on C s => /out_perm Hout.
  rewrite (Hout _ Hx) {}Hout //.
  by move: Hx; apply contra; move: HC => /astabsP/(_ x)/= ->.
Qed.

End PermOnG.

Section ActOnTuple.

Variables (T : countType) (n : nat) (w : n.-tuple T).
Implicit Type (t : permuted w).

Let wp := (Permuted (perm_eq_refl w)).

Lemma perm_eq_act_tuple t (s : 'S_n) :
  perm_eq w [tuple tnth t (s^-1 i) | i < n].
Proof.
  apply: (perm_eq_trans (permutedP t)).
  by rewrite /= perm_eq_sym; apply/tuple_perm_eqP; exists s^-1.
Qed.
Definition permutedact t s := Permuted (perm_eq_act_tuple t s).

Local Notation "t # s" := (permutedact t s)
  (at level 40, left associativity, format "t # s").

Lemma permutedact_is_action : is_action [set: 'S_n] permutedact.
Proof.
split.
- move=> /= s t1 t2 Heq; apply val_inj; apply eq_from_tnth => i.
  move: Heq => /(congr1 (fun t => tnth t (s i))).
  by rewrite !tnth_mktuple permK.
- move=> t /= s1 s2 _ _; apply val_inj; apply eq_from_tnth => /= i.
  by rewrite !tnth_mktuple invMg permM.
Qed.
Canonical permuted_action := Action permutedact_is_action.
Local Notation pact := permuted_action.

Lemma permuted_action_trans :
  [transitive [set: 'S_n], on [set: permuted w] | pact].
Proof.
apply/imsetP; exists (Permuted (perm_eq_refl w)); first by [].
apply/setP => /= t; rewrite !inE; apply/esym/orbitP => /=.
have:= permutedP t => /tuple_perm_eqP [s /val_inj Hs].
exists s; first by rewrite inE.
apply val_inj => /=; apply eq_from_tnth => /= i.
by rewrite {1}Hs !tnth_mktuple permKV.
Qed.

From Combi Require Import Greene symgroup.

Lemma stab_tuple_prod :
  'C[wp | pact] =
  (\prod_(x : seq_sub w) perm_ong_group [set i : 'I_n | tnth w i == val x])%G.
Proof.
have Htriv : trivIset [set [set i : 'I_n | tnth w i == val x] | x : seq_sub w].
  apply/trivIsetP => /= X Y.
  move=> /imsetP [/= [x Hx _ /= ->{X}]].
  move=> /imsetP [/= [y Hy _ /= ->{Y}]] Hneq.
  rewrite -setI_eq0; apply/eqP/setP => /= i.
  rewrite !inE; apply (introF idP) => /andP [/eqP ->] /eqP Hxy.
  by move: Hneq; rewrite Hxy eq_refl.
apply/eqP; rewrite bigprodGE eqEsubset; apply/andP; split.
- apply/subsetP => /= s.
  move/astabP/(_ wp); rewrite inE eq_refl => /(_ isT) Ht.
  rewrite -(perm_decE (s := s) Htriv); first last.
  + apply/astabP => /= CS /imsetP [/= x _ ->{CS}].
    apply/astab1P; rewrite astab1_set.
    rewrite !inE /=; apply/subsetP => j.
    rewrite !inE => /eqP <-.
    by rewrite -{1}[w]/(val wp) -Ht tnth_mktuple permK.
  + apply/subsetP => /= i _; apply/bigcupP => /=.
    exists [set i0 | tnth w i0 == tnth w i]; last by rewrite inE.
    by apply/imsetP => /=; exists (SeqSub (mem_tnth i w)) => //=.
  apply group_prod => /= u /imsetP [/= X].
  move=> /imsetP [x Hx ->{X} ->{u}]; apply/mem_gen.
  apply/bigcupP; exists x => //.
  by rewrite inE; exact: restr_perm_on.
- rewrite gen_subG; apply/subsetP => /= s /bigcupP [/= x _] Hs.
  rewrite !inE /=; apply/subsetP => j; rewrite !inE => /eqP ->{j}.
  apply/eqP/val_inj/eq_from_tnth => /= i.
  rewrite tnth_mktuple.
  case: (boolP (tnth w i == val x)) => Hl0.
  + move: Hs; rewrite inE => /im_perm_on/setP/(_ i).
    rewrite !inE Hl0 => /imsetP [/= j].
    rewrite inE => /eqP H {1}->.
    by rewrite (eqP Hl0) permK.
  + move: Hs => /groupVr; rewrite inE /= => /out_perm -> //.
    by rewrite inE.
Qed.

Lemma stab_tuple_dprod :
  'C[wp | pact] =
  \big[dprod/1]_(x : seq_sub w) perm_ong [set i : 'I_n | tnth w i == val x].
Proof.
rewrite stab_tuple_prod; apply/esym/eqP/bigdprodYP => x /= _.
apply/subsetP => /= s; rewrite !inE negb_and negbK => Ht.
have {Ht} : s \in perm_ong [set i | tnth w i != val x].
  move: Ht; rewrite bigprodGE => /gen_prodgP [u [/= f Hf ->{s}]].
  apply group_prod => j _; move/(_ j): Hf => /bigcupP [k Hk].
  rewrite !inE /perm_on => /subset_trans; apply.
  by apply/subsetP => C; rewrite !inE => /eqP ->.
rewrite inE => on_neqi; apply/andP; split.
- case: (altP (s =P 1)) => //=; apply contra => on_eqi.
  apply/eqP/permP => /= i; rewrite perm1.
  case: (boolP (tnth w i == val x)) => [HC | /negbTE HC].
  + by rewrite (out_perm on_neqi) // !inE HC.
  + by rewrite (out_perm on_eqi) // !inE HC.
- apply/centP => /= u; move: on_neqi.
  rewrite inE !support_perm_on -[support u \subset _]setCS => on_neqi on_eqi.
  apply support_disjointC; rewrite disjoints_subset.
  apply: (subset_trans on_neqi); apply: (subset_trans _ on_eqi).
  by apply/subsetP => X; rewrite !inE.
Qed.

Lemma card_stab_ipcycles :
  #|'C[wp | pact]| = (\prod_(x : seq_sub w) (count_mem (val x) w)`!)%N.
Proof using.
rewrite -(bigdprod_card (esym stab_tuple_dprod)).
apply eq_bigr => [[i _]] _ /=.
rewrite card_perm_ong; congr (_)`!.
rewrite -map_tnth_enum.
rewrite cardE /enum_mem size_filter /= count_map count_filter.
by apply eq_count => X; rewrite !inE andbC.
Qed.

Lemma card_permuted_prodE :
  (#|[set: permuted w]| * \prod_(x : seq_sub w) (count_mem (val x) w)`!)%N = n`!.
Proof.
rewrite -card_Sn -card_stab_ipcycles.
rewrite -(atransPin (subxx _) permuted_action_trans (x := wp)) ?inE //.
by rewrite -cardsT /= -(card_orbit_in_stab pact wp (subxx _)) /= setTI.
Qed.

Lemma dvdn_card_permuted :
  (\prod_(x : seq_sub w) (count_mem (val x) w)`! %| n`!)%N.
Proof.
by apply/dvdnP; exists #|[set: permuted w]|; rewrite card_permuted_prodE.
Qed.

Lemma card_permuted_seq_subE :
  #|[set: permuted w]| = (n`! %/ \prod_(x : seq_sub w) (count_mem (val x) w)`!)%N.
Proof.
rewrite -card_permuted_prodE mulnK //.
by apply prodn_gt0 => i; apply: fact_gt0.
Qed.

Lemma prod_gact_count_memE (s : seq T) :
  uniq s -> all (mem s) w ->
  (\prod_(x : seq_sub w) (count_mem (val x) w)`! =
   \prod_(x <- s)        (count_mem      x  w)`!)%N.
Proof.
move=> Huniq /allP H.
rewrite [RHS](bigID (fun x => x \in w)) /= [X in (_ * X)%N]big1 ?muln1; first last.
  by move=> i /count_memPn ->.
rewrite /index_enum.
rewrite -[LHS](big_map (ssval (s := w)) xpredT (fun x : T => (count_mem x w)`!)).
rewrite -[RHS]big_filter; apply eq_big_perm; apply uniq_perm_eq.
- rewrite map_inj_uniq; last exact: val_inj.
  by rewrite -enumT; exact: enum_uniq.
- exact: filter_uniq.
- move=> x; rewrite mem_filter; apply/mapP/idP => [/= [y _ ->] | /andP [Hx Hxs]].
  + by case: y => y /= Hy; rewrite Hy /=; apply: H.
  + exists (SeqSub Hx) => //.
    by rewrite -enumT mem_enum.
Qed.

Lemma prod_gact_count_undupE :
  (\prod_(x : seq_sub w) (count_mem (val x) w)`! =
   \prod_(x <- undup w)  (count_mem      x  w)`!)%N.
Proof.
apply prod_gact_count_memE; first exact: undup_uniq.
rewrite (eq_in_all (a2 := predT)); first exact: all_predT.
by move=> i /=; rewrite mem_undup => ->.
Qed.

Lemma card_permutedE :
  #|[set: permuted w]| = (n`! %/ \prod_(x <- undup w) (count_mem x w)`!)%N.
Proof. by rewrite card_permuted_seq_subE prod_gact_count_undupE. Qed.

End ActOnTuple.


From CoreErlang Require Import ScopingLemmas Equalities Basics.
Import ListNotations.

Fixpoint match_pattern (p : Pat) (e : Val) : option (list Val) :=
match p with
| PVar => Some [e]
(* | PPid x => match e with
            | EPid p => if Nat.eqb p x then Some [] else None
            | _      => None
            end *)
| PNil => match e with
          | VNil => Some []
          | _    => None
          end
| PLit l0 => match e with
              | VLit l => if Lit_beq l l0 then Some [] else None
              | _      => None
              end
| PCons p1 p2 =>
  match e with
  | VCons v1 v2 =>
    match match_pattern p1 v1, match_pattern p2 v2 with
    | Some l1, Some l2 => Some (l1 ++ l2)
    | _      , _       => None
    end
  | _           => None
  end
| PTuple pl => match e with
              | VTuple vl =>
                        (fix match_and_bind_elements pl vl :=
                        match pl with
                        | [] =>
                            match vl with
                            | [] => Some []
                            | _ => None
                            end
                        | p::ps =>
                            match vl with
                            | v::vs =>
                                match (match_pattern p v) with
                                | Some vl1 =>
                                    match (match_and_bind_elements ps vs) with
                                    | Some vl2 => Some (vl1 ++ vl2)
                                    | _        => None
                                    end
                                | _ => None
                                end
                            | _ => None
                            end
                        end) pl vl
              | _ => None
              end
| PMap pl => match e with
              | VMap vl => (fix match_and_bind_elements pl vl :=
                          match pl with
                          | [] =>
                              match vl with
                              | []  => Some []
                              | _   => None
                              end
                          | (p1,p2)::ps =>
                              match vl with
                              | (v1,v2)::vs =>
                                  match (match_pattern p1 v1), (match_pattern p2 v2) with
                                  | Some vl1, Some vl1' =>
                                      match (match_and_bind_elements ps vs) with
                                      | Some vl2  => Some (vl1 ++ vl1' ++ vl2)
                                      | _         => None
                                      end
                                  | _, _ => None
                                  end
                              | _ => None
                              end
                          end) pl vl
              | _  => None
              end
end.

Fixpoint match_pattern_list (pl : list Pat) (vl : list Val) : option (list Val) :=
match pl,vl with
  | (p::ps), (v::vs) => match match_pattern p v with
                        | Some vs' => match match_pattern_list ps vs with
                                      | Some vs'' => Some (vs'++vs'')
                                      | None      => None
                                      end
                        | None => None
                        end
  | [], [] => Some []
  | _, _ => None
end.

Theorem match_pattern_scoped : forall p v l Γ,
  VAL Γ ⊢ v -> match_pattern p v = Some l
->
  Forall (fun v => VAL Γ ⊢ v) l.
Proof.
  induction p using Pat_ind2 with
  (Q := Forall (fun p => forall v l Γ,
                  VAL Γ ⊢ v -> match_pattern p v = Some l
                  -> Forall (fun v => VAL Γ ⊢ v) l))
  (R := Forall (fun '(p1, p2) => (forall v l Γ,
  VAL Γ ⊢ v -> match_pattern p1 v = Some l
  -> Forall (fun v => VAL Γ ⊢ v) l) /\
  (forall v l Γ,
  VAL Γ ⊢ v -> match_pattern p2 v = Some l
  -> Forall (fun v => VAL Γ ⊢ v) l))); try intros v l' Γ HΓ Hmatch; simpl in *; try now constructor.
  * destruct v; try congruence. now inversion Hmatch.
  * destruct v; try congruence.
    destruct Lit_beq in Hmatch; inversion Hmatch. auto.
  * inversion Hmatch. now constructor.
  * destruct v; try congruence.
    break_match_hyp; try congruence. break_match_hyp; try congruence. inversion Hmatch. inversion HΓ. subst. apply Forall_app. split.
    - eapply IHp1. exact H3. auto.
    - eapply IHp2. exact H4. auto.
  * destruct v; try congruence. inversion HΓ; subst. clear HΓ.
    apply indexed_to_forall in H1.
    generalize dependent l'; generalize dependent l; induction l0;
    intros l H l' Hmatch.
    - destruct l. 2: congruence. now inversion Hmatch.
    - inversion H1; subst; clear H1.
      destruct l. congruence.
      do 2 (break_match_hyp; try congruence).
      inversion H; subst; clear H.
      specialize (IHl0 H4 l H5 _ Heqo0). inversion Hmatch; subst. clear Hmatch.
      apply Forall_app; split; auto.
      clear IHl0 Heqo0. eapply H2 in Heqo; eauto.
  * destruct v; try congruence. inversion HΓ; subst. clear HΓ.
    generalize dependent l'; generalize dependent l; induction l0;
    intros l H l' Hmatch.
    - destruct l. 2: { destruct p; congruence. } now inversion Hmatch.
    - destruct l. congruence.
      do 5 (break_match_hyp; try congruence).
      inversion H; subst; clear H.
      inversion Hmatch; subst. clear Hmatch.
      destruct H4.
      apply Forall_app; split;[|apply Forall_app; split].
      3: {
        eapply IHl0.
        - intros. apply (H0 (S i)). simpl. lia.
        - intros. apply (H2 (S i)). simpl. lia.
        - apply H5.
        - assumption.
      }
      + eapply H. 2: eassumption. apply (H0 0). simpl. lia.
      + eapply H1. 2: eassumption. apply (H2 0). simpl. lia.
Qed.

(* Matching.v *)
Lemma match_pattern_list_sublist vs :
  forall lp vs', match_pattern_list lp vs = Some vs' ->
    incl vs' vs.
Proof.
  (* Does not hold! One pattern can contain any number of
     variables. *)
Abort.

(* Matching.v *)
Lemma match_pattern_length :
  forall p v l, match_pattern p v = Some l ->
    PatScope p = length l.
Proof.
  induction p using Pat_ind2 with
    (Q := Forall (fun p => forall v l, match_pattern p v = Some l ->
    PatScope p = length l))
    (R := Forall (fun '(p1, p2) => (forall v l, match_pattern p1 v = Some l ->
    PatScope p1 = length l) /\
    (forall v l, match_pattern p2 v = Some l ->
    PatScope p2 = length l))); simpl; intros.
  * destruct v; now inv H.
  * destruct v; inv H. break_match_hyp; now inv H1.
  * now inv H.
  * destruct_all_hyps. inv H. rewrite app_length. firstorder.
  * destruct_all_hyps. generalize dependent l0. revert l1.
    induction l; intros.
    - destruct_all_hyps. now inv H.
    - destruct_all_hyps. inv H. inv IHp. rewrite app_length.
      apply IHl in Heqo0; auto. cbn. erewrite Heqo0, H1.
      reflexivity. eassumption.
  * destruct_all_hyps. generalize dependent l0. revert l1.
    induction l; intros.
    - destruct_all_hyps. now inv H.
    - destruct_all_hyps. inv H. inv IHp. do 2 rewrite app_length.
      apply IHl in Heqo1; auto. cbn. erewrite Heqo1.
      destruct H1. erewrite H, H0. rewrite Nat.add_assoc. reflexivity.
      all: eassumption.
  * firstorder.
  * firstorder.
  * firstorder.
  * firstorder.
Qed.

(* Matching.v *)
Lemma match_pattern_list_length vs :
  forall lp vs', match_pattern_list lp vs = Some vs' ->
    PatListScope lp = length vs'.
Proof.
  induction vs; destruct lp; intros vs' H; inversion H.
  * reflexivity.
  * repeat break_match_hyp; try congruence.
    inv H1. apply IHvs in Heqo0. cbn. rewrite app_length.
    rewrite <- Heqo0. erewrite match_pattern_length. reflexivity.
    eassumption.
Qed.

Lemma match_pattern_scope Γ p :
  forall v l, match_pattern p v = Some l ->
    VAL Γ ⊢ v ->
    Forall (fun v => VAL Γ ⊢ v) l.
Proof.
  induction p using Pat_ind2 with
    (Q := Forall (fun p => forall v l, match_pattern p v = Some l ->
    VAL Γ ⊢ v ->
    Forall (fun v => VAL Γ ⊢ v) l))
    (R := Forall (fun '(p1, p2) => (forall v l, match_pattern p1 v = Some l ->
    VAL Γ ⊢ v ->
    Forall (fun v => VAL Γ ⊢ v) l) /\
    (forall v l, match_pattern p2 v = Some l ->
    VAL Γ ⊢ v ->
    Forall (fun v => VAL Γ ⊢ v) l))); simpl; intros.
    * destruct v; now inv H.
    * destruct v; inv H. break_match_hyp; now inv H2.
    * inv H. auto.
    * destruct_all_hyps. destruct_redex_scopes. inv H. apply Forall_app; split.
      - eapply IHp1; eassumption.
      - eapply IHp2; eassumption.
    * destruct_all_hyps. destruct_redex_scopes.
      apply indexed_to_forall in H3.
      generalize dependent l0. generalize dependent l1.
      induction l; intros.
      - destruct_all_hyps. now inv H.
      - destruct_all_hyps. inv H. inv IHp.
        destruct_foralls.
        apply IHl in Heqo0; auto. apply Forall_app; split; auto.
        eapply H1; eassumption.
    * destruct_all_hyps. destruct_redex_scopes.
      generalize dependent l0. generalize dependent l1.
      induction l; intros.
      - destruct_all_hyps. now inv H.
      - destruct_all_hyps. inv H. inv IHp.
        destruct_foralls.
        destruct H1 as [H1f H1s].
        apply IHl in Heqo1; auto.
        2: { intros. apply (H2 (S i)). simpl. lia. }
        2: { intros. apply (H4 (S i)). simpl. lia. }
        apply Forall_app; split; auto.
        2: apply Forall_app; split; auto.
        eapply H1f. exact Heqo. apply (H2 0 ltac:(slia)).
        eapply H1s. exact Heqo0. apply (H4 0 ltac:(slia)).
    * firstorder.
    * firstorder.
    * firstorder.
    * firstorder.
Qed.

Lemma match_pattern_list_scope Γ vs :
  forall lp vs', match_pattern_list lp vs = Some vs' ->
    Forall (fun v => VAL Γ ⊢ v) vs ->
    Forall (fun v => VAL Γ ⊢ v) vs'.
Proof.
  induction vs; destruct lp; intros vs' H Hall; inv H.
  * auto.
  * inv Hall. destruct_all_hyps. inv H1. apply IHvs in Heqo0; auto.
    apply Forall_app; split; auto.
    eapply match_pattern_scope; eassumption.
Qed.


(** * ∑-categories on morphisms - a category with the same objects, but a ∑ type for morphisms *)
Require Import HSet Types.Unit HoTT.Tactics Types.Forall Types.Sigma Basics.Trunc.
Require Import Category.Core Functor.Core Category.Sigma.Core.
Require Functor.Composition.Core Functor.Identity.
Require Import Functor.Paths.
Import Functor.Identity.FunctorIdentityNotations.
Import Functor.Composition.Core.FunctorCompositionCoreNotations.

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

Local Notation sigT_type := Coq.Init.Specif.sigT.
Local Notation pr1_type := Overture.pr1.

Local Open Scope morphism_scope.
Local Open Scope functor_scope.

Section sigT_mor.
  Variable A : PreCategory.
  Variable Pmor : forall s d, morphism A s d -> Type.

  Local Notation mor s d := (sigT_type (Pmor s d)).
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  (** ** Definition of [sigT_mor]-precategory *)
  Definition sigT_mor : PreCategory.
  Proof.
    refine (@Build_PreCategory
              (object A)
              (fun s d => mor s d)
              (fun x => identity x)
              (fun s d d' m1 m2 => compose m1 m2)
              _
              _
              _
              _);
    assumption.
  Defined.

  (** ** First projection functor *)
  Definition pr1_mor : Functor sigT_mor A
    := Build_Functor
         sigT_mor A
         idmap
         (fun _ _ => @pr1_type _ _)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Definition sigT_mor_as_sigT : PreCategory.
  Proof.
    refine (@sigT A (fun _ => Unit) (fun s d => @Pmor (pr1_type s) (pr1_type d)) _ (fun _ => Pidentity _) (fun _ _ _ _ _ m1 m2 => Pcompose m1 m2) _ _ _);
    intros; trivial.
  Defined.

  Definition sigT_functor_mor : Functor sigT_mor_as_sigT sigT_mor
    := Build_Functor
         sigT_mor_as_sigT sigT_mor
         (@pr1_type _ _)
         (fun _ _ => idmap)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Definition sigT_functor_mor_inv : Functor sigT_mor sigT_mor_as_sigT
    := Build_Functor
         sigT_mor sigT_mor_as_sigT
         (fun x => existT _ x tt)
         (fun _ _ => idmap)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Local Open Scope functor_scope.

  Lemma sigT_mor_eq `{Funext}
  : sigT_functor_mor o sigT_functor_mor_inv = 1
    /\ sigT_functor_mor_inv o sigT_functor_mor = 1.
  Proof.
    split; path_functor; simpl; trivial.
    refine (existT
              _
              (path_forall
                 _
                 _
                 (fun x
                  => match x as x return (x.1; tt) = x with
                       | (_; tt) => idpath
                     end))
              _).
    repeat (apply path_forall; intro).
    destruct_head @sigT_type.
    destruct_head Unit.
    rewrite !transport_forall_constant.
    transport_path_forall_hammer.
    reflexivity.
  Qed.

  Definition sigT_mor_compat : pr1_mor o sigT_functor_mor = pr1
    := idpath.
End sigT_mor.

Arguments pr1_mor {A Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity}.

Section sigT_mor_hProp.
  Variable A : PreCategory.
  Variable Pmor : forall s d, morphism A s d -> Type.

  Local Notation mor s d := (sigT_type (Pmor s d)).
  Context `(HPmor : forall s d m, IsHProp (Pmor s d m)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Local Ltac t ex_tac :=
    intros;
    simpl;
    apply path_sigma_uncurried;
    simpl;
    ex_tac;
    apply path_ishprop.

  Let P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).
  Proof.
    abstract t ltac:(exists (associativity _ _ _ _ _ _ _ _))
      using P_associativity_on_morphisms_subproof.
  Defined.

  Let P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.
  Proof.
    clear P_associativity.
    abstract t ltac:(exists (left_identity _ _ _ _))
      using P_left_identity_on_morphisms_subproof.
  Defined.

  Let P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.
  Proof.
    clear P_associativity P_left_identity.
    abstract t ltac:(exists (right_identity _ _ _ _))
      using P_right_identity_on_morphisms_subproof.
  Defined.

  (** ** Definition of [sig_mor]-precategory *)
  Definition sig_mor : PreCategory
    := Eval cbv delta [P_associativity P_left_identity P_right_identity]
      in @sigT_mor A Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity.

  (** ** First projection functor *)
  Definition proj1_sig_mor : Functor sig_mor A
    := pr1_mor.
End sigT_mor_hProp.

Arguments proj1_sig_mor {A Pmor HPmor Pidentity Pcompose}.