(**********************************************************************************

 Isos in two-sided displayed categories

 We define isomorphisms in two-sided displayed categories.

 Contents
 1. Isos in two-sided displayed categories
 2. Accessors for isos
 3. Derived laws
 4. Being an iso is a proposition
 5. The identity iso

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.

Local Open Scope cat.

(**
 1. Isos in two-sided displayed categories
 *)
Definition is_iso_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           (Hf : is_z_isomorphism f)
           (Hg : is_z_isomorphism g)
           (fg : xy₁ -->[ f ][ g ] xy₂)
  : UU
  := let f_z_iso : z_iso x₁ x₂ := f ,, Hf in
     let g_z_iso : z_iso y₁ y₂ := g ,, Hg in
     ∑ (gf : xy₂
             -->[ inv_from_z_iso f_z_iso ][ inv_from_z_iso g_z_iso ]
             xy₁),
     (fg ;;2 gf
      =
      transportb
        (λ z, _ -->[ z ][ _ ] _)
        (z_iso_inv_after_z_iso f_z_iso)
        (transportb
           (λ z, _ -->[ _ ][ z ] _)
           (z_iso_inv_after_z_iso g_z_iso)
           (id_two_disp _)))
     ×
     (gf ;;2 fg
      =
      transportb
        (λ z, _ -->[ z ][ _ ] _)
        (z_iso_after_z_iso_inv f_z_iso)
        (transportb
           (λ z, _ -->[ _ ][ z ] _)
           (z_iso_after_z_iso_inv g_z_iso)
           (id_two_disp _))).

Definition iso_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           (f : z_iso x₁ x₂)
           (g : z_iso y₁ y₂)
           (xy₁ : D x₁ y₁)
           (xy₂ : D x₂ y₂)
  : UU
  := ∑ (fg : xy₁ -->[ f ][ g ] xy₂),
     is_iso_twosided_disp (pr2 f) (pr2 g) fg.

(**
 2. Accessors for isos
 *)
Definition iso_inv_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           {Hf : is_z_isomorphism f}
           {Hg : is_z_isomorphism g}
           {fg : xy₁ -->[ f ][ g ] xy₂}
           (Hfg : is_iso_twosided_disp Hf Hg fg)
  : xy₂
    -->[ inv_from_z_iso (f ,, Hf) ][ inv_from_z_iso (g ,, Hg) ]
    xy₁
  := pr1 Hfg.

Definition inv_after_iso_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           {Hf : is_z_isomorphism f}
           {Hg : is_z_isomorphism g}
           {fg : xy₁ -->[ f ][ g ] xy₂}
           (Hfg : is_iso_twosided_disp Hf Hg fg)
  : fg ;;2 iso_inv_twosided_disp Hfg
    =
    transportb
      (λ z, _ -->[ z ][ _ ] _)
      (z_iso_inv_after_z_iso (f ,, Hf))
      (transportb
         (λ z, _ -->[ _ ][ z ] _)
         (z_iso_inv_after_z_iso (g ,, Hg))
         (id_two_disp _))
  := pr12 Hfg.

Definition iso_after_inv_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           {Hf : is_z_isomorphism f}
           {Hg : is_z_isomorphism g}
           {fg : xy₁ -->[ f ][ g ] xy₂}
           (Hfg : is_iso_twosided_disp Hf Hg fg)
  : iso_inv_twosided_disp Hfg ;;2 fg
    =
    transportb
      (λ z, _ -->[ z ][ _ ] _)
      (z_iso_after_z_iso_inv (f ,, Hf))
      (transportb
         (λ z, _ -->[ _ ][ z ] _)
         (z_iso_after_z_iso_inv (g ,, Hg))
         (id_two_disp _))
  := pr22 Hfg.

Definition make_iso_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {f : z_iso x₁ x₂}
           {g : z_iso y₁ y₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           (fg : xy₁ -->[ f ][ g ] xy₂)
           (Hfg : is_iso_twosided_disp (pr2 f) (pr2 g) fg)
  : iso_twosided_disp f g xy₁ xy₂
  := fg ,, Hfg.

(**
 3. Derived laws
 *)
Definition inv_after_iso_twosided_disp_alt
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           {Hf : is_z_isomorphism f}
           {Hg : is_z_isomorphism g}
           {fg : xy₁ -->[ f ][ g ] xy₂}
           (Hfg : is_iso_twosided_disp Hf Hg fg)
  : id_two_disp _
    =
    transportf
      (λ z, _ -->[ z ][ _ ] _)
      (z_iso_inv_after_z_iso (f ,, Hf))
      (transportf
         (λ z, _ -->[ _ ][ z ] _)
         (z_iso_inv_after_z_iso (g ,, Hg))
         (fg ;;2 iso_inv_twosided_disp Hfg)).
Proof.
  use (@transportf_transpose_right _ (λ z, _ -->[ z ][ _ ] _)).
  use (@transportf_transpose_right _ (λ z, _ -->[ _ ][ z ] _)).
  refine (!_).
  etrans.
  {
    apply inv_after_iso_twosided_disp.
  }
  refine (!_).
  apply twosided_swap_transport.
Qed.

Definition iso_after_inv_twosided_disp_alt
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           {Hf : is_z_isomorphism f}
           {Hg : is_z_isomorphism g}
           {fg : xy₁ -->[ f ][ g ] xy₂}
           (Hfg : is_iso_twosided_disp Hf Hg fg)
  : id_two_disp _
    =
    transportf
      (λ z, _ -->[ z ][ _ ] _)
      (z_iso_after_z_iso_inv (f ,, Hf))
      (transportf
         (λ z, _ -->[ _ ][ z ] _)
         (z_iso_after_z_iso_inv (g ,, Hg))
         (iso_inv_twosided_disp Hfg ;;2 fg)).
Proof.
  use (@transportf_transpose_right _ (λ z, _ -->[ z ][ _ ] _)).
  use (@transportf_transpose_right _ (λ z, _ -->[ _ ][ z ] _)).
  refine (!_).
  etrans.
  {
    apply iso_after_inv_twosided_disp.
  }
  refine (!_).
  apply twosided_swap_transport.
Qed.

(**
 4. Being an iso is a proposition
 *)
Definition isaprop_is_iso_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x₁ x₂ : C₁}
           {y₁ y₂ : C₂}
           {xy₁ : D x₁ y₁}
           {xy₂ : D x₂ y₂}
           {f : x₁ --> x₂}
           {g : y₁ --> y₂}
           (Hf : is_z_isomorphism f)
           (Hg : is_z_isomorphism g)
           (fg : xy₁ -->[ f ][ g ] xy₂)
  : isaprop (is_iso_twosided_disp Hf Hg fg).
Proof.
  use invproofirrelevance.
  intros φ₁ φ₂.
  use subtypePath.
  {
    intro.
    use isapropdirprod ; apply isaset_disp_mor.
  }
  etrans.
  {
    apply id_two_disp_right_alt.
  }
  refine (twosided_prod_transport _ _ _ @ _).
  etrans.
  {
    do 2 apply maponpaths.
    exact (inv_after_iso_twosided_disp_alt φ₂).
  }
  rewrite two_disp_post_whisker_left.
  rewrite two_disp_post_whisker_right.
  etrans.
  {
    apply maponpaths.
    apply twosided_prod_transport.
  }
  rewrite transport_f_f.
  rewrite assoc_two_disp.
  unfold transportb.
  etrans.
  {
    apply maponpaths.
    apply twosided_prod_transport.
  }
  rewrite transport_f_f.
  etrans.
  {
    apply maponpaths.
    apply maponpaths_2.
    apply (iso_after_inv_twosided_disp φ₁).
  }
  unfold transportb.
  rewrite two_disp_pre_whisker_left.
  rewrite two_disp_pre_whisker_right.
  etrans.
  {
    apply maponpaths.
    apply twosided_prod_transport.
  }
  rewrite transport_f_f.
  rewrite id_two_disp_left.
  unfold transportb.
  etrans.
  {
    apply maponpaths.
    apply twosided_prod_transport.
  }
  rewrite transport_f_f.
  unfold iso_inv_twosided_disp.
  use (@transportf_set
         _
         (λ z, xy₂ -->[ pr1 z ][ dirprod_pr2 z ] xy₁)
         (_ ,, _)).
  apply isasetdirprod ; apply homset_property.
Qed.

(**
 5. The identity iso
 *)
Definition id_iso_twosided_disp
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           {x : C₁}
           {y : C₂}
           (xy : D x y)
  : iso_twosided_disp (identity_z_iso x) (identity_z_iso y) xy xy.
Proof.
  use make_iso_twosided_disp.
  - apply id_two_disp.
  - simple refine (_ ,, _ ,, _).
    + apply id_two_disp.
    + apply id_two_disp_left.
    + apply id_two_disp_left.
Defined.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Axioms                                                                  *
**************************************************************************)

Set Implicit Arguments.

(** This file is used to extend Coq with standard axioms from classical,
    non-constructive higher-order logic. (Such axioms are provided by
    default in other theorem provers like Isabelle/HOL or HOL4.) *)

(** Three axioms taken are: functional extensionality, and propositional
    extensionality and indefinite description.

    All other comomn axioms are derivable, including: the excluded middle,
    the strong excluded middle, propositional degenerency, proof irrelevance,
    injectivity of equality on dependent pairs, predicate extensionality,
    definite description, and all the versions of the axiom of choice. *)

(* ********************************************************************** *)
(** * Functional extensionality *)

(** Two functions that yield equal results on equal arguments are equal. *)

Axiom func_ext_dep : forall (A:Type) (B:A->Type) (f g : forall x, B x),
  (forall x, f x = g x) -> f = g.

(* ********************************************************************** *)
(** * Propositional extensionality *)

(** Two propositions that are equivalent can be considered to be equal. *)

Axiom prop_ext : forall (P Q : Prop),
  (P <-> Q) -> P = Q.

(* ********************************************************************** *)
(** * Indefinite description *)

(** Proofs of existence can be reified from [Prop] to [Type]. The lemma
    below is a concise statement for [(exists x, P x) -> { x : A | P x }]. *)

Axiom indefinite_description : forall (A : Type) (P : A->Prop),
   ex P -> sig P.


(*
    A Tableau system for Ecumenical Propositional Logic.
    < coqtop v 8.13.1 >
 *)

Require Import Ascii.
Require Import Bool.
Require Import String.
Require Import List.
Require Import ZArith.
Require Import String.

Module Ecumenical.

  (* Type definitions *)

  Inductive logicalFormula : Set :=
  | Atom   : string -> logicalFormula
  | Neg  : logicalFormula -> logicalFormula
  | And  : (logicalFormula * logicalFormula) -> logicalFormula
  | iOr  : (logicalFormula * logicalFormula) -> logicalFormula
  | cOr  : (logicalFormula * logicalFormula) -> logicalFormula
  | iImp : (logicalFormula * logicalFormula) -> logicalFormula
  | cImp : (logicalFormula * logicalFormula) -> logicalFormula.

  Inductive node : Type :=
  | Empty  : node
  | Node : bool -> logicalFormula -> node.

  Inductive tree : Type :=
  | Root  : tree
  | Leaf  : tree
  | Unary : tree -> tree -> (bool * (Z*Z) * bool * node) -> tree -> tree
  | Alpha : tree -> tree ->
            ((bool * (Z*Z) * bool * node) * (bool * (Z*Z) * bool * node)) ->
            tree -> tree
  | Beta  : (tree * tree * (bool * (Z*Z) * bool * node) * tree) ->
            (tree * tree * (bool * (Z*Z) * bool * node) * tree) -> tree.

  (* A checkpoint is a snapshot of the current state *)
  Inductive checkpoint : Type :=
  | null
  | Checkpoint : Z -> tree -> checkpoint.

  (* A state holds a tableau tree and a list of checkpoints *)
  Inductive state : Type := State : tree -> list checkpoint -> bool -> state.

  Inductive pair : Type := ZZ : (Z * Z) -> pair.

  Inductive prettyTree : Type :=
  | Start : prettyTree
  | End : prettyTree
  | U : (pair * node) -> prettyTree -> prettyTree
  | A : ((pair * node) * (pair * node)) -> prettyTree -> prettyTree
  | B : ((pair * node) * prettyTree) -> ((pair  * node) * prettyTree) -> prettyTree.

  Inductive nodeXTree : Type := nt : Z -> node -> tree -> bool -> nodeXTree.

  Inductive treeXtree : Type := tt : (tree * tree) -> treeXtree.

  (* Notations *)

  Notation "[ A ]"   := (Atom A) (at level 50).
  Notation "~ A"     := (Neg A).
  Notation "A /\ B"  := (And (A, B)).
  Notation "A \/i B" := (iOr (A, B)) (at level 100).
  Notation "A \/c B" := (cOr (A, B)) (at level 100).
  Notation "A ->i B" := (iImp (A, B)) (at level 90).
  Notation "A ->c B" := (cImp (A, B)) (at level 90).

  Notation "@" := (A) (at level 10).
  Notation "#" := (B) (at level 10).
  Notation "$" := (U) (at level 10).

  Notation "p <~ q" := (ZZ (p, q)) (at level 10).

  (* General tools *)

  Fixpoint upto (k : nat) :=
    match k with
    | 0 => nil
    | S n => S n :: upto n
    end.

  Open Scope Z_scope.

  Fixpoint genTag (tree : tree) :=
    match tree with
    | Root => 0
    | Leaf => 1
    | Unary _ pT (_, (ptag, ctag), lt, l) nT  => ctag + genTag nT
    | Alpha _ pT ((_, (ptagl, ctagl), lt, l), (_, (ptagr, ctagr), rt, r)) nT  =>
        ctagl + ctagr + genTag nT
    | Beta (_, lpT, (_, (ptagl, ctagl), lt, l), lnT) (_, rpT, (_, (ptagr, ctagr), rt, r), rnT) =>
        ctagl + ctagr + genTag lnT + genTag rnT
    end.

  Fixpoint print tree :=
    match tree with
    | Root => Start
    | Leaf => End
    | Unary _ pT (_, (ptag, ctag), lt, l) nT =>
      $ ((ctag <~ ptag), l) (print nT)
    | Alpha _ pT ((_, (ptagl, ctagl), lt, l), (_, (ptagr, ctagr), rt, r)) nT =>
      @ (((ctagl <~ ptagl), l), ((ctagr <~ ptagr), r)) (print nT)
    | Beta (_, lpT, (_, (ptagl, ctagl), lt, l), lnT)
        (_, rpT, (_, (ptagr, ctagr), rt, r), rnT) =>
      # (((ctagl <~ ptagl), l), print lnT) (((ctagr <~ ptagr), r), print rnT)
    end.

  Fixpoint resetTree (tree : tree) :=
    match tree with
    | Root => Root
    | Leaf => Leaf
    | Unary hT pT ((ptag, ctag), t, r) nT => Unary hT pT ((ptag, ctag), true, r) (resetTree nT)
    | Alpha hT pT (((ptagl, ctagl), lt, l), ((ptagr, ctagr), rt, r)) nT => Alpha hT pT (((ptagl, ctagl), true, l), ((ptagr, ctagr), true, r)) (resetTree nT)
    | Beta (lhT, lpT, ((ptagl, ctagl), lt, l), lnT) (rhT, rpT, ((ptagr, ctagr), rt, r), rnT) =>
      Beta (lhT, lpT, ((ptagl, ctagl), true, l), (resetTree lnT)) (rhT, rpT, ((ptagr, ctagr), true, r), (resetTree rnT))
    end.

  Definition pop
    {X : Type}
    (l : list X) default :=
    match l with nil => default | h::tl => h end.

  Definition explode
    {X : Type}
    (l : list X) := match l with nil => nil | h::tl => tl end.

  Fixpoint makeInitialTree (prevTree : tree) (nodes : list node) :=
    match nodes with
    | nil => Leaf
    | h::tl =>
        Unary prevTree
          (Unary prevTree prevTree ((true, ((genTag prevTree), (genTag prevTree)), true, h)) Leaf)
          ((true, ((genTag prevTree), (genTag prevTree)), true, h))
          (makeInitialTree
             ((Unary prevTree prevTree ((true, ((genTag prevTree), (genTag prevTree)), true, h)) Leaf))
             tl)
    end.

  Definition getPt tree :=
    match tree with
      ( Root | Leaf | Beta _ _ ) => Root
    | Unary _ pT _ _ => pT
    | Alpha _ pT _ _ => pT
    end.

  Definition getHt tree :=
    match tree with
      Root => Root
    | Leaf => Leaf
    | Unary hT pT ((ptag, ctag), t, r) nT => hT
    | Alpha hT pT (((ptagl, ctagl), lt, l), ((ptagr, ctagr), rt, r)) nT => hT
    | Beta (lhT, lpT, ((ptagl, ctagl), lt, l), lnT) (rhT, rpT, ((ptagr, ctagr), rt, r), rnT) => lhT
    end.

  Definition getTag tree :=
    match tree with
      ( Root | Leaf | Alpha _ _ _ _ | Beta _ _ ) => 0
    | Unary hT pT (_, (ptag, ctag), t, r) nT => ctag
    end.

  Definition getNt tree :=
    match tree with
      ( Root | Leaf | Beta _ _ ) => Root
    | Unary _ _ _ nT => nT
    | Alpha _ _ _ nT => nT
    end.

  Definition isFalseIntImp (n : node) :=
    match n with
      Node t op =>
      match op with
        _ ->i _ => negb t
      | _ => false
      end
    | _ => false
    end.

  Open Scope Z_scope.

  (* Functions *)

  Definition getTreeFromNT nxt := match nxt with nt z n t b => t end.
  Definition getNodeFromNT nxt := match nxt with nt z n t b => n end.
  Definition getTagFromNT  nxt := match nxt with nt z n t b => z end.
  Definition getBoolFromNT nxt := match nxt with nt z n t b => b end.

  Definition getTreeLeft treePair  := match treePair with tt (l, r) => l end.
  Definition getTreeRight treePair := match treePair with tt (l, r) => r end.

  Definition getCheckpointListFromState state := match state with State t cl b => cl end.
  Definition getTreeFromState state := match state with State t cl b => t end.
  Definition getBoolFromState state := match state with State t cl b => b end.

  Definition getTreeFromCheckpoint checkpoint :=
    match checkpoint with null => Root | Checkpoint b t => t end.
  Definition getZFromCheckpoint checkpoint :=
    match checkpoint with null => 0 | Checkpoint b t => b end.

  Open Scope Z_scope.

  Fixpoint doWeHaveCheckpointAlready (cp : checkpoint) (lcp : list checkpoint) :=
    match lcp with
      nil => false
    | h::tl =>
      let cptag := (getZFromCheckpoint cp) in
      let thtag := (getZFromCheckpoint h) in
      if cptag =? thtag then true else doWeHaveCheckpointAlready cp tl
    end.

  Definition applyRule
    (prevTree : tree)
    (node : node)
    (ctree : tree)
    (tag : Z)
    (gen : Z)
    (selector : bool) :=
    let uP :=
        fun n1 next =>
          (Unary prevTree prevTree (true, (tag, next), true, n1) Leaf) in
    let aP :=
        fun n1 n2 =>
          (Unary prevTree prevTree (true, (tag, (genTag ctree) + gen), true, n1)
             (Unary Root Root (true, (tag, (genTag ctree + 1) + gen), true, n2) Leaf)) in
    let unaryRule :=
        fun an1 =>
          (Unary (uP an1 ((genTag ctree) + gen)) (uP an1 ((genTag ctree) + gen))
             (true, (tag, (genTag ctree) + gen), true, an1) Leaf) in
    let alphaRule :=
        fun an1 an2 =>
          (Alpha (aP an1 an2) (aP an1 an2) ((true, (tag, (genTag ctree) + gen), true, an1),
               (true, (tag, (genTag ctree + 1) + gen) , true, an2)) Leaf) in
    let betaRule :=
        fun bn1 bn2 =>
          (Beta ((uP bn1 ((genTag ctree) + gen)), (uP bn1 ((genTag ctree) + gen)),
               (true, (tag, (genTag ctree) + gen), true, bn1), Leaf)
             ((uP bn2 ((genTag ctree + 1) + gen)), (uP bn2 ((genTag ctree + 1) + gen)),
               (true, (tag, (genTag ctree + 1) + gen), true, bn2), Leaf)) in
    match node with
      Empty => Leaf
    | Node t op =>
      match op with
        Atom _ => Leaf
      | l /\ r =>
        let an1 := (Node true l) in
        let an2 := (Node true r) in
        let bn1 := (Node false l) in
        let bn2 := (Node false r) in
        if t then alphaRule an1 an2
        else betaRule bn1 bn2
      | l \/c r =>
        let an1 := (Node true (Neg l)) in
        let an2 := (Node true (Neg r)) in
        let bn1 := (Node false (Neg l)) in
        let bn2 := (Node false (Neg r)) in
        if t then betaRule bn1 bn2
        else alphaRule an1 an2
      | l ->c r =>
        let an1 := (Node true l) in
        let an2 := (Node true (Neg r)) in
        let bn1 := (Node false l) in
        let bn2 := (Node false (Neg r)) in
        if t then betaRule bn1 bn2
        else alphaRule an1 an2
      | l \/i r =>
        let an1 := (Node false l) in
        let an2 := (Node false r) in
        let bn1 := (Node true l) in
        let bn2 := (Node true r) in
        if t then betaRule bn1 bn2
        else if selector then unaryRule an1 else unaryRule an2
      | l ->i r =>
        let an1 := (Node true l) in
        let an2 := (Node false r) in
        let bn1 := (Node false l) in
        let bn2 := (Node true r) in
        if t then betaRule bn1 bn2
        else alphaRule an1 an2
      | ~ r =>
        let an1 := (Node false r) in
        let an2 := (Node true r) in
        if t then unaryRule an1
        else unaryRule an2
      end
    end.

  Definition specialAlpha (n : node) :=
    match n with
    | Empty => true
    | Node t op =>
        match op with
        | ~ r => negb t
        | l ->i r => negb t
        | _ => false
        end
    end.

  (** Essa função olha para a memória do estado para encontrar o próximo nó a ser expandido.
      Se for especial beta (false or_i), envia um sinal (true).
   **)
  Fixpoint findNodeToExpand (tree : tree) : nodeXTree :=
    match tree with
    | Unary hT pT (b, (ptag, ctag), t, r) nT =>
        if t then
          match r with
          | Empty =>  nt ctag r (Unary hT pT (b, (ptag, ctag), false, r) nT) false
          | Node tv op =>
              match op with
              | _ \/i _ => nt ctag r (Unary hT pT (b, (ptag, ctag), false, r) nT) (negb tv)
              | _ => nt ctag r (Unary pT pT (b, (ptag, ctag), false, r) nT) false
              end
          end
        else
          let next := (findNodeToExpand pT) in
          nt (getTagFromNT next)
            (getNodeFromNT next)
            (Unary hT nT (b, (ptag, ctag), false, r) (getTreeFromNT next))
            (getBoolFromNT next)
    | _ => nt 0 Empty Leaf false
    end.

  Close Scope string_scope.

  Fixpoint removeEveryFalseNode (t : tree) : tree :=
    match t with
    | Unary hT pT (b, (ptag, ctag), t, r) nT =>
        match r with
        | Empty => removeEveryFalseNode pT
        | Node bt op =>
            if bt then
              Unary hT (removeEveryFalseNode pT) (b, (ptag, ctag), t, r) nT
            else removeEveryFalseNode pT
        end
    | _ => Root
    end.

  Fixpoint findLeaf
    (ltree : tree)
    (iterator : tree)
    (dir : bool)
    (ctrl : bool) :=
    match iterator with
    | Root => State Root (null::nil) true
    | Leaf => State Leaf (null::nil) true
    | Unary hT pT (b, (ptag, ctag), t, r) nT =>
      match nT with
      | Root => State Root (null::nil) true
      | Leaf =>
          let prev := findNodeToExpand pT in
          let checkpoint := Unary hT pT (b, (ptag, ctag), false, r) nT in
          State
            (Unary ((getHt (getTreeFromNT prev)))
               ((getTreeFromNT prev))
               (b, (ptag, ctag), t, r)
               (applyRule
                  (if (specialAlpha (getNodeFromNT prev)) then removeEveryFalseNode (getTreeFromNT prev)
                   else (getTreeFromNT prev))
                  (getNodeFromNT prev)
                ltree
                (getTagFromNT prev)
                ctag
                ctrl))
          ((Checkpoint ctag checkpoint) :: nil)
          ((getBoolFromNT prev))
      | (Unary _ _ _ _ | Alpha _ _ _ _ | Beta _ _) =>
        let next := (findLeaf ltree nT dir ctrl) in
        State
          (Unary hT pT (b, (ptag, ctag), t, r)
             (getTreeFromState next))
          (( Checkpoint
               (getZFromCheckpoint
                  (pop (getCheckpointListFromState next) null))
               (Unary hT pT (b, (ptag, ctag), t, r)
                  (getTreeFromCheckpoint
                     (pop (getCheckpointListFromState next) null))) :: nil ))
          (getBoolFromState next)
      end
    | Alpha hT pT ((lb, (ptagl, ctagl), lt, l), (rb ,(ptagr, ctagr), rt, r)) nT =>
        match nT with
        | Root => State Root (null::nil) true
        | Leaf =>
            let prev := findNodeToExpand pT in
            let checkpoint := Alpha hT pT ((lb, (ptagl, ctagl), false, l),
                                  (rb, (ptagr, ctagr), false, r)) nT in
            State
              (Alpha
                 ((getHt (getTreeFromNT prev)))
                 ((getTreeFromNT prev))
                 ((lb, (ptagl, ctagl), lt, l), (rb, (ptagr, ctagr), rt, r))
                 (applyRule
                    (if (specialAlpha (getNodeFromNT prev)) then removeEveryFalseNode (getTreeFromNT prev)
                     else (getTreeFromNT prev))
                    (getNodeFromNT prev)
                    ltree
                    (getTagFromNT prev)
                    (ctagl + ctagr)
                    ctrl))
              ((Checkpoint ctagr checkpoint) :: nil)
              ((getBoolFromNT prev))
        | (Unary _ _ _ _ | Alpha _ _ _ _ | Beta _ _) =>
            let next := (findLeaf ltree nT dir ctrl) in
            State
              (Alpha
                 hT pT ((lb, (ptagl, ctagl), lt, l),
                   (rb, (ptagr, ctagr), rt, r)) (getTreeFromState next))
              ((Checkpoint (getZFromCheckpoint (pop (getCheckpointListFromState next) null))
                  (Alpha hT pT ((lb, (ptagl, ctagl), lt, l), (rb, (ptagr, ctagr), rt, r))
                     (getTreeFromCheckpoint
                        (pop (getCheckpointListFromState next) null))) :: nil ))
              (getBoolFromState next)
        end
    | Beta (lhT, lpT, (lb, (ptagl, ctagl), lt, l), lnT)
        (rhT, rpT, (rb, (ptagr, ctagr), rt, r), rnT) =>
        if dir then
          match lnT with
          | Root => State Root (null::nil) true
          | Leaf =>
              let prev := findNodeToExpand lpT in
              let checkpoint := Beta (lhT, lpT, (lb, (ptagl, ctagl), false, l), lnT)
                                  (rhT, rpT, (rb, (ptagr, ctagr), rt, r), rnT) in
              State
                (Beta
                   ((getHt (getTreeFromNT prev)),
                     (((getTreeFromNT prev))),
                     (lb, (ptagl, ctagl), lt, l),
                     (applyRule
                        (if (specialAlpha (getNodeFromNT prev)) then removeEveryFalseNode (getTreeFromNT prev)
                         else (getTreeFromNT prev))
                        (getNodeFromNT prev)
                        ltree
                        (getTagFromNT prev)
                        ctagl
                        ctrl))
                   (rhT, rpT, (rb, (ptagr, ctagr), rt, r), rnT))
                ((Checkpoint ctagl checkpoint) :: nil)
                ((getBoolFromNT prev))
          | (Unary _ _ _ _ | Alpha _ _ _ _ | Beta _ _) =>
              let lnext := (findLeaf ltree lnT dir ctrl) in
              let rnext := (findLeaf ltree rnT dir ctrl) in
              State
                (Beta (lhT, lpT, (lb, (ptagl, ctagl), lt, l), (getTreeFromState lnext))
                   (rhT, rpT, (rb, (ptagr, ctagr), rt, r), (getTreeFromState rnext)))
                ((Checkpoint
                    ((getZFromCheckpoint
                        (pop (getCheckpointListFromState lnext) null)))
                    (Beta
                       (lhT, lpT, (lb, (ptagl, ctagl), lt, l),
                         (getTreeFromCheckpoint
                            (pop (getCheckpointListFromState lnext) null)))
                       (rhT, rpT, (rb, (ptagr, ctagr), rt, r),
                         (getTreeFromCheckpoint
                            (pop (getCheckpointListFromState rnext) null)))) :: nil ))
                ((getBoolFromState lnext))
          end
        else
          match rnT with
          | Root => State Root (null::nil) true
          | Leaf =>
              let prev := findNodeToExpand rpT in
              let checkpoint := Beta (lhT, lpT, (lb, (ptagl, ctagl), lt, l), lnT)
                                  (rhT, rpT, (rb, (ptagr, ctagr), false, r), rnT) in
              State
                (Beta
                   (lhT, lpT, (lb, (ptagl, ctagl), lt, l), lnT)
                   ((getHt (getTreeFromNT prev)),
                     (((getTreeFromNT prev))),
                     (rb, (ptagr, ctagr), rt, r),
                     (applyRule
                        (if (specialAlpha (getNodeFromNT prev)) then removeEveryFalseNode (getTreeFromNT prev)
                         else (getTreeFromNT prev))
                        (getNodeFromNT prev)
                        ltree
                        (getTagFromNT prev)
                        ctagr
                        ctrl)))
                ((Checkpoint ctagr checkpoint) :: nil)
                ( (getBoolFromNT prev))
          | (Unary _ _ _ _ | Alpha _ _ _ _ | Beta _ _) =>
              let lnext := (findLeaf ltree lnT dir ctrl) in
              let rnext := (findLeaf ltree rnT dir ctrl) in
              State
                (Beta
                   (lhT, lpT, (lb, (ptagl, ctagl), lt, l), (getTreeFromState lnext))
                   (rhT, rpT, (rb, (ptagr, ctagr), rt, r), (getTreeFromState rnext)))
                ((Checkpoint
                    ((getZFromCheckpoint
                        (pop (getCheckpointListFromState rnext) null)))
                    (Beta
                       (lhT, lpT, (lb, (ptagl, ctagl), lt, l),
                         (getTreeFromCheckpoint
                            (pop (getCheckpointListFromState lnext) null)))
                       (rhT, rpT, (rb, (ptagr, ctagr), rt, r),
                         (getTreeFromCheckpoint
                            (pop (getCheckpointListFromState rnext) null)))) :: nil ))
                ((getBoolFromState rnext))
          end
    end.

  Definition tableau tree dir ctrl := findLeaf tree tree dir ctrl.

  (**
      makeTableau expande a arvore (up to l)
   **)

  Fixpoint makeTableau
    (l : list nat)
    (t : tree)
    (dir : bool)
    (checkpoints : list checkpoint)
    (ctrl : bool)
    : state :=
    match l with
    | nil => State t checkpoints ctrl
    | h::tl =>
        let newstate := (tableau t dir ctrl) in
        let newcp := pop (getCheckpointListFromState newstate) null in
        if (andb (negb (doWeHaveCheckpointAlready newcp checkpoints))
            (getBoolFromState newstate)) (** o sinal enviado por findNodeToExpand chega aqui **)
        then
          makeTableau
            tl
            (getTreeFromState newstate)
            (negb dir)
            (newcp :: checkpoints)
            ctrl
        else
          makeTableau
            tl
            (getTreeFromState newstate)
            (negb dir)
            checkpoints
            ctrl
    end.

  (** A função controller recebe uma lista de checkpoints e retorna uma lista de states.
      Um state é uma arvore de tableau + uma lista de checkpoints.
      Um checkpoint é uma imagem da arvore de tableau (uma foto do momento em que F-or_i
      está sendo expandido. **)
  Fixpoint controller
    (l : list nat)
    (checkpoints : list checkpoint) :=
    match checkpoints with
    | nil => nil
    | h::tl =>
        let next := (tableau (getTreeFromCheckpoint h) false false) in
        let nstate := (makeTableau l (getTreeFromState next) true nil true) in
        (nstate) :: (controller l tl)
    end.

  Fixpoint makeNewCheckpointList (l : list state) :=
    match l with
    | nil => nil
    | a::tl => (getCheckpointListFromState a) ++ (makeNewCheckpointList tl)
    end.

  Fixpoint getAllTreesFromListState (l : list state) :=
    match l with
    | nil => nil
    | a::tl => (getTreeFromState a) :: (getAllTreesFromListState tl)
    end.

  Fixpoint computeTableau (l : list nat) (lc : list checkpoint) :=
    let control := (controller l lc) in
    let nextlc := makeNewCheckpointList control in
    match l with
    | nil => nil
    | h::tl =>
        ((getAllTreesFromListState control)) ++ (computeTableau tl nextlc)
    end.

  Definition make (t : tree) :=
    let l := (upto 1000) in
    let newstate := (makeTableau l t true nil true) in
    let newcps := (getCheckpointListFromState newstate) in
    (getTreeFromState newstate)::(computeTableau l newcps).

  Fixpoint parse (t : tree) (i : list node) : list (list node) :=
    match t with
    | Root => nil
    | Leaf => i::nil
    | Unary _ pT (_, (ptag, ctag), lt, l) nT =>
        let n := l::i in
        parse nT n
    | Alpha _ pT ((_, (ptagl, ctagl), lt, l), (_, (ptagr, ctagr), rt, r)) nT =>
        let n := l::r::i in
        parse nT n
    | Beta (_, lpT, (_, (ptagl, ctagl), lt, l), lnT)
        (_, rpT, (_, (ptagr, ctagr), rt, r), rnT) =>
        let n1 := l::i in
        let n2 := r::i in
        parse lnT n1 ++ parse rnT n2
    end.

  Fixpoint length {X : Type} (n : list X) :=
    match n with
      nil => 0
    | a::tl => 1 + length tl
    end.

  (** Algoritmo: pega um, olha todos; loop **)
  Fixpoint lookAround (l : list node) (n : node) (s_alpha : bool) :=
    match l with
    | nil => false
    | h::tl =>
        let c_s_alpha := specialAlpha h in
        let isSAlpha := (orb c_s_alpha s_alpha) in
        match n with
        | Empty => lookAround tl n isSAlpha
        | Node t op =>
            match op with
            | Atom P =>
                match h with
                | Empty => lookAround tl n isSAlpha
                | Node t2 op2 =>
                    if (implb s_alpha t2) then
                      if xorb t t2 then
                        match op2 with
                        | Atom Q =>
                            if (eqb P Q) then true
                            else lookAround tl n isSAlpha
                        | _ => lookAround tl n isSAlpha
                        end
                      else lookAround tl n isSAlpha
                    else lookAround tl n isSAlpha
                end
            | _ => lookAround tl n isSAlpha
            end
        end
    end.

  Fixpoint branchCloses (l : list node) :=
    match l with
    | nil => false
    | h::tl =>
        match h with
        | Empty => branchCloses tl
        | Node t op =>
            match op with
            | (Atom P) => orb (lookAround l h false) (branchCloses tl)
            | _ => branchCloses tl
            end
        end
    end.

  (** Tree closes iff every branch closes **)
  Fixpoint treeCloses (l : list (list node)) :=
    match l with
    | nil => true
    | h::tl => andb (branchCloses h) (treeCloses tl)
    end.

  Fixpoint someTreeCloses (l : list (list (list node))) :=
    match l with
    | nil => false
    | h::tl => orb (treeCloses h) (someTreeCloses tl)
    end.

  Fixpoint parseTree (l : list tree) :=
    match l with
    | nil => nil
    | h::tl => (parse h nil) :: (parseTree tl)
    end.

  Definition closure (t : tree) : bool :=
    (someTreeCloses (parseTree (make t))).

  (* *)

  Open Scope string_scope.

  Definition P := "P".
  Definition Q := "Q".
  Definition R := "R".
  Definition S := "S".
  Definition T := "T".
  Definition X := "X".

  (** P /\ Q |- P **)
  Definition inf0 := makeInitialTree
                       Root (((Node true ([P] /\ [Q])))
                               ::((Node false ([P])))
                               ::nil).
  Compute closure inf0.

  (** A ordem de expansão importa. **)
  (* |/- P \/c ~P
     mas
     |- ~P \/c P
   *)
  Definition inf1 := makeInitialTree
                       Root (((Node false (~[P] \/c [P])))
                               ::nil).
  Compute closure inf1.

  (** P, P ->i Q |- Q **)
  Definition inf2 := makeInitialTree
                       Root (((Node true ([P] ->i [Q])))
                               ::((Node true ([P])))
                               ::((Node false ([Q])))
                               ::nil).
  Compute closure inf2.

  (** P, P ->c Q |/- ~~Q **)
  Definition inf3 := makeInitialTree
                       Root (((Node true ([P] ->c [Q])))
                               ::((Node true ([P])))
                               ::((Node false (~(~([Q])))))
                               ::nil).
  Compute parseTree (make inf3).

  (** |/- P \/i ~P **)
  Definition inf4 := makeInitialTree
                       Root (((Node false ([P] \/i ~[P])))
                               ::nil).
  Compute closure inf4.

  (** |/- ((P ->i Q) ->i P) ->i P **)
  Definition inf5 := makeInitialTree
                       Root (((Node false ((([P] ->i [Q]) ->i [P]) ->i [P])))
                               ::nil).
  Compute closure inf5.

  (* ** *)

(* @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ *)
(*                                                                 *)
(* Example 2 : From (PEREIRA; RODRIGUEZ, 2017), section 2, p. 6    *)
(*                                                                 *)
(* @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ *)

(* Initial trees *)

  Definition ex11 := makeInitialTree
                       Root ((Node false (([P] ->i [Q]) ->i ([P] ->c [Q])))::nil).
  Definition ex12 := makeInitialTree
                       Root ((Node false ( ( (([P] /\ [Q]) ->i (~(((~[P]) \/c (~[Q])))))
                                             /\ (((~(((~[P]) \/c (~[Q])))) ->i ([P] /\ [Q]))) ) ))::nil).
  Definition ex13 :=  makeInitialTree
                        Root ((Node false ( (([P] /\ [Q]) ->i (~([P] ->c (~[Q]))))
                                            /\ (((~([P] ->c (~[Q]))) ->i ([P] /\ [Q]))) ))::nil).
  Definition ex14 :=  makeInitialTree
                        Root ((Node false ( ((~((~[P]) /\ (~[Q]))) ->i ([P] \/c [Q]) )
                                            /\ (([P] \/c [Q]) ->i (~((~[P]) /\ (~[Q]))) ) ) )::nil).
  Definition ex15 :=  makeInitialTree
                        Root ((Node false ( ((~([P] /\ (~[Q]))) ->i ([P] ->c [Q]))
                                            /\ (([P] ->c [Q]) ->i (~([P] /\ (~[Q])))) ))::nil).

  Compute closure ex11.
  Compute closure ex12.
  Compute print (pop (make ex13) _).
  Compute closure ex14.
  Compute closure ex15.

  Close Scope Z_scope.

End Ecumenical.

Export Ecumenical.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia Bool.

From Undecidability.Shared.Libs.DLW
  Require Import utils list_bool pos vec subcode sss.

From Undecidability.StackMachines
  Require Export BSM.

Set Implicit Arguments.

Set Default Proof Using "Type".

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

(* ** Semantics results for BSM *)

Section Binary_Stack_Machine.

  Variable (n : nat).

  Notation "i // s -1> t" := (@bsm_sss n i s t).

  Ltac mydiscr :=
      match goal with H: ?x = _, G : ?x = _ |- _ => rewrite H in G; discriminate end.

  Ltac myinj :=
      match goal with H: ?x = _, G : ?x = _ |- _ => rewrite H in G; inversion G; subst; auto end.

  (* bsm_sss is a functional relation *)

  Fact bsm_sss_fun i s t1 t2 : i // s -1> t1 -> i // s -1> t2 -> t1 = t2.
  Proof. intros []; subst; inversion 1; subst; auto; try mydiscr; myinj. Qed.

  (* bsm_sss is an informativelly total relation *)

  Fact bsm_sss_total ii s : { t | ii // s -1> t }.
  Proof.
    destruct s as (i,v).
    destruct ii as [ x p q | x b ].
    + case_eq (v#>x); [ intros Hx | intros [] l Hx ].
      * exists (q,v); constructor; trivial.
      * exists (1+i,v[l/x]); constructor; trivial.
      * exists (p,v[l/x]); constructor; trivial.
    + exists (1+i,v[(b::v#>x)/x]); constructor.
  Qed.

  Fact bsm_sss_total' ii s : exists t, ii // s -1> t.
  Proof.
    destruct (bsm_sss_total ii s); firstorder.
  Qed.

  (* Hence computations can only stop at instructions which lie outside the code
     Stalling means no instruction can be executed anymore. It DOES NOT mean
     that the state cannot change anymore (this is a strictly lesser requirement).
  *)

  Fact bsm_sss_stall : forall P s, sss_step_stall (@bsm_sss n) P s -> out_code (fst s) P.
  Proof.
    intros (i,P) (q,v) H; unfold fst.
    red in H.
    destruct (in_out_code_dec q (i,P)) as [ H1 | ]; auto; exfalso.
    apply in_code_subcode in H1.
    destruct H1 as (ii & l & r & H1 & H2).
    simpl in H1.
    destruct (bsm_sss_total ii (q,v)) as (t & Ht).
    apply (H t); subst; apply in_sss_step; auto.
  Qed.

  Notation "P // s -[ k ]-> t" := (sss_steps (@bsm_sss n) P k s t).
  Notation "P // s ->> t" := (sss_compute (@bsm_sss n) P s t).

  Fact bsm_compute_POP_E P i x p q v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = nil
      -> P // (q,v) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Fact bsm_compute_POP_0 P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = Zero::ll
      -> P // (p,v[ll/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Fact bsm_compute_POP_1 P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = One::ll
      -> P // (1+i,v[ll/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Fact bsm_compute_POP_any P i x p q b ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = b::ll
      -> p = 1+i
      -> P // (1+i,v[ll/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    destruct b; intros H1 H2 H3.
    apply bsm_compute_POP_1 with p q; auto.
    apply bsm_compute_POP_0 with q; subst; auto.
  Qed.

  Fact bsm_compute_PUSH P i x b v st :
         (i,PUSH x b::nil) <sc P
      -> P // (1+i,v[(b::v#>x)/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Fact bsm_steps_POP_0_inv a P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = Zero::ll
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (p,v[ll/x]) -[b]-> st }.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (_ & ?) | (b & H4) ]; subst.
    destruct H3; auto.
    exists b.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    lia.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; try mydiscr; myinj.
  Qed.

  Fact bsm_steps_POP_1_inv a P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = One::ll
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (1+i,v[ll/x]) -[b]-> st }.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (_ & ?) | (b & H4) ]; subst.
    destruct H3; auto.
    exists b.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    lia.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; try mydiscr; myinj.
  Qed.

  Fact bsm_steps_POP_any_inv a P i x p q b ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = b::ll
      -> p = 1+i
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (1+i,v[ll/x]) -[b]-> st }.
  Proof.
    intros.
    destruct b.
    apply bsm_steps_POP_1_inv with p q; auto.
    apply bsm_steps_POP_0_inv with i q; subst; auto.
  Qed.

  Fact bsm_steps_POP_E_inv a P i x p q v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = nil
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (q,v) -[b]-> st }.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (b & H4) ]; subst; auto.
    destruct H3; auto.
    exists b.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    lia.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; try mydiscr; myinj.
  Qed.

  Fact bsm_steps_PUSH_inv k P i x b v st :
         (i,PUSH x b::nil) <sc P
      -> st <> (i,v)
      -> P // (i,v) -[k]-> st
      -> { a | a < k /\ P // (1+i,v[(b::v#>x)/x]) -[a]-> st }.
  Proof.
    intros H1 H2 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (a & H4) ]; subst; auto.
    destruct H2; auto.
    exists a.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    lia.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; auto.
  Qed.

End Binary_Stack_Machine.

Tactic Notation "bsm" "sss" "POP" "empty" "with" uconstr(a) constr(b) constr(c) :=
     apply bsm_compute_POP_E with (x := a) (p := b) (q := c); auto.

Tactic Notation "bsm" "sss" "POP" "zero" "with" uconstr(a) constr(b) constr(c) uconstr(d) :=
     apply bsm_compute_POP_0 with (x := a) (p := b) (q := c) (ll := d); auto.

Tactic Notation "bsm" "sss" "POP" "one" "with" uconstr(a) constr(b) constr(c) uconstr(d) :=
     apply bsm_compute_POP_1 with (x := a) (p := b) (q := c) (ll := d); auto.

Tactic Notation "bsm" "sss" "POP" "any" "with" uconstr(a) constr(c) constr(d) constr(e) constr(f) :=
     apply bsm_compute_POP_any with (x := a) (p := c) (q := d) (b := e) (ll := f); auto.

Tactic Notation "bsm" "sss" "PUSH" "with" uconstr(a) constr(q) :=
     apply bsm_compute_PUSH with (x := a) (b := q); auto.

Tactic Notation "bsm" "sss" "stop" := exists 0; apply sss_steps_0; auto.

Tactic Notation "bsm" "inv" "POP" "empty" "with" hyp(H) constr(a) constr(b) constr(c) :=
     apply bsm_steps_POP_E_inv with (x := a) (p := b) (q := c) in H; auto.

Tactic Notation "bsm" "inv" "POP" "zero" "with" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
     apply bsm_steps_POP_0_inv with (x := a) (p := b) (q := c) (ll := d) in H; auto.

Tactic Notation "bsm" "inv" "POP" "one" "with" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
     apply bsm_steps_POP_1_inv with (x := a) (p := b) (q := c) (ll := d) in H; auto.

Tactic Notation "bsm" "inv" "POP" "any" "with" hyp(H) constr(a) constr(c) constr(d) constr(e) constr(f) :=
     apply bsm_steps_POP_any_inv with (x := a) (p := c) (q := d) (b := e) (ll := f) in H; auto.

Tactic Notation "bsm" "inv" "PUSH" "with" hyp(H) constr(a) constr(c) :=
     apply bsm_steps_PUSH_inv with (x := a) (b := c) in H; auto.

#[export] Hint Immediate bsm_sss_fun : core.


Inductive oc : Set :=
| O : oc
| C : oc.

Section Maybes.
  Parameter t : Type.

Inductive MaybeO : oc -> Type -> Type :=
  JustO    : t -> MaybeO O t
| NothingO :      MaybeO C t.
End Maybes.

Inductive Block (n: oc -> oc -> Type) : oc -> oc -> Type :=
  BlockCO : n C O -> Block n O O          -> Block n C O
| BlockCC : n C O -> Block n O O -> n O C -> Block n C C
| BlockOC :          Block n O O -> n O C -> Block n O C
| BNil    : Block n O O
| BMiddle : n O O                      -> Block n O O
| BCat    : Block n O O -> Block n O O -> Block n O O
| BSnoc   : Block n O O -> n O O       -> Block n O O
| BCons   : n O O       -> Block n O O -> Block n O O.

Definition blockSplit {n:oc -> oc -> Type} (blk : Block n C C)
  : n C O * Block n O O * n O C :=
  match blk in Block _ e x return (match e, x with
                                   | C, C => n C%type O * Block n O O *n O C%type
                                   | _, _ => unit
                                   end) with
  | BlockCC _ f b t => (f, b, t)
  | _ => tt
  end.

Fixpoint go {n : oc -> oc -> Type} (blk : Block n O O) (acc : list (n O O))
  : list (n O O) :=
  match blk in Block _ e x return (match e, x with
                                   | O, O => list (n O O)
                                   | _, _ => unit
                                   end) with
  | BNil _       => acc
  | BMiddle _ n  => n :: acc
  | BCat _ b1 b2 => go b1 (go b2 acc)
  | BSnoc _ b1 n => go b1 (n :: acc)
  | BCons _ n b1 => n :: go b1 acc
  | _            => tt
  end.

Definition blockToList {n : oc -> oc -> Type} (blk: Block n O O) : list (n O O) :=
  go blk nil.


(* ** Reduction from H10 *)

Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.Undecidability.
From Undecidability.FOL Require Import Syntax.Facts Deduction.FullNDFacts Semantics.Tarski.FullFacts Semantics.Tarski.FullSoundness.
Require Import Undecidability.FOL.Arithmetics.Problems.
From Undecidability.FOL.Arithmetics Require Import TarskiFacts DeductionFacts NatModel.
From Undecidability.H10 Require Import H10p.
Require Import List Lia.

Set Default Proof Using "Type".

Fixpoint embed_poly p : term :=
    match p with
    | dp_nat_pfree n => num n
    | dp_var_pfree k => $k
    | dp_comp_pfree do_add_pfree a b => (embed_poly a) ⊕ (embed_poly b)
    | dp_comp_pfree do_mul_pfree a b => (embed_poly a) ⊗ (embed_poly b)
    end.

(* We translate h10 problems to formulas in PA *)
Definition embed_problem (E : H10p_PROBLEM) : form :=
  let (a, b) := E in embed_poly a == embed_poly b.

Definition H10p_sem E sigma := dp_eval_pfree sigma (fst E) = dp_eval_pfree sigma (snd E).

Definition poly_bound p := proj1_sig (find_bounded_t (embed_poly p)).
Definition problem_bound (E : H10p_PROBLEM) :=
  let (a, b) := E in proj1_sig (find_bounded (embed_poly a == embed_poly b) ).

Definition embed E := exist_times (problem_bound E) (embed_problem E).

Lemma embed_is_closed E : bounded 0 (embed E).
Proof.
  unfold embed. rewrite exists_close_form.
  unfold problem_bound. destruct E as [a b]; cbn.
  apply (proj2_sig (find_bounded _)).
Qed.

Fact numeral_subst_invariance n rho : subst_term rho (num n) = num n.
Proof.
  induction n.
  - reflexivity.
  - cbn. now rewrite IHn.
Qed.

Lemma prv_poly {p : peirce} sigma q Gamma :
  incl FAeq Gamma -> Gamma ⊢ ( (embed_poly q)`[sigma >> num] == num (dp_eval_pfree sigma q) ).
Proof.
  intros H.
  induction q; cbn.
  - change ((num n)`[sigma >> num]) with (subst_term (sigma >> num) (num n)).
    rewrite numeral_subst_invariance.
    now apply reflexivity.
  - now apply reflexivity.
  - destruct d; cbn.
    + eapply transitivity. assumption.
      apply (eq_add H IHq1 IHq2).
      now apply num_add_homomorphism.
    + eapply transitivity. assumption.
      apply (eq_mult H IHq1 IHq2).
      now apply num_mult_homomorphism.
Qed.

Lemma problem_to_prv {p : peirce} :
  forall E sigma, H10p_sem E sigma -> FAeq ⊢ (embed_problem E)[sigma >> num].
Proof.
  intros [a b] sigma HE. cbn -[FAeq].
  eapply transitivity; firstorder.
  apply prv_poly; firstorder.
  apply symmetry; firstorder.
  unfold H10p_sem in *. cbn in HE. rewrite HE.
  apply prv_poly; firstorder.
Qed.

Theorem H10p_to_FA_prv' {p : peirce} E :
  H10p E -> FAeq ⊢ embed E.
Proof.
  intros [sigma HE].
  eapply subst_exist_prv.
  apply problem_to_prv, HE.
  rewrite <-exists_close_form; apply embed_is_closed.
Qed.

Section FA_ext_Model.

  Context {D : Type}.
  Context {I : interp D}.

  Hypothesis ext_model : extensional I.
  Hypothesis FA_model : forall ax rho, In ax FA -> rho ⊨ ax.

  Notation "'iO'" := (i_func (f:=Zero) (Vector.nil D)) (at level 2) : PA_Notation.

  Fact eval_poly sigma p : eval (sigma >> iμ) (embed_poly p) = iμ (dp_eval_pfree sigma p).
    Proof using ext_model FA_model.
      induction p; cbn.
      - now rewrite eval_num.
      - reflexivity.
      - destruct d; cbn.
        + now rewrite IHp1, IHp2, add_hom.
        + now rewrite IHp1, IHp2, mult_hom.
    Qed.

    Lemma problem_to_ext_model : forall E sigma, H10p_sem E sigma -> (sigma >> iμ) ⊨ embed_problem E.
    Proof using ext_model FA_model.
      intros [a b] sigma Hs. cbn -[sat].
      unfold H10p_sem in *. cbn -[FA] in *.
      apply ext_model. rewrite !eval_poly. congruence.
    Qed.

    Theorem H10p_to_FA_ext_model' E rho : H10p E -> rho ⊨ embed E.
    Proof using ext_model FA_model.
      intros [sigma HE].
      eapply subst_exist_sat.
      apply problem_to_ext_model.
      - apply HE.
      - rewrite <-exists_close_form; apply embed_is_closed.
    Qed.

End FA_ext_Model.

Section FA_Model.

  (* Model of FA with equality. *)

  Context {D : Type}.
  Context {I : interp D}.

  Hypothesis FA_model : forall rho ax, In ax FAeq -> rho ⊨ ax.

  Notation "'iO'" := (i_func (f:=Zero) (Vector.nil D)) (at level 2) : PA_Notation.

  Lemma problem_to_model E sigma : H10p_sem E sigma -> (sigma >> iμ) ⊨ embed_problem E.
  Proof using FA_model.
    intros HE%(problem_to_prv (p:=intu))%soundness.
    specialize (HE D I).
    setoid_rewrite sat_comp in HE.
    eapply sat_ext. 2: apply HE.
    intros x. unfold ">>". now rewrite eval_num.
    intros. instantiate (1 := (fun _ => iO)).
    now apply FA_model.
  Qed.

  Definition standard :=
    extensional I /\ exists f : D -> nat, (forall d, iμ (f d) = d) /\ (forall n, f (iμ n) = n).

  Fact standard_embed_poly rho p f :
    extensional I -> (forall d, iμ (f d) = d) -> eval rho (embed_poly p) = iμ (dp_eval_pfree (rho >> f) p).
  Proof using FA_model.
    intros HI Hf. induction p; try destruct d; cbn.
    - apply eval_num.
    - unfold funcomp. now rewrite Hf.
    - rewrite IHp1, IHp2. rewrite add_hom; trivial. firstorder.
    - rewrite IHp1, IHp2. rewrite mult_hom; trivial. firstorder.
  Qed.

  Lemma standard_embed_problem' E rho f :
    extensional I -> (forall d, iμ (f d) = d) -> (forall n, f (iμ n) = n) -> rho ⊨ embed_problem E -> H10p_sem E (rho >> f).
  Proof using FA_model.
    intros HI Hf1 Hf2 H. destruct E as [p q]. apply HI in H.
    unfold H10p_sem. cbn. rewrite <- Hf2 at 1. setoid_rewrite <- Hf2 at 3.
    f_equal. now rewrite <- !standard_embed_poly.
  Qed.

  Lemma standard_embed_problem E :
    standard -> (exists rho, rho ⊨ embed_problem E) -> H10p E.
  Proof using FA_model.
    intros (HI & f & Hf1 & Hf2) [rho Hr]. exists (rho >> f). now apply standard_embed_problem'.
  Qed.

  Lemma standard_embed E rho :
    standard -> rho ⊨ (embed E) -> H10p E.
  Proof using FA_model.
    intros HS H. apply standard_embed_problem; trivial. eapply subst_exist_sat2, H.
  Qed.

End FA_Model.

Arguments standard _ _ : clear implicits.

Lemma nat_standard :
  standard nat interp_nat.
Proof.
  split; try reflexivity. exists (fun n => n).
  setoid_rewrite <- (eval_num _ (fun n => n)).
  setoid_rewrite nat_eval_num.
  split; reflexivity.
Qed.

Fact nat_eval_poly (sigma : env nat) p :
  @eval _ _ _ interp_nat sigma (embed_poly p) = dp_eval_pfree sigma p.
Proof.
  induction p; cbn.
  - now rewrite nat_eval_num.
  - reflexivity.
  - destruct d; cbn.
    + now rewrite IHp1, IHp2.
    + now rewrite IHp1, IHp2.
Qed.

Lemma nat_H10 E :
  (forall rho, sat interp_nat rho (embed E)) -> H10p E.
Proof.
  destruct E as [a b]. unfold embed in *.
  intros H. specialize (H (fun _ => 0)).
  apply subst_exist_sat2 in H as [sigma H].
  exists sigma. unfold H10p.H10p_sem. cbn.
  rewrite <- !nat_eval_poly. apply H.
Qed.

Lemma nat_sat :
  forall E rho, sat interp_nat rho (embed_problem E) <-> H10p_sem E rho.
Proof.
  intros E rho. split.
  - destruct E as [a b]. unfold H10p_sem. cbn.
    now rewrite !nat_eval_poly.
  - intros. eapply (@sat_ext _ _ _ _ _ (rho >> @iμ nat interp_nat)).
    intros x. change ((rho >> iμ) x) with (@iμ nat interp_nat (rho x)).
    induction (rho x). reflexivity. cbn. now rewrite IHn.
    eapply problem_to_model.
    apply nat_is_FA_model.
    assumption.
Qed.

Lemma nat_sat' E :
  (exists sigma, sat interp_nat sigma (embed_problem E)) <-> H10p E.
Proof.
  split; intros [sigma ]; exists sigma; now apply nat_sat.
Qed.

Theorem H10p_to_FA_ext_sat E :
  H10p E <-> ext_entailment_PA (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho Hext H.
    eapply subst_exist_sat.
    apply problem_to_ext_model.
    + apply Hext.
    + intros. apply H. now constructor.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id nat_extensional).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
    apply nat_is_PA_model.
Qed.

Theorem H10p_to_FA_sat E :
  H10p E <-> valid_ctx FAeq (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho H.
    eapply subst_exist_sat.
    apply problem_to_model.
    + intros ρ' ax Hax. eapply sat_closed.
      2: now apply H.
      repeat (destruct Hax as [<- | Hax]; cbn; repeat solve_bounds; auto).
      inversion Hax.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id (nat_is_FA_model id)).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
Qed.

Theorem H10p_to_Q_sat E :
  H10p E <-> valid_ctx Qeq (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho H.
    eapply subst_exist_sat.
    apply problem_to_model.
    + intros ρ' ax Hax. eapply sat_closed.
      2: apply H.
      repeat (destruct Hax as [<- | Hax]; cbn; repeat solve_bounds; auto).
      1: inversion Hax.
      firstorder.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id (nat_is_Q_model id)).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
Qed.

Theorem H10p_to_PA_sat E :
  H10p E <-> forall D (I : interp D) rho, (forall psi rho, PAeq psi -> rho ⊨ psi) -> rho ⊨ (embed E).
Proof.
  split.
  - intros [sigma HE].
    intros D I rho H.
    eapply subst_exist_sat.
    apply problem_to_model.
    + intros ρ' ax Hax. apply sat_closed with rho.
      repeat (destruct Hax as [<- | Hax]; cbn; repeat solve_bounds; auto).
      1:inversion Hax.
      apply H. now constructor.
    + apply HE.
    + rewrite <-exists_close_form; apply embed_is_closed.
  - intros H.
    specialize (H nat interp_nat id nat_is_PAeq_model).
    unfold embed in *. apply subst_exist_sat2 in H.
    now apply nat_sat'.
Qed.

Theorem H10p_to_FA_prv E :
  H10p E <-> FAeq ⊢I embed E.
Proof.
  split.
  - intros [sigma HE].
    eapply subst_exist_prv.
    apply problem_to_prv,  HE.
    rewrite <-exists_close_form; apply embed_is_closed.
  - intros H%soundness.
    now apply H10p_to_FA_sat.
Qed.

Theorem H10p_to_Q_prv E :
  H10p E <-> Qeq ⊢I embed E.
Proof.
  split.
  - intros.
    apply Weak with FAeq.
    now apply H10p_to_FA_prv.
    firstorder.
  - intros H%soundness.
    now apply H10p_to_Q_sat.
Qed.

Theorem H10p_to_PA_prv E :
  H10p E <-> PAeq ⊢TI embed E.
Proof.
  split.
  - intros [sigma HE].
    exists FAeq. split. intros. now constructor.
    apply H10p_to_FA_prv.
    now exists sigma.
  - intros H. apply nat_sat'.
    eapply subst_exist_sat2.
    eapply (tsoundness H (rho:=id)).
    intros. now apply nat_is_PAeq_model.
Qed.

(* ** Reduction for the axiomatisation PA assuming extensionality of models. *)

Theorem H10_to_ext_entailment_PA :
  H10p ⪯ ext_entailment_PA.
Proof.
  exists embed. intros E. apply H10p_to_FA_ext_sat.
Qed.

(* ** Reductions for the axiomatisations FAeq, Qeq and PAeq, which include the axioms for equatlity. *)

Theorem H10_to_entailment_FA :
  H10p ⪯ entailment_FA.
Proof.
  exists embed; intros E. apply H10p_to_FA_sat.
Qed.

Corollary H10_to_entailment_Q :
  H10p ⪯ entailment_Q.
Proof.
  exists embed; intros E. apply H10p_to_Q_sat.
Qed.

Corollary H10_to_entailment_PA :
  H10p ⪯ entailment_PA.
Proof.
  exists embed; intros E. apply H10p_to_PA_sat.
Qed.

Theorem H10_to_deduction_FA :
  H10p ⪯ deduction_FA.
Proof.
  exists embed; intros E. apply H10p_to_FA_prv.
Qed.

Theorem H10_to_deduction_Q :
  H10p ⪯ deduction_Q.
Proof.
  exists embed; intros E. apply H10p_to_Q_prv.
Qed.

Corollary H10_to_deduction_PA :
  H10p ⪯ deduction_PA.
Proof.
  exists embed; intros E. apply H10p_to_PA_prv.
Qed.


Require Import Coq.NArith.NArith
  Verigen.Domainpar
  Verigen.Functions
  Znumtheory Lia
  Zdiv Zpow_facts.
From Coq Require Import String Ascii.
Open Scope N_scope.

(* 1024 bit prime *)

Module Pins <: Prime.
Definition p : N :=
0xff600483db6abfc5b45eab78594b3533d550d9f1bf2a992a7a8daa6dc34f8045ad4e6e0c429d334eeeaaefd7e23d4810be00e4cc1492cba325ba81ff2d5a5b305a8d17eb3bf4a06a349d392e00d329744a5179380344e82a18c47933438f891e22aeef812d69c8f75e326cb70ea000c3f776dfdbd604638c2ef717fc26d02e17.
Definition q : N := 0xe21e04f911d1ed7991008ecaab3bf775984309c3.
Definition k : N := Eval vm_compute in N.div (p - 1) q.
Definition domain_parameter_seed : N :=  0x180180ee2f0ae4a7b3a1ab1b8414228913ef2911.
Definition ggen : N := 0x6767656e.
Definition index : N := 0x79.

Theorem prime_p : prime (Z.of_N p).
Proof.
Admitted.

Theorem p_len : 1024 <= N.size p.
Proof.
  simpl. lia.
Qed.

Theorem prime_q : prime (Z.of_N q).
Proof.
Admitted.

Theorem q_len : 160 <= N.size q.
Proof.
  simpl. lia.
Qed.

Theorem k_gteq_2 : 2 <= k.
Proof.
  vm_compute; intro Hf.
  inversion Hf.
Qed.

Theorem safe_prime : p = k * q + 1.
Proof.
  vm_compute.
  reflexivity.
Qed.

Theorem ggen_hyp : ggen =  0x6767656e.
Proof.
  unfold ggen.
  reflexivity.
Qed.

Theorem index_8bit : 0 <= index < 255.
Proof.
  vm_compute.
  split.
  intros Hf; inversion Hf.
  reflexivity.
Qed.

End Pins.

(* get a concrete instance *)
Module genr := Comp Pins.

Definition G := 0xc52a4a0ff3b7e61fdf1867ce84138369a6154f4afa92966e3c827e25cfa6cf508b90e5de419e1337e07a2e9e2a3cd5dea704d175f8ebf6af397d69e110b96afb17c7a03259329e4829b0d03bbc7896b15b4ade53e130858cc34d96269aa89041f409136c7242a38895c9d5bccad4f389af1d7a4bd1398bd072dffa896233397a.

Theorem G_is_gen : genr.Valid G = genr.compute_generator.
Proof.
  Time vm_compute.
  reflexivity.
Qed.

Time Eval vm_compute in genr.compute_generator.
(*
= genr.Valid
       138454106708200479055735335430888877165820506315681808529812588774891294266745965935843260905810124292112533861018873505541666292973867778507479111324012276358327291576815142910454131034197568218833096994765060449736987726137450505727390912803873697812682423871774182713509275008471752297521355610521695631738
   : genr.Tag
*)

Time Eval vm_compute in (genr.verify_generator 138454106708200479055735335430888877165820506315681808529812588774891294266745965935843260905810124292112533861018873505541666292973867778507479111324012276358327291576815142910454131034197568218833096994765060449736987726137450505727390912803873697812682423871774182713509275008471752297521355610521695631738).

(*
= true : bool
*)


Definition task := forall m n (p q : m <= n), p = q.


Require Import Cubical.
Require Import Pointed.
Require Import Homotopy.HSpace.Core.
Require Import Homotopy.Suspension.
Require Import Homotopy.Join.

Local Open Scope pointed_scope.
Local Open Scope mc_mult_scope.

(** A Cayley-Dickson Spheroid is a pointed type X which is an H-space, with two operations called negation and conjugation, satisfying the seven following laws.
  --x=x   x**=x   1*=1    (-x)*=-x*   x(-y)=-(xy)   (xy)* = y* x*    x* x=1    *)
Class CayleyDicksonSpheroid (X : pType) := {
  cds_hspace : IsHSpace X;
  cds_negate : Negate X;
  cds_conjug : Conjugate X;
  cds_negate_inv : Involutive cds_negate;
  cds_conjug_inv : Involutive cds_conjug;
  cds_conjug_unit_pres : IsUnitPreserving cds_conjug;
  cds_conjug_left_inv : LeftInverse (.*.) cds_conjug mon_unit;
  cds_conjug_distr : DistrOpp (.*.) cds_conjug;
  cds_swapop : SwapOp (-) cds_conjug;
  cds_factorneg_r : FactorNegRight (-) (.*.);
}.
#[export] Existing Instances
  cds_hspace
  cds_negate
  cds_conjug
  cds_negate_inv
  cds_conjug_inv
  cds_conjug_unit_pres
  cds_conjug_left_inv
  cds_conjug_distr
  cds_swapop
  cds_factorneg_r.

Section CayleyDicksonSpherioid_Properties.

  Context {X : pType} `(CayleyDicksonSpheroid X).

  Global Instance cds_factorneg_l : FactorNegLeft (-) (.*.).
  Proof.
    intros x y.
    transitivity (conj (conj (-x * y))).
    1: symmetry; apply involutive.
    rewrite distropp.
    rewrite swapop.
    rewrite factorneg_r.
    rewrite swapop.
    rewrite <- distropp.
    rewrite involutive.
    reflexivity.
  Defined.

  Global Instance cds_conjug_right_inv
    : RightInverse (.*.) cds_conjug mon_unit.
  Proof.
    intro x.
    set (p := cds_conjug x).
    rewrite <- (involutive x).
    apply left_inverse.
  Defined.

End CayleyDicksonSpherioid_Properties.

Global Instance conjugate_susp (A : Type) `(Negate A)
  : Conjugate (Susp A).
Proof.
  srapply Susp_rec.
  + exact North.
  + exact South.
  + intro a.
    exact (merid a).
Defined.

Global Instance negate_susp (A : Type) `(Negate A)
  : Negate (Susp A).
Proof.
  srapply Susp_rec.
  + exact South.
  + exact North.
  + intro a.
    exact (merid (-a))^.
Defined.

Class CayleyDicksonImaginaroid (A : Type) := {
  cdi_negate : Negate A;
  cdi_negate_involutive : Involutive cdi_negate;
  cdi_susp_hspace : IsHSpace (psusp A);
  cdi_susp_factorneg_r : FactorNegRight (negate_susp A cdi_negate) hspace_op;
  cdi_susp_conjug_left_inv : LeftInverse hspace_op (conjugate_susp A cdi_negate) mon_unit;
  cdi_susp_conjug_distr : DistrOpp hspace_op (conjugate_susp A cdi_negate);
}.
#[export] Existing Instances
  cdi_negate
  cdi_negate_involutive
  cdi_susp_hspace
  cdi_susp_factorneg_r
  cdi_susp_conjug_left_inv
  cdi_susp_conjug_distr.

Global Instance involutive_negate_susp {A} `(CayleyDicksonImaginaroid A)
  : Involutive (negate_susp A cdi_negate).
Proof.
  srapply Susp_ind_dp; try reflexivity.
  intro x.
  apply dp_paths_FFlr.
  rewrite concat_p1.
  rewrite Susp_rec_beta_merid.
  rewrite ap_V.
  rewrite Susp_rec_beta_merid.
  rewrite inv_V.
  rewrite (involutive x).
  apply concat_Vp.
Defined.

Global Instance involutive_conjugate_susp {A} `(CayleyDicksonImaginaroid A)
  : Involutive (conjugate_susp A cdi_negate).
Proof.
  srapply Susp_ind_dp; try reflexivity.
  intro x.
  apply dp_paths_FFlr.
  rewrite concat_p1.
  rewrite 2 Susp_rec_beta_merid.
  apply concat_Vp.
Defined.

Global Instance isunitpreserving_conjugate_susp {A} `(CayleyDicksonImaginaroid A)
  : @IsUnitPreserving _ _ pt pt (conjugate_susp A cdi_negate).
Proof.
  reflexivity.
Defined.

Global Instance swapop_conjugate_susp {A} `(CayleyDicksonImaginaroid A)
  : SwapOp negate (conjugate_susp A cdi_negate).
Proof.
  srapply Susp_ind_dp; try reflexivity.
  intro x.
  apply dp_paths_FlFr.
  rewrite concat_p1.
  rewrite ap_compose.
  rewrite (ap_compose negate).
  rewrite Susp_rec_beta_merid.
  rewrite ap_V.
  rewrite inv_V.
  rewrite 3 Susp_rec_beta_merid.
  apply concat_pV.
Defined.

(** Every suspension of a Cayley-Dickson imaginaroid gives a Cayley-Dickson spherioid. *)
Global Instance cds_susp_cdi {A} `(CayleyDicksonImaginaroid A)
  : CayleyDicksonSpheroid (psusp A) := {}.

Global Instance cdi_conjugate_susp_left_inverse {A} `(CayleyDicksonImaginaroid A)
  : LeftInverse hspace_op (conjugate_susp A cdi_negate) mon_unit.
Proof.
  srapply cds_conjug_left_inv.
Defined.

Global Instance cdi_conjugate_susp_right_inverse {A} `(CayleyDicksonImaginaroid A)
  : RightInverse hspace_op (conjugate_susp A cdi_negate) mon_unit.
Proof.
  srapply cds_conjug_right_inv.
Defined.

Global Instance cdi_susp_left_identity {A} `(CayleyDicksonImaginaroid A)
  : LeftIdentity hspace_op mon_unit.
Proof.
  exact _.
Defined.

Global Instance cdi_susp_right_identity {A} `(CayleyDicksonImaginaroid A)
  : RightIdentity hspace_op mon_unit.
Proof.
  exact _.
Defined.

Global Instance cdi_negate_susp_factornegleft {A} `(CayleyDicksonImaginaroid A)
  : FactorNegLeft (negate_susp A cdi_negate) hspace_op.
Proof.
  srapply cds_factorneg_l.
Defined.

(** A Cayley-Dickson imaginaroid A whose multiplciation on the suspension is associative gives rise to a H-space structure on the join of the suspension of A with itself. *)
Section ImaginaroidHSpace.

  (* Let A be a Cayley-Dickson imaginaroid with associative H-space multiplication on Susp A *)
  Context `{Funext} {A} `(CayleyDicksonImaginaroid A)
    `(!Associative hspace_op).

  (** Declaring these as local instances so that they can be found *)
  Local Instance hspace_op' : SgOp (Susp A) := hspace_op.
  Local Instance hspace_unit' : MonUnit (Susp A) := hspace_mon_unit.

  (** First we make some observations with the context we have. *)
  Section Lemmata.

    Context (a b c d : Susp A).

    Local Definition f := (fun x => a * (c * -x)).
    Local Definition g := (fun y => c * (y * b)).

    Lemma lemma1 : f (- mon_unit) = a * c.
    Proof.
      unfold f; apply ap.
      exact (hspace_right_identity c).
    Defined.

    Lemma lemma2 : f (conj c * conj a * d * conj b) = (-d) * conj b.
    Proof.
      unfold f.
      rewrite 2 factorneg_r.
      rewrite 3 simple_associativity.
      rewrite <- distropp.
      rewrite (right_inverse (a * c)).
      rewrite (left_identity d).
      symmetry.
      apply factorneg_l.
    Defined.

    Lemma lemma3 : g mon_unit = c * b.
    Proof.
      unfold g; apply ap.
      apply left_identity.
    Defined.

    Lemma lemma4 : g (conj c * conj a * d * conj b) = conj a * d.
    Proof.
      unfold g.
      rewrite 2 simple_associativity.
      rewrite <- simple_associativity.
      rewrite left_inverse.
      rewrite right_identity.
      rewrite 2 simple_associativity.
      rewrite right_inverse.
      rewrite <- simple_associativity.
      apply left_identity.
    Defined.

  End Lemmata.

  Arguments f {_ _}.
  Arguments g {_ _}.

  (** Here is the multiplication map in algebraic form:
      (a,b) * (c,d) = (a * c - d * b*, a* * d + c * b)
      the following is the spherical form. *)
  Global Instance cd_op
    : SgOp (pjoin (psusp A) (psusp A)).
  Proof.
    unfold psusp, pjoin; cbn.
    srapply Join_rec; hnf.
    { intro a.
      srapply Join_rec; hnf.
      - intro c.
        exact (joinl (hspace_op a c)).
      - intro d.
        exact (joinr (hspace_op (conj a) d)).
      - intros x y.
        apply jglue. }
    { intro b.
      srapply Join_rec; hnf.
      - intro c.
        exact (joinr (hspace_op c b)).
      - intro d.
        exact (joinl (hspace_op (-d) (conj b))).
      - intros x y.
        symmetry.
        apply jglue. }
    intros a b.
    apply path_forall.
    srapply Join_ind.
    1: intro; apply jglue.
    1: intro; cbn; symmetry; apply jglue.
    intros c d.
    srapply sq_dp^-1.
    refine (sq_ccGG _^ _^ _).
    1,2: apply Join_rec_beta_jglue.
    change (PathSquare (jglue (a * c) (c * b)) (jglue ((- d) * conj b) (conj a * d))^
      (jglue (a * c) (conj a * d)) (jglue ((- d) * conj b) (c * b))^).
    rewrite <- (lemma1 a c), <- (lemma2 a b c d),
       <- (lemma3 b c), <- (lemma4 a b c d).
    refine (sq_GGGG _ _ _ _ _).
    2,4: apply ap.
    1,2,3,4: srapply (Join_rec_beta_jglue _ _ (fun a b => jglue (f a) (g b))).
    refine (sq_cGcG _ _ _).
    1,2: exact (ap_V _ (jglue _ _ )).
    refine (@sq_ap _ _ _ _ _ _ _ (jglue _ _) (jglue _ _)^
      (jglue _ _) (jglue _ _)^ _).
    generalize (conj c * conj a * d * conj b).
    clear a b c d.
    change (forall s : Susp A,
      Diamond (-mon_unit) s (mon_unit) s).
    srapply Susp_ind_dp; hnf.
    1: by apply diamond_v.
    1: by apply diamond_h.
    intro a.
    apply diamond_twist.
  Defined.

  Global Instance cd_op_left_identity
    : LeftIdentity cd_op pt.
  Proof.
    srapply Join_ind.
    { unfold cd_op, Join_rec, Pushout.Pushout_rec, Pushout.Pushout_ind; simpl;
        intro a; apply ap.
      srapply hspace_left_identity. }
    { unfold cd_op, Join_rec, Pushout.Pushout_rec, Pushout.Pushout_ind.
      simpl; intro b; apply ap.
      srapply hspace_left_identity. }
    intros a b.
     simpl. apply sq_dp^-1.
    rewrite ap_idmap, Join_rec_beta_jglue.
    apply join_natsq_v.
  Defined.

  Global Instance cd_op_right_identity
    : RightIdentity cd_op pt.
  Proof.
    srapply Join_ind.
    { unfold cd_op, Join_rec, Pushout.Pushout_rec, Pushout.Pushout_ind; simpl.
      intro a; apply ap.
      srapply hspace_right_identity. }
    { unfold cd_op, Join_rec, Pushout.Pushout_rec, Pushout.Pushout_ind; simpl.
      intro b; apply ap.
      srapply hspace_left_identity. }
    intros a b.
    apply sq_dp^-1.
    rewrite ap_idmap.
    rewrite (ap_compose _ (fun f => f _)).
    rewrite Join_rec_beta_jglue.
    rewrite ap_apply_l.
    rewrite eisretr.
    apply join_natsq_v.
  Defined.

  Global Instance hspace_cdi_susp_assoc
    : IsHSpace (pjoin (psusp A) (psusp A))
    := {}.

End ImaginaroidHSpace.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  A set of signatures that we need to construct boolean equalities,
 variables and variable sets. Using the standard library.

 However, the weakness of Coq modules in combination with poor type
 inference does cause us to manhandle the signatures and functors
 a little bit.
*)
Set Implicit Arguments.
Require Import Coq.Structures.Equalities.
Require Export Coq.MSets.MSets.
Require Export Coq.MSets.MSetWeakList.

(* Boolean Equalities and sets of them and variables as their element. *)

Module Type BooleanEquality.
  Include BooleanDecidableType.
  (* These exists in Boolean.v but are not in a module. *)
  Parameter eqb_refl:  forall a,     eqb a a = true.
  Parameter eqb_sym:   forall x y,   eqb x y = eqb y x.
  Parameter eqb_trans:
    forall x y z,
      eqb x y = true -> eqb y z = true -> eqb x z = true.
  Parameter eq_trans:
    forall x y z, eq x y -> eq y z -> eq x z.
  Parameter eqb_to_eq:    forall a b, eqb a b = true -> a = b.
  Parameter eqb_to_neq:   forall a b, eqb a b = false -> a <> b.
  Parameter eqb_iff_eq:    forall a b, eqb a b = true <-> a = b.
  Parameter eqb_iff_neq:   forall a b, eqb a b = false <-> a <> b.
End BooleanEquality.

(* Not used. *)
Module BooleanEqualityFun.
  Include BooleanDecidableType.
  (* These exists in Boolean.v but are not in a module. *)
  Lemma eqb_refl:  forall a,     eqb a a = true. Admitted.
  Lemma eqb_sym:   forall x y,   eqb x y = eqb y x. Admitted.
  Lemma eqb_trans: forall x y z,
      eqb x y = true -> eqb y z = true -> eqb x z = true.
  Admitted.
  Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.  Admitted.
  Lemma eqb_to_eq:    forall a b, eqb a b = true -> a = b. Admitted.
  Lemma eqb_to_neq:   forall a b, eqb a b = false -> a <> b. Admitted.
  Lemma eqb_iff_eq:    forall a b, eqb a b = true <-> a = b. Admitted.
  Lemma eqb_iff_neq:   forall a b, eqb a b = false <-> a <> b. Admitted.
End BooleanEqualityFun.

(* Repeat the definitions of BooleanEquality and WOps(BooleanEquality) as I can't
get type inference to work otherwise. *)
Module Type BooleanEqualitySet.
   Declare Module BE : BooleanEquality.
   Include WOps(BE).
   Parameter eq : elt -> elt -> Prop.
   Parameter eq_equiv : Equivalence eq.
   Parameter eq_dec : forall x y : elt, {eq x y} + {~ eq x y}.
   Parameter eqb : elt -> elt -> bool.
   Parameter eqb_eq : forall x y : elt, eqb x y = true <-> eq x y.
   Parameter eqb_refl : forall a : elt, eqb a a = true.
   Parameter eqb_sym : forall x y : elt, eqb x y = eqb y x.
   Parameter eqb_trans :
     forall x y z : elt, eqb x y = true -> eqb y z = true -> eqb x z = true.
   Parameter eq_trans : forall x y z : elt, eq x y -> eq y z -> eq x z.
   Parameter eqb_to_eq : forall a b : elt, eqb a b = true -> a = b.
   Parameter eqb_to_neq : forall a b : elt, eqb a b = false -> a <> b.
   Parameter eqb_iff_eq : forall a b : elt, eqb a b = true <-> a = b.
   Parameter eqb_iff_neq : forall a b : elt, eqb a b = false <-> a <> b.
End BooleanEqualitySet.

Module BooleanEqualitySetFun(BE' : BooleanEquality) : BooleanEqualitySet.
  Module BE := BE'.
  Module BESet := Ops(BE).
  Include BESet.
  Definition eq := BE.eq.
  Definition eq_equiv := BE.eq_equiv.
  Definition eq_dec := BE.eq_dec.
  Definition eqb := BE.eqb.
  Definition eqb_eq := BE.eqb_eq.
  Definition eqb_refl := BE.eqb_refl.
  Definition eqb_sym := BE.eqb_sym.
  Definition eqb_trans := BE.eqb_trans.
  Definition eq_trans := BE.eq_trans.
  Definition eqb_to_eq := BE.eqb_to_eq.
  Definition eqb_to_neq := BE.eqb_to_neq.
  Definition eqb_iff_eq := BE.eqb_iff_eq.
  Definition eqb_iff_neq := BE.eqb_iff_neq.
End BooleanEqualitySetFun.
Print BooleanEqualitySetFun.

Module Type ContextSig.
  Declare Module K : BooleanEqualitySet.
  Declare Module T : BooleanEquality.

  Parameter Context  : Type.
  Parameter empty    : Context.
  Parameter add      : Context -> K.elt -> T.t -> Context.
  Parameter map      : Context -> K.elt -> option T.t.
  Parameter nodup    : Context -> bool.
  Parameter equal    : Context -> Context -> bool.
  Parameter concat   : Context -> Context -> Context.
  Parameter dom      : Context -> K.t.
  Parameter extends  : Context -> Context -> bool.
End ContextSig.

Module ContextFun(K': BooleanEquality) (T' : BooleanEquality) <: ContextSig.
  Module K := BooleanEqualitySetFun(K').
  Module T := T'.

Inductive Context': Type :=
| dot  : Context'
| ctxt :  K.elt -> T.t -> Context' -> Context' .

Definition Context := Context'.
Definition empty  := dot.

Function add (c : Context') (k: K.elt) (t : T.t)  : Context' :=
  match c with
    | dot => (ctxt k t (dot))
    | (ctxt k' t' c') =>
      match K.eqb k k' with
        | true  => (ctxt k  t  c')
        | false => (ctxt k' t' (add c' k t))
      end
  end.
Hint Unfold add.

Function map (c : Context') (k : K.elt) : option T.t :=
  match c with
    | dot => None
    | (ctxt k' t' c') =>
      match K.eqb k k' with
        | true  => Some t'
        | false => (map c' k)
      end
  end.
Hint Unfold map.

Function delete (c : Context') (k : K.elt) : Context' :=
  match k, c with
    | k, dot => empty
    | k, (ctxt k' t' c') =>
      match K.eqb k k' with
        | true  => c'
        | false => (ctxt k' t' (delete c' k))
      end
  end.
Hint Unfold delete.

Function nodup (c : (Context')) : bool :=
  match c with
    | dot => true
    | (ctxt k' t' c') =>
      match map c' k' with
        | Some t  => false
        | None  => nodup c'
      end
end.
Hint Unfold nodup.

Function extends (c c' : Context') : bool :=
  match c with
    | dot => true
    | ctxt k t c'' =>
      match map c' k with
       | Some t' =>
         match (T.eqb t t') with
           | true => extends c'' c'
           | false => false
         end
       | None => false
      end
  end.
Hint Unfold extends.

Function equal (c c' : Context') : bool :=
  andb (extends c c') (extends c' c).
Hint Unfold equal.

Function concat (c c' : Context') {struct c'} : Context' :=
  match c' with
  | dot => c
  | (ctxt k v d) => (ctxt k v (concat c d))
  end.

Function dom (c : Context') : K.t :=
 match c with
 | dot => K.empty
 | (ctxt k v c') => K.union (K.singleton k) (dom c')
 end.
End ContextFun.


From Coq Require Import String List.

Inductive scala_case_condition : Set -> Set -> Type :=
  | case_pred    : forall A : Set,   (A -> bool)     -> scala_case_condition A A
  | case_extract : forall A B : Set, (A -> option B) -> scala_case_condition A (A * B).

Inductive scala_case : Set -> Set -> Type :=
  | case : forall A B C : Set, scala_case_condition A B -> (B -> C) -> scala_case A C.

Inductive scala_match (A B : Set) : Type :=
  | match_constr : list (scala_case A B) -> scala_match A B.

(* marking type parameters implicit *)

Arguments case_pred [A].
Arguments case_extract [A B].
Arguments case [A B C].
Arguments match_constr [A B].

(* how to evaluate scala_match *)

Definition eval_case_condition : forall (A B : Set), A -> scala_case_condition A B -> option B.
  intros A B a cond.
  inversion cond as [ A0 p | A0 C e ].
  - subst A0 B. exact (if p a then Some a else None).
  - subst A0.   exact (option_map (fun c => (a, c)) (e a)).
Defined.

Arguments eval_case_condition [A B].

Definition eval_case : forall (A B : Set), A -> scala_case A B -> option B.
  intros A B a case.
  inversion case as [ A0 C B0 cond f ]. subst A0 B0.
  exact (option_map f (eval_case_condition a cond)).
Defined.

Arguments eval_case [A B].

Definition eval_match (A B : Set) (a : A) (m : scala_match A B) : option B :=
  match m with
  | match_constr cases =>
      (fix loop cs :=
          match cs with
          | nil      => None
          | cons h t =>
              match eval_case a h with
              | Some b => Some b
              | None   => loop t
              end
          end) cases
  end.

Arguments eval_match [A B].

(* simple match example *)

Record user : Set := mkUser {
    username     : string;
    emailAddress : string
  }.

Definition username_extractor (u : user) : option string := Some (username u).
Definition tru (u : user) : bool := true.
Definition fls (u : user) : bool := false.

Open Scope string_scope.

Eval compute in (
  eval_match (mkUser "username" "")
    (match_constr  (
      case (case_pred fls) (fun _ => "fls") ::
      case (case_extract username_extractor) snd ::
      case (case_pred tru) (fun _ => "tru") ::
      nil)
    )
).

(* defining the pattern matching combinator *)

Definition and_match : forall A B X Y : Set,
    scala_case_condition A X -> scala_case_condition A Y -> (X -> Y -> B) -> scala_case A B.
  intros A B X Y c1 c2 f.
  inversion c1 as [ A0 p1 | A0 C1 e1 ]; subst A0 X;
  inversion c2 as [ A0 p2 | A0 C2 e2 ]; subst A0 Y.
  - exact (case (case_pred (fun a => andb (p1 a) (p2 a))) (fun a => f a a)).
  - exact (case (case_extract
            (fun a => match (p1 a), (e2 a) with
                      | true, Some c => Some c
                      | _   , _      => None
                      end))
            (fun ac => f (fst ac) ac)).
  - exact (case (case_extract
            (fun a => match (e1 a), (p2 a) with
                      | Some c, true => Some c
                      | _     , _    => None
                      end))
            (fun ac => f ac (fst ac))).
  - exact (case (case_extract
            (fun a => match (e1 a), (e2 a) with
                      | Some c1, Some c2 => Some (c1, c2)
                      | _      , _       => None
                      end))
            (fun acc => f (fst acc, fst (snd acc)) (fst acc, snd (snd acc)) )).
Defined.

Arguments and_match [A B X Y].

(* some properties *)

Definition cond_matches (A B : Set) (a : A) (cond : scala_case_condition A B) : Prop :=
  exists x, eval_case_condition a cond = Some x.

Definition case_matches (A B : Set) (a : A) (case : scala_case A B) : Prop :=
  exists x, eval_case a case = Some x.

Arguments cond_matches [A B].
Arguments case_matches [A B].

Lemma if_both_branches : forall (A : Type) (b : bool) (a : A), (if b then a else a) = a.
Proof.
  intros A b a. case b.
  - reflexivity.
  - reflexivity.
Qed.

Lemma match_option_both_branches : forall (A B : Type) (a : option A) (b : B),
    (match a with | Some _ => b | None => b end) = b.
Proof.
  intros A B a b. case a.
  - reflexivity.
  - reflexivity.
Qed.

Ltac simpl_eq_rec := simpl; unfold eq_rec_r; simpl.
Ltac simpl_eq_rect := simpl; unfold eq_rect_r; simpl; unfold eq_rec_r; simpl.

Ltac solve_for_pred p a H :=
  exists a; simpl_eq_rec; generalize H; simpl_eq_rect; unfold option_map; case (p a);
  try rewrite Bool.andb_false_r; try rewrite match_option_both_branches; easy.

Ltac solve_for_extract o a H :=
  generalize H; unfold cond_matches; simpl_eq_rect; case (o a);
  [ intros x1 H1; exists (a, x1); now simpl
  | unfold option_map; simpl; try
      (now rewrite if_both_branches || now rewrite match_option_both_branches || discriminate) ].

Theorem and_match_both_match_1 : forall (A B X Y : Set) (a : A) (f : X -> Y -> B)
    (c1 : scala_case_condition A X) (c2 : scala_case_condition A Y),
    case_matches a (and_match c1 c2 f) -> cond_matches a c1 /\ cond_matches a c2.
Proof.
  intros A B X Y a f.
  induction c1 as [ A p1 | A C1 e1 ]; induction c2 as [ A p2 | A C2 e2 ].
  - intros [x H]. split.
    + solve_for_pred    p1 a H.
    + solve_for_pred    p2 a H.
  - intros [x H]. split.
    + solve_for_pred    p1 a H.
    + solve_for_extract e2 a H.
  - intros [x H]. split.
    + solve_for_extract e1 a H.
    + solve_for_pred    p2 a H.
  - intros [x H]. split.
    + solve_for_extract e1 a H.
    + solve_for_extract e2 a H.
Qed.

Ltac subst_over_some :=
  intros; repeat (
    match goal with
    | HSome: Some _ = Some _ |- _ => injection HSome; clear HSome
    end; intros; subst
  ).

Ltac solve_for_case p1 p2 a f :=
  intros [[x1 H1] [x2 H2]]; generalize H1 H2; unfold case_matches; simpl_eq_rect;
  intros H3 H4; exists (f x1 x2); generalize H3 H4;
  case (p1 a); case (p2 a); try unfold option_map; subst_over_some; now simpl.

Theorem and_match_both_match_2 : forall (A B X Y : Set) (a : A) (f : X -> Y -> B)
    (c1 : scala_case_condition A X) (c2 : scala_case_condition A Y),
    cond_matches a c1 /\ cond_matches a c2 -> case_matches a (and_match c1 c2 f).
Proof.
  intros A B X Y a f.
  induction c1 as [ A p1 | A C1 e1 ]; induction c2 as [ A p2 | A C2 e2 ].
  - solve_for_case p1 p2 a f.
  - solve_for_case p1 e2 a f.
  - solve_for_case e1 p2 a f.
  - solve_for_case e1 e2 a f.
Qed.

Theorem and_match_both_match : forall (A B X Y : Set) (a : A) (f : X -> Y -> B)
    (c1 : scala_case_condition A X) (c2 : scala_case_condition A Y),
    case_matches a (and_match c1 c2 f) <-> cond_matches a c1 /\ cond_matches a c2.
Proof.
  split; [ apply and_match_both_match_1 | apply and_match_both_match_2 ].
Qed.


Require Export LogRelFI.PseudoType.
Require Export RecTypes.Contraction.
Require Export LogRelFI.Contraction.

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Max.
Require Import Coq.micromega.Lia.

Fixpoint pNumbFree (τ : PTy) : nat :=
  match τ with
  | ptunit => 0
  | ptbool => 0
  | ptprod τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptsum τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptarr τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | pEmulDV n p τ => 0
  end.
Arguments pNumbFree !τ.

Lemma pNumbFree_sound τ : innerPClosed τ → ws (pNumbFree τ) τ.
Proof.
  induction τ; cbn; try constructor; dependent destruction H.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - assumption.
Qed.

Definition pDecideClosed τ := match pNumbFree τ with
                             | 0 => B.true
                             | _ => B.false
                             end.

Arguments pDecideClosed /.
Lemma decidePClosed_sound {τ} : innerPClosed τ → Is_true (pDecideClosed τ) -> ⟨ 0 ⊢ τ ⟩.
Proof.
  unfold pDecideClosed, WsTy.
  remember (pNumbFree τ).
  destruct n; intuition.
  rewrite Heqn.
  now eapply pNumbFree_sound.
Qed.

Lemma pNumbFree_complete {τ n} : ⟨ n ⊢ τ ⟩ -> pNumbFree τ <= n.
Proof.
  induction 1; cbn; try lia.
Qed.

Lemma pNumbFree_complete' {τ} : ⟨ 0 ⊢ τ ⟩ -> pNumbFree τ = 0.
Proof.
  intros cl.
  cut (pNumbFree τ <= 0).
  - lia.
  - now eapply pNumbFree_complete.
Qed.

Lemma pDecideClosed_complete {τ} : ⟨ 0 ⊢ τ ⟩ -> Is_true (pDecideClosed τ).
Proof.
  intros cτ.
  assert (nc := pNumbFree_complete cτ).
  assert (eq : pNumbFree τ = 0) by lia.
  unfold pDecideClosed.
  now rewrite eq.
Qed.

Inductive ClosedPEnv : PEnv → Prop :=
  | PEmptyClosed : ClosedPEnv pempty
  | VarPClosed {Γ τ} :
      ⟨ 0 ⊢ τ ⟩ →
      ClosedPEnv Γ →
      ClosedPEnv (Γ p▻ τ).

Hint Constructors wsPTy : cty.
Hint Constructors ClosedPEnv : cenv.

Definition ValidPTy : PTy -> Prop := fun τ => ⟨ 0 ⊢ τ ⟩ /\ SimplePContr τ.
(* Definition ValidPEnv : PEnv -> Prop := fun Γ => ClosedPEnv Γ /\ ContrPEnv Γ. *)

Lemma ValidPTy_SimplePContr {τ} : ValidPTy τ -> SimplePContr τ.
Proof.
  now destruct 1.
Qed.
Hint Resolve ValidPTy_SimplePContr : simple_p_contr_rec.

(* Lemma ValidPEnv_nil : ValidPEnv pempty. *)
(* Proof. *)
(*   split; constructor; eauto. *)
(* Qed. *)
(* Hint Resolve ValidPEnv_nil : ptyvalid. *)

(* Lemma ValidPEnv_cons {Γ τ} : ValidPEnv Γ -> ValidPTy τ -> ValidPEnv (Γ p▻ τ). *)
(* Proof. *)
(*   intros [env_cl env_contr] [ty_cl ty_contr]. *)
(*   split; constructor; eauto. *)
(* Qed. *)
(* Hint Resolve ValidPEnv_cons : ptyvalid. *)

(* Lemma ValidPEnv_invert_cons {Γ τ} : ValidPEnv (Γ p▻ τ) → ValidPEnv Γ ∧ ValidPTy τ. *)
(* Proof. *)
(*   intro vΓ. *)
(*   destruct vΓ as (closedΓ & contrΓ). *)
(*   inversion closedΓ; inversion contrΓ; subst. *)
(*   split; split; assumption. *)
(* Qed. *)

(* Lemma ValidPEnv_getevar {Γ i τ} : ValidPEnv Γ → ⟪ i : τ p∈ Γ ⟫ → ValidPTy τ. *)
(* Proof. *)
(*   revert Γ. *)
(*   induction i; intros Γ vΓ ev. *)
(*   - inversion ev; subst. *)
(*     destruct (ValidPEnv_invert_cons vΓ) as (_ & vτ). *)
(*     assumption. *)
(*   - inversion ev; subst. *)
(*     destruct (ValidPEnv_invert_cons vΓ) as (vΓ0 & _). *)
(*     apply (IHi Γ0 vΓ0 H1). *)
(* Qed. *)