Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import primRec.
Require Import cPair.
Require Import Arith.
Require Import folProp.
Require Import code.
Require Import codeList.
Require Import codeFreeVar.
Require Import extEqualNat.
Require Vector.
Require Import prLogic.
Require Import Compat815.
From Coq Require Import Lia.
Import LispAbbreviations.

Section close.

Variable L : Language.
Variable codeF : Functions L -> nat.
Variable codeR : Relations L -> nat.

Let Formula := Formula L.
Let codeFormula := codeFormula L codeF codeR.

Definition codeCloseList : nat -> nat -> nat :=
  evalStrongRec 1
    (fun l recs f : nat =>
     switchPR l
       (cPair 3
          (cPair (car (pred l))
             (codeNth (l - S (cdr (pred l))) recs))) f).

Lemma codeCloseListCorrect (l : list nat) (f : Formula):
 codeCloseList (codeList l) (codeFormula f) =
   codeFormula (closeList L l f).
Proof.
  set (g :=
         fun l recs f : nat =>
           switchPR l
             (cPair 3
                (cPair (car (pred l))
                   (codeNth (l - S (cdr (pred l))) recs)))
             f).
  induction l as [| a l Hrecl].
  - simpl; unfold codeCloseList, evalStrongRec in |- *; simpl.
    rewrite cPairProjections1; reflexivity.
  - simpl; unfold codeCloseList; fold g.
    assert
      (H :forall n m : nat,
          m < n ->
          extEqual 1
            (evalComposeFunc 1 1 (Vector.cons _
                                    (evalStrongRecHelp 1 g n) 0 (Vector.nil _))
               (fun b : nat => codeNth (n - S m) b)) (evalStrongRec 1 g m)).
    { intros n m H; apply (evalStrongRecHelp2 1); assumption. }
    simpl in H; unfold evalStrongRec in |- *.
    unfold evalComposeFunc, evalOneParamList, evalList.
    rewrite computeEvalStrongRecHelp.
    unfold compose2, evalComposeFunc, evalOneParamList, evalList in |- *.
    unfold g at 1; rewrite H.
    + simpl; repeat rewrite cPairProjections1 || rewrite cPairProjections2.
      rewrite <- Hrecl; reflexivity.
    + simpl; apply Compat815.le_lt_n_Sm, cPairLe2A.
Qed.

Lemma codeCloseListIsPR : isPR 2 codeCloseList.
Proof.
  unfold codeCloseList; apply evalStrongRecIsPR.
  apply compose3_3IsPR with
    (f1 := fun l recs f : nat => l)
    (f2 := fun l recs f : nat =>
             cPair 3
               (cPair (car (pred l))
                  (codeNth (l - S (cdr (pred l))) recs)))
    (f3 := fun l recs f : nat => f).
  - apply pi1_3IsPR.
  - apply filter110IsPR with
      (g := fun l recs : nat =>
              cPair 3
                (cPair (car (pred l))
                   (codeNth (l - S (cdr (pred l))) recs))).
    apply compose2_2IsPR with
      (f := fun l recs : nat => 3)
      (g := fun l recs : nat =>
              cPair (car (pred l))
                (codeNth (l - S (cdr (pred l))) recs)).
    + apply filter10IsPR with (g := fun _ : nat => 3).
      apply const1_NIsPR.
    + apply compose2_2IsPR with
        (f := fun l recs : nat => car (pred l))
        (g := fun l recs : nat => codeNth (l - S (cdr (pred l))) recs).
      * apply filter10IsPR with (g := fun l : nat => car (pred l)).
        apply compose1_1IsPR.
        -- apply predIsPR.
        -- apply cPairPi1IsPR.
      * apply callIsPR with (g := fun l : nat => cdr (pred l)).
        apply compose1_1IsPR.
        -- apply predIsPR.
        -- apply cPairPi2IsPR.
      * apply cPairIsPR.
    + apply cPairIsPR.
  - apply pi3_3IsPR.
  - apply switchIsPR.
Qed.

Definition codeClose (f : nat) : nat :=
  codeCloseList (codeNoDup (codeFreeVarFormula f)) f.

Lemma codeCloseCorrect (f : Formula) :
  codeClose (codeFormula f) = codeFormula (close L f).
Proof.
  unfold close, codeClose, codeFormula;
    rewrite codeFreeVarFormulaCorrect, codeNoDupCorrect.
  apply codeCloseListCorrect.
Qed.

Lemma codeCloseIsPR : isPR 1 codeClose.
Proof.
  unfold codeClose;
    apply compose1_2IsPR with
    (f := fun f : nat => codeNoDup (codeFreeVarFormula f))
    (f' := fun f : nat => f).
  - apply compose1_1IsPR.
    + apply codeFreeVarFormulaIsPR.
    + apply codeNoDupIsPR.
  - apply idIsPR.
  - apply codeCloseListIsPR.
Qed.

End close.

Require Import PA.
Require Import codeSubFormula.

Section Code_PA.

Let codeTerm := codeTerm LNT codeLNTFunction.
Let codeFormula := codeFormula LNT codeLNTFunction codeLNTRelation.
Let codeFormulaInj :=
  codeFormulaInj LNT codeLNTFunction codeLNTRelation codeLNTFunctionInj
    codeLNTRelationInj.

Definition codeOpen : nat -> nat :=
  evalStrongRec 0
    (fun f recs : nat =>
     switchPR (car f)
       (switchPR (pred (car f))
          (switchPR (pred (pred (car f)))
             (switchPR (pred (pred (pred (car f)))) f
                (codeNth (f - S (cdr (cdr f))) recs)) f) f) f).

Lemma codeOpenCorrect (f : Formula):
  codeOpen (codeFormula f) = codeFormula (open f).
Proof.
  unfold codeOpen, open;
    set (g :=
           fun f recs : nat =>
             switchPR (car f)
               (switchPR (pred (car f))
                  (switchPR (pred (pred (car f)))
                     (switchPR (pred (pred (pred (car f)))) f
                        (codeNth (f - S (cdr (cdr f))) recs)) f) f) f).
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
    simpl; unfold evalStrongRec.
  - simpl ; unfold g ;
      repeat rewrite cPairProjections1 || rewrite cPairProjections2;
      reflexivity.
  - simpl in |- *; unfold g at 1 in |- *;
      repeat rewrite cPairProjections1 || rewrite cPairProjections2;
      reflexivity.
  - simpl in |- *; unfold g at 1 in |- *;
      repeat rewrite cPairProjections1 || rewrite cPairProjections2;
      reflexivity.
  - simpl in |- *; unfold g at 1 in |- *;
      repeat rewrite cPairProjections1 || rewrite cPairProjections2;
      reflexivity.
  - unfold evalComposeFunc, evalOneParamList, evalList;
      rewrite computeEvalStrongRecHelp.
    unfold compose2, evalComposeFunc, evalOneParamList, evalList.
    unfold g at 1; repeat rewrite evalStrongRecHelp1.
    unfold pred;
      repeat rewrite cPairProjections1 || rewrite cPairProjections2.
    + simpl; apply Hrecf.
    + eapply Nat.le_lt_trans.
      * apply cPairLe2A.
      * rewrite cPairProjections2.
        apply cPairLt2.
Qed.

Lemma codeOpenIsPR : isPR 1 codeOpen.
Proof.
  unfold codeOpen; apply evalStrongRecIsPR.
  apply
    compose2_3IsPR
    with
    (f1 := fun f recs : nat => car f)
    (f2 := fun f recs : nat =>
             switchPR (pred (car f))
               (switchPR (pred (pred (car f)))
                  (switchPR (pred (pred (pred (car f)))) f
                     (codeNth (f - S (cdr (cPairPi2 f))) recs)) f) f)
    (f3 := fun f recs : nat => f).
  - apply filter10IsPR.
    apply cPairPi1IsPR.
  - apply compose2_3IsPR with
      (f1 := fun f recs : nat => pred (car f))
      (f2 := fun f recs : nat =>
               switchPR (pred (pred (car f)))
                 (switchPR (pred (pred (pred (car f)))) f
                    (codeNth (f - S (cdr (cdr f))) recs)) f)
      (f3 := fun f recs : nat => f).
    + apply filter10IsPR with (g := fun f : nat => pred (car f)).
      apply compose1_1IsPR.
      * apply cPairPi1IsPR.
      * apply predIsPR.
    + apply compose2_3IsPR with
        (f1 := fun f recs : nat => pred (pred (car f)))
        (f2 := fun f recs : nat =>
                 switchPR (pred (pred (pred (car f)))) f
                   (codeNth (f - S (cdr (cdr f))) recs))
        (f3 := fun f recs : nat => f).
      * apply filter10IsPR with
          (g := fun f : nat => pred (pred (car f))).
        apply compose1_1IsPR with (f := fun f : nat => pred (car f)).
        -- apply compose1_1IsPR.
           ++ apply cPairPi1IsPR.
           ++ apply predIsPR.
        -- apply predIsPR.
      * apply compose2_3IsPR with
          (f1 := fun f recs : nat => pred (pred (pred (car f))))
          (f2 := fun f recs : nat => f)
          (f3 := fun f recs : nat => codeNth (f - S (cdr (cdr f))) recs).
        -- apply filter10IsPR with
             (g := fun f : nat => pred (pred (pred (car f)))).
           apply compose1_1IsPR with
             (f := fun f : nat => pred (pred (car f))).
           ++ apply compose1_1IsPR with
                (f := fun f : nat => pred (car f)).
              ** apply compose1_1IsPR.
                 apply cPairPi1IsPR.
                 apply predIsPR.
              ** apply predIsPR.
           ++ apply predIsPR.
        -- apply pi1_2IsPR.
        -- apply callIsPR with (g := fun f : nat => cdr (cdr f)).
           apply compose1_1IsPR; apply cPairPi2IsPR.
        -- apply switchIsPR.
      * apply pi1_2IsPR.
      * apply switchIsPR.
    + apply pi1_2IsPR.
    + apply switchIsPR.
  - apply pi1_2IsPR.
  - apply switchIsPR.
Qed.

Definition codeInductionSchema (f : nat) : bool :=
  let n :=
    car (cdr (cddddr  (codeOpen f))) in
  let g := cdr (cdr (cddddr (codeOpen f))) in
  Nat.eqb
    (codeClose
       (codeImp (codeSubFormula g n (codeTerm Zero))
          (codeImp
             (codeForall n
                (codeImp g (codeSubFormula g n
                              (codeTerm (Succ (var n))))))
             (codeForall n g)))) f.

Lemma codeInductionSchemaCorrect1 (f : Formula) :
 InductionSchema f -> codeInductionSchema (codeFormula f) = true.
Proof.
  intros [x [x0 H]]; unfold PA7 in H; rewrite H; clear H f.
  lazy beta delta [codeInductionSchema] in |- *.
  rewrite codeOpenCorrect;
    replace
      (open
         (close LNT
            (impH (substituteFormula LNT x x0 Zero)
               (impH
                  (forallH x0
                     (impH x
                        (substituteFormula LNT x x0 (Succ (var x0)))))
                  (forallH x0 x)))))
    with
    (impH (substituteFormula LNT x x0 Zero)
       (impH (forallH x0
                (impH x (substituteFormula LNT x x0 (Succ (var x0)))))
          (forallH x0 x))).
  - replace
      (cadr (cddddr
               (codeFormula
                  (impH (substituteFormula LNT x x0 Zero)
                     (impH
                        (forallH x0
                           (impH x
                              (substituteFormula LNT x x0
                                 (Succ (var x0)))))
                        (forallH x0 x))))))
      with x0.
    + replace
        (cddr
           (cddddr
              (codeFormula
                 (impH (substituteFormula LNT x x0 Zero)
                    (impH
                       (forallH x0
                          (impH x
                             (substituteFormula LNT x x0
                                (Succ (var x0)))))
                       (forallH x0 x))))))
         with (codeFormula x).
      * cbv zeta; unfold codeFormula; rewrite <- codeCloseCorrect.
        replace
          (codeClose
             (codeImp
                (codeSubFormula
                   (code.codeFormula LNT codeLNTFunction
                      codeLNTRelation x) x0
                   (codeTerm Zero))
                (codeImp
                   (codeForall x0
                      (codeImp
                         (code.codeFormula LNT codeLNTFunction
                            codeLNTRelation x)
                         (codeSubFormula
                            (code.codeFormula LNT
                               codeLNTFunction codeLNTRelation x)
                            x0 (codeTerm (Succ (var x0))))))
                   (codeForall x0
                      (code.codeFormula LNT codeLNTFunction
                         codeLNTRelation x)))))
          with
          (codeClose
             (code.codeFormula LNT codeLNTFunction codeLNTRelation
                (impH (substituteFormula LNT x x0 Zero)
                   (impH
                      (forallH x0
                         (impH x (substituteFormula LNT x x0
                                    (Succ (var x0)))))
                      (forallH x0 x))))).
      -- rewrite Nat.eqb_refl; reflexivity.
      -- simpl; unfold codeTerm; repeat rewrite codeSubFormulaCorrect.
         reflexivity.
      * simpl;
          repeat rewrite cPairProjections1 || rewrite cPairProjections2.
        reflexivity.
    + simpl in |- *.
      repeat rewrite cPairProjections1 || rewrite cPairProjections2.
      reflexivity.
  - unfold close.
      induction
        (List.nodup Nat.eq_dec
           (freeVarFormula LNT
              (impH (substituteFormula LNT x x0 Zero)
                 (impH
                    (forallH x0
                       (impH x (substituteFormula LNT x x0
                                  (Succ (var x0)))))
             (forallH x0 x))))).
    + reflexivity.
    + simpl; assumption.
Qed.

Lemma codeInductionSchemaCorrect2 (f : Formula):
 codeInductionSchema (codeFormula f) = true -> InductionSchema f.
Proof.
  intros H; lazy beta delta [codeInductionSchema] in H;
    rewrite codeOpenCorrect in H.
  set
    (n := car (cdr (cddddr (codeFormula (open f))))) in *.
  set
    (g := cdr (cdr (cddddr (codeFormula (open f))))) in *.
  cbv zeta in H.
  induction
    (eq_nat_dec
       (codeImp (codeSubFormula g n (codeTerm Zero))
          (codeImp
             (codeForall n
                (codeImp g (codeSubFormula g n
                              (codeTerm (Succ (var n))))))
             (codeForall n g)))
       (codeFormula (open f))) as [a | b].
  - rewrite a in H; unfold codeFormula in H;
      rewrite codeCloseCorrect in H;  fold codeFormula in H.
    destruct (formula_dec LNT LNT_dec (close LNT (open f)) f)
      as [a0 | b].
    + unfold codeImp at 1 in a.
      destruct (open f) as [t t0| r t| f0 f1| f0| n0 f0]; simpl in a;
        try
          match goal with
          | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
              assert False by (cut (X1 = X3);
              [ discriminate | eapply cPairInj1; apply h]) ; contradiction
          end.
        assert (H0: codeSubFormula g n (codeTerm Zero) = codeFormula f0).
        { eapply cPairInj1, cPairInj2; apply a. }
        assert
          (H1: codeImp
                 (codeForall n
                    (codeImp g (codeSubFormula g n
                                  (codeTerm (Succ (var n))))))
                 (codeForall n g) =
                 codeFormula f1).
        { eapply cPairInj2; eapply cPairInj2; apply a. }
        clear a.
        Opaque cPairPi1.
        Opaque cPairPi2.
        unfold codeImp at 1 in H1.
        destruct f1 as [t t0| r t| f1 f2| f1| n0 f1]; simpl in H1;
          try
            match goal with
            | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
                assert False by
                (cut (X1 = X3);
                [ discriminate | eapply cPairInj1; apply h ]);
                 contradiction
            end.
        assert
          (H2: codeForall n (codeImp g
                               (codeSubFormula g n
                                  (codeTerm (Succ (var n))))) =
                 codeFormula f1).
        { eapply cPairInj1; eapply cPairInj2; apply H1. }
        assert (H3: codeForall n g = codeFormula f2).
        { eapply cPairInj2; eapply cPairInj2; apply H1. }
        clear H1.
        unfold codeForall at 1 in H3;
          destruct f2 as [t t0| r t| f2 f3| f2| n0 f2]; simpl in H3;
          try
            match goal with
            | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
                assert False by (cut (X1 = X3);
                [ discriminate | eapply cPairInj1; apply h ]);
                contradiction
            end.
        simpl in (value of n).
        simpl in (value of g).
        unfold InductionSchema in |- *.
        exists f2, n0.
        unfold PA7; replace (substituteFormula LNT f2 n0 Zero) with f0.
      * replace (forallH n0 (impH f2
                               (substituteFormula LNT f2 n0
                                  (Succ (var n0)))))
          with f1.
        -- symmetry; apply a0.
        -- apply codeFormulaInj; simpl; rewrite <- codeSubFormulaCorrect.
           symmetry; unfold n, g in H2.
           repeat
             rewrite cPairProjections1 in H2 ||
                                            rewrite cPairProjections2
               in H2; apply H2.
      * apply codeFormulaInj; rewrite <- codeSubFormulaCorrect.
        symmetry; unfold n, g in H0.
        repeat
          rewrite cPairProjections1 in H0 || rewrite cPairProjections2
            in H0; apply H0.
    + rewrite nat_eqb_false in H.
      * discriminate H.
      * unfold not in |- *; intros; apply b.
        apply codeFormulaInj, H0.
  - rewrite nat_eqb_false in H.
    discriminate H.
    unfold not in |- *; intros; apply b.
    rewrite <- codeOpenCorrect, <- H0.
    unfold codeImp;
      generalize
        (cPair (codeSubFormula g n (codeTerm Zero))
           (cPair 1
              (cPair
                 (codeForall n
                    (cPair 1
                       (cPair g (codeSubFormula g n
                                   (codeTerm (Succ (var n)))))))
                 (codeForall n g)))).
    intros n0; unfold codeClose;
      assert
        (H1: forall m : nat,
            m <= codeNoDup (codeFreeVarFormula (cPair 1 n0)) ->
            cPair 1 n0 = codeOpen (codeCloseList m (cPair 1 n0))).
    { induction (codeNoDup (codeFreeVarFormula (cPair 1 n0))).
      intros m H1; replace m with 0 by lia.
      - unfold codeCloseList, evalStrongRec.
        unfold evalComposeFunc, evalOneParamList, evalList; simpl.
        rewrite cPairProjections1.
        unfold codeOpen, evalStrongRec.
        unfold evalComposeFunc, evalOneParamList, evalList.
        rewrite computeEvalStrongRecHelp.
        unfold compose2, evalComposeFunc, evalOneParamList, evalList.
        repeat rewrite cPairProjections1.
        simpl; repeat rewrite cPairProjections1; reflexivity.
      - intros m H1; destruct  (Compat815.le_lt_or_eq _ _ H1) as [H2 | H2].
        + apply IHn1.
          apply Compat815.lt_n_Sm_le.
          assumption.
        + rewrite H2.
          unfold codeCloseList in |- *.
          set (g0 :=
                 fun l recs f0 : nat =>
                   switchPR l
                     (cPair 3
                        (cPair (car (pred l))
                           (codeNth (l - S (cdr (pred l))) recs)))
                     f0).
          unfold evalStrongRec, evalComposeFunc, evalOneParamList, evalList.
          rewrite computeEvalStrongRecHelp.
          unfold compose2,  evalComposeFunc, evalOneParamList, evalList.
          assert
            (H3: forall n m : nat,
                m < n ->
                extEqual 1
                  (evalComposeFunc 1 1 (Vector.cons _
                                          (evalStrongRecHelp 1 g0 n) 0
                                          (Vector.nil _))
                     (fun b : nat => codeNth (n - S m) b))
                  (evalStrongRec 1 g0 m)).
          { intros n2 m0; apply (evalStrongRecHelp2 1). }
          simpl in H3.
          unfold g0 at 1; rewrite H3; simpl.
          * repeat rewrite cPairProjections1.
            unfold codeCloseList in IHn1.
            move g0 after IHn1; fold g0 in IHn1.
            set (A := evalStrongRec 1 g0 (cdr n1) (cPair 1 n0)) in *.
            unfold codeOpen.
            set
              (g1 :=
                 fun f0 recs : nat =>
                   switchPR (car f0)
                     (switchPR (pred (car f0))
                        (switchPR (pred (pred (car f0)))
                           (switchPR (pred (pred (pred (car f0)))) f0
                              (codeNth (f0 - S (cdr (cdr f0))) recs))
                           f0) f0) f0).
            unfold evalStrongRec, evalComposeFunc, evalOneParamList, evalList.
            rewrite computeEvalStrongRecHelp; unfold compose2.
            unfold evalComposeFunc, evalOneParamList, evalList;
              unfold g1 at 1 in |- *.
            unfold pred at 1 in |- *.
            repeat rewrite cPairProjections1.
            repeat rewrite evalStrongRecHelp1.
            simpl; repeat rewrite cPairProjections2.
            unfold A; unfold codeOpen in IHn1.
            move g1 after IHn1; fold g1 in IHn1; apply IHn1.
            apply cPairLe2A.
            repeat rewrite cPairProjections2.
            eapply Nat.le_lt_trans; [ idtac | apply cPairLt2 ].
            apply cPairLe2; simpl; apply Compat815.le_lt_n_Sm.
          * specialize (cPairLe2A n1); lia.
    }
    apply H1, le_n.
Qed.

Lemma codeInductionSchemaCorrect3 (f : Formula):
 ~ InductionSchema f -> codeInductionSchema (codeFormula f) = false.
Proof.
  intros H; assert (H0: forall x : bool, x = true \/ x = false) by
   (intros x; destruct x; auto).
  destruct (H0 (codeInductionSchema (codeFormula f))) as [H1 | H1].
  - elim H; now apply codeInductionSchemaCorrect2.
  - assumption.
Qed.

Lemma codeInductionSchemaIsPR : isPRrel 1 codeInductionSchema.
Proof.
  lazy beta delta [codeInductionSchema];
    set (A := fun f : nat => cddddr (cdr (codeOpen f))).
  assert (H: isPR 1 A).
  { unfold A in |- *.
    apply compose1_1IsPR with (g := iterate cPairPi2 5) (f := codeOpen).
    - apply codeOpenIsPR.
    - apply iterateIsPR, cPairPi2IsPR.
  }
  assert
    (H0: isPRrel 1
           (fun f : nat =>
              let n := car (A f) in
              let g := cdr (A f) in
              Nat.eqb
                (codeClose
                   (codeImp (codeSubFormula g n (codeTerm Zero))
                      (codeImp
                         (codeForall n
                            (codeImp g (codeSubFormula g n
                                          (codeTerm (Succ (var n))))))
                         (codeForall n g)))) f)).
  { unfold isPRrel; apply compose1_2IsPR with
      (g := charFunction 2 Nat.eqb)
      (f' := fun f : nat => f)
      (f := fun f : nat =>
              codeClose
                (codeImp
                   (codeSubFormula (cdr (A f)) (car (A f))
                      (codeTerm Zero))
                   (codeImp
                      (codeForall (car (A f))
                         (codeImp (cdr (A f))
                            (codeSubFormula (cdr (A f))
                               (car (A f))
                               (codeTerm (Succ (var (car (A f))))))))
                      (codeForall (car (A f)) (cdr (A f)))))).
    - apply compose1_1IsPR with
        (f := fun f : nat =>
                codeImp
                  (codeSubFormula (cdr (A f)) (car (A f)) (codeTerm Zero))
                  (codeImp
                     (codeForall (car (A f))
                        (codeImp (cdr (A f))
                           (codeSubFormula (cdr (A f))
                              (car (A f))
                              (codeTerm (Succ (var (car (A f))))))))
                     (codeForall (car (A f)) (cdr (A f))))).
      + apply compose1_2IsPR with
          (f := fun f : nat =>
                  codeSubFormula (cdr (A f)) (car (A f)) (codeTerm Zero))
          (f' := fun f : nat =>
                   codeImp
                     (codeForall (car (A f))
                        (codeImp (cdr (A f))
                           (codeSubFormula (cdr (A f))
                              (car (A f))
                              (codeTerm (Succ (var (car (A f))))))))
                     (codeForall (car (A f)) (cdr (A f)))).
        * apply compose1_3IsPR with
            (f1 := fun f : nat => cdr (A f))
            (f2 := fun f : nat => car (A f))
            (f3 := fun f : nat => codeTerm Zero).
          -- apply compose1_1IsPR.
             ++ assumption.
             ++ apply cPairPi2IsPR.
          -- apply compose1_1IsPR.
             assumption.
             apply cPairPi1IsPR.
          -- apply const1_NIsPR.
          -- apply codeSubFormulaIsPR.
        * apply compose1_2IsPR with
            (f := fun f : nat =>
                    codeForall (car (A f))
                      (codeImp (cdr (A f))
                         (codeSubFormula (cdr (A f)) (car (A f))
                            (codeTerm (Succ (var (car (A f))))))))
            (f' := fun f : nat => codeForall (car (A f)) (cdr (A f))).
          -- apply compose1_2IsPR with
               (f := fun f : nat => car (A f))
               (f' := fun f : nat =>
                        codeImp (cdr (A f))
                          (codeSubFormula (cdr (A f)) (car (A f))
                             (codeTerm (Succ (var (car (A f))))))).
             ++ apply compose1_1IsPR.
                assumption.
                apply cPairPi1IsPR.
             ++ apply compose1_2IsPR with
                  (f := fun f : nat => cdr (A f))
                  (f' := fun f : nat =>
                           codeSubFormula (cdr (A f)) (car (A f))
                             (codeTerm (Succ (var (car (A f)))))).
                ** apply compose1_1IsPR.
                   assumption.
                   apply cPairPi2IsPR.
                ** apply compose1_3IsPR with
                     (f1 := fun f : nat => cdr (A f))
                     (f2 := fun f : nat => car (A f))
                     (f3 := fun f : nat => codeTerm (Succ (var (car (A f))))).
                   apply compose1_1IsPR.
                   assumption.
                   apply cPairPi2IsPR.
                   apply compose1_1IsPR.
                   assumption.
                   apply cPairPi1IsPR.
                   assert
                     (H0: isPR 1
                            (fun f : nat =>
                               cPair 3 (S (cPair (cPair 0 (car (A f))) 0)))).
                   { apply compose1_2IsPR with
                       (f := fun f : nat => 3)
                       (f' := fun f : nat => S (cPair (cPair 0 (car (A f))) 0)).
                     - apply const1_NIsPR.
                     - apply compose1_1IsPR with
                         (f := fun f : nat => cPair (cPair 0 (car (A f))) 0).
                       + apply compose1_2IsPR with
                           (f := fun f : nat => cPair 0 (car (A f)))
                           (f' := fun f : nat => 0).
                         * apply compose1_2IsPR with
                             (f := fun f : nat => 0)
                             (f' := fun f : nat => car (A f)).
                           -- apply const1_NIsPR.
                           -- apply compose1_1IsPR.
                              assumption.
                              apply cPairPi1IsPR.
                           -- apply cPairIsPR.
                         * apply const1_NIsPR.
                         * apply cPairIsPR.
                       + apply succIsPR.
                     - apply cPairIsPR.
                   }
                   destruct H0 as (x, p).
                   exists x.
                   eapply extEqualTrans.
                   apply p.
                   simpl in |- *.
                   intros c; reflexivity.
                   apply codeSubFormulaIsPR.
                ** apply codeImpIsPR.
             ++ apply codeForallIsPR.
          -- apply compose1_2IsPR  with
               (f := fun f : nat => car (A f))
               (f' := fun f : nat => cdr (A f)).
             ++ apply compose1_1IsPR.
                assumption.
                apply cPairPi1IsPR.
             ++ apply compose1_1IsPR.
                assumption.
                apply cPairPi2IsPR.
             ++ apply codeForallIsPR.
          -- apply codeImpIsPR.
        * apply codeImpIsPR.
      + apply codeCloseIsPR.
    - apply idIsPR.
    - apply eqIsPR.
  }
  apply H0.
Qed.

Definition codePA : nat -> bool :=
  orRel 1 (Nat.eqb (codeFormula PA6))
    (orRel 1 (Nat.eqb (codeFormula PA5))
       (orRel 1 (Nat.eqb (codeFormula PA4))
          (orRel 1 (Nat.eqb (codeFormula PA3))
             (orRel 1 (Nat.eqb (codeFormula PA2))
                (orRel 1 (Nat.eqb (codeFormula PA1))
                   codeInductionSchema))))).

Lemma codePAcorrect1 (f : Formula):
 codePA (codeFormula f) = true -> mem Formula PA f.
Proof.
  intros H; destruct (PAdec f) as [H0 | H0].
  - assumption.
  - unfold codePA, orRel, nat_rec, nat_rect in H.
    unfold PA; destruct (eq_nat_dec (codeFormula PA6) (codeFormula f))
      as [a | b].
    + rewrite a, Nat.eqb_refl in H.
      replace f with PA6.
      * right; constructor.
      * eapply codeFormulaInj; apply a.
    + left; rewrite nat_eqb_false in H.
      * clear b.
        destruct (eq_nat_dec (codeFormula PA5) (codeFormula f)) as [a | b].
        -- rewrite a, Nat.eqb_refl in H.
           replace f with PA5.
           ++ right; constructor.
           ++ eapply codeFormulaInj; apply a.
        -- left.
           rewrite nat_eqb_false in H.
           ++ clear b; destruct (eq_nat_dec (codeFormula PA4) (codeFormula f))
                as [a | b].
              ** rewrite a in H.
                 rewrite Nat.eqb_refl in H.
                 replace f with PA4.
                 right; constructor.
                 eapply codeFormulaInj.
                 apply a.
              ** left.
                 rewrite nat_eqb_false in H.
                 clear b.
                 induction (eq_nat_dec (codeFormula PA3) (codeFormula f))
                             as [a | b].
                 rewrite a in H.
                 rewrite Nat.eqb_refl in H.
                 replace f with PA3.
                 right; constructor.
                 eapply codeFormulaInj.
                 apply a.
                 left.
                 rewrite nat_eqb_false in H.
                 clear b.
                 induction (eq_nat_dec (codeFormula PA2) (codeFormula f))
                   as [a | b].
                 rewrite a, Nat.eqb_refl in H.
                 replace f with PA2.
                 right; constructor.
                 eapply codeFormulaInj.
                 apply a.
                 left.
                 rewrite nat_eqb_false in H.
                 clear b.
                 induction (eq_nat_dec (codeFormula PA1) (codeFormula f))
                   as [a | b].
                 rewrite a, Nat.eqb_refl in H.
                 replace f with PA1.
                 right; constructor.
                 eapply codeFormulaInj.
                 apply a.
                 left.
                 rewrite nat_eqb_false in H.
                 apply codeInductionSchemaCorrect2.
                 simpl in H.
                 assumption.
                 assumption.
                 assumption.
                 assumption.
                 assumption.
           ++ assumption.
      * assumption.
Qed.

Lemma codePAcorrect2 (f : Formula):
 ~ mem Formula PA f -> codePA (codeFormula f) = false.
Proof.
  intros H ; assert (H0: forall x : bool, x = true \/ x = false).
  { intros x; destruct x; auto. }
  induction (H0 (codePA (codeFormula f)))  as [H1 | H1].
  - elim H; apply codePAcorrect1; assumption.
  - assumption.
Qed.

Lemma codePAcorrect3 (f : Formula):
  mem Formula PA f -> codePA (codeFormula f) = true.
Proof.
  intros H; unfold codePA, orRel, nat_rec, nat_rect.
  do 6 try induction H.
  - assert (H0: codeInductionSchema (codeFormula x) = true).
    + apply codeInductionSchemaCorrect1, H.
    + rewrite H0; repeat rewrite orb_true_b;
        repeat rewrite orb_b_true; reflexivity.
  - destruct H.
    generalize (codeFormula PA1); intro n.
    rewrite Nat.eqb_refl.
    repeat rewrite orb_true_b; repeat rewrite orb_b_true; reflexivity.
  - generalize (codeFormula PA2); intro n.
    rewrite Nat.eqb_refl.
    repeat rewrite orb_true_b; repeat rewrite orb_b_true; reflexivity.
  - generalize (codeFormula PA3); intros n.
    rewrite Nat.eqb_refl.
    repeat rewrite orb_true_b; repeat rewrite orb_b_true; reflexivity.
  - generalize (codeFormula PA4); intros n.
    rewrite Nat.eqb_refl.
    repeat rewrite orb_true_b; repeat rewrite orb_b_true; reflexivity.
  - generalize (codeFormula PA5); intros n.
    rewrite Nat.eqb_refl.
    repeat rewrite orb_true_b; repeat rewrite orb_b_true; reflexivity.
  - rewrite Nat.eqb_refl.
    repeat rewrite orb_true_b; repeat rewrite orb_b_true; reflexivity.
Qed.

Lemma codePAIsPR : isPRrel 1 codePA.
Proof.
  unfold codePA in |- *.
  assert (H: forall n : nat, isPRrel 1 (Nat.eqb n)).
  { intros n; apply compose1_2IsPR with
      (f := fun f : nat => n)
      (f' := fun f : nat => f)
      (g := charFunction 2 Nat.eqb).
    - apply const1_NIsPR.
    - apply idIsPR.
    - apply eqIsPR.
  }
  repeat apply orRelPR; try apply H.
  apply codeInductionSchemaIsPR.
Qed.

End Code_PA.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.
Require Import Crypto.Util.Notations.
Import ListNotations.

Local Open Scope list_scope.
Local Open Scope Z_scope.

Definition tap := (Z * Z)%type.
Definition taps := list tap.
Declare Scope tap_scope.
Declare Scope taps_scope.
Delimit Scope tap_scope with tap.
Delimit Scope taps_scope with taps.
Bind Scope tap_scope with tap.
Bind Scope taps_scope with taps.

Coercion Z_to_tap (v : Z) : tap := (v, 0).
Coercion tap_to_taps (v : tap) : taps := [v].
Definition make_tap (b e : Z) : tap := (b, e).

Definition scmul_tap (c : Z) (t : tap) : tap
  := let '(c', e) := t in (c * c', e).
Definition neg_tap (t : tap) : tap
  := let '(c, e) := t in (-c, e).
Definition add_taps : taps -> taps -> taps := @List.app _.

Notation "b ^ e" := (make_tap (Z.log2 b) e) : tap_scope.
Notation "2 ^ e" := [(1, e%Z)] (only printing) : tap_scope.
Notation "x * y" := (scmul_tap x y) : tap_scope.
Notation "- a" := (neg_tap a) : tap_scope.

Notation "b ^ e" := (b^e)%tap (only printing) : taps_scope.
Notation "x * y" := (x * y)%tap (only printing) : taps_scope.
Notation "- a" := (-a)%tap (only printing) : taps_scope.
Notation "b ^ e" := (tap_to_taps (b ^ e)) : taps_scope.
Notation "x * y" := (tap_to_taps (x * y)) : taps_scope.
Notation "- a" := (tap_to_taps (-a)) : taps_scope.

Notation "a + b" := (add_taps a b) : taps_scope.
Notation "a - b" := (add_taps a (neg_tap (Z_to_tap (Zpos b)))) : taps_scope.
Notation "a - b" := (add_taps a (- b)) : taps_scope.


Require Export MSetInterface.
Require Export FMapInterface.
Require Export Constr.
Require Export FunctionalExtensionality.
Require Export List.
Require Import Utf8.

Export ListNotations.

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

Module Type SetsTypeOn := MSetInterface.WSetsOn.
Module Type MapsTypeOn := FMapInterface.WSfun.

(*Module Type Solver (Sys : CSysJoinSemiLat) (SStr : SolverStructs (Sys)).
End Solver.*)

Module Defs (Sys : CSysJoinSemiLat).

Module Var := Sys.V.
Module D   := Sys.D.

Section LeqFun.
Variable X : Type.

Definition leqF : relation (X -> D.t)
  := fun f1 f2 => forall x, D.Leq (f1 x) (f2 x).

Definition leqF_refl : reflexive _ leqF.
Proof. now firstorder. Qed.
Hint Resolve leqF_refl.

Definition leqF_antisym : antisymmetric _ leqF.
Proof.
intros f g H H0.
extensionality x.
now apply D.LeqAntisym.
Qed.
Hint Resolve leqF_antisym.

Definition leqF_trans : transitive _ leqF.
Proof.
intros f g h H1 H2 x.
eapply D.LeqTrans; [eapply H1 |]; auto.
Qed.
End LeqFun.
Hint Resolve leqF_trans.

Definition has_uniq_lookup {X} (rhs : X -> Tree Var.t D.t D.t) :=
  forall x, uniq_lookup (rhs x).

Definition is_monotone {X} (rhs : X -> Tree Var.t D.t D.t) :=
  forall x f g, leqF f g -> D.Leq ([[rhs x]]* f) ([[rhs x]]* g).

Definition is_solution (rhs : Var.t -> Tree Var.t D.t D.t) mu
  := forall x, D.Leq ([[rhs x]]* mu) (mu x).

Definition is_min_solution (rhs : Var.t -> Tree Var.t D.t D.t) mu
  := is_solution rhs mu /\
     forall mu', is_solution rhs mu' -> leqF mu mu'.

End Defs.


Notation "[ A ; .. ; B ]" := (cons A ( .. (cons B nil) ..))(at level 70).

Definition const_gn (n : nat) := 7 + 8 * n.
Definition var_gn (n : nat) := 13 + 8 * n.
Definition fun_gn (n m : nat) := 1 + 8 * (Nat.pow 2 n * Nat.pow 3 m).
Definition rel_gn (n m : nat) := 3 + 8 * (Nat.pow 2 n * Nat.pow 3 m).

(* recursive language *)
Inductive Term : Set :=
| Const : (exists n gn, const_gn n = gn) -> Term
| Var : (exists n gn, var_gn n = gn) -> Term
| Func : (exists n m gn, fun_gn n m = gn) -> Term.

Inductive Relation : Set :=
  | Rel : (exists n m gn, rel_gn n m = gn) -> Relation.

Record RecLanguage : Set := L {
  terms : list Term;
  relations : list Relation
}.

Ltac constant n :=
  apply Const; exists n; exists (const_gn n); reflexivity.

Ltac variable n :=
  apply Var; exists n; exists (var_gn n); reflexivity.

Ltac function n m :=
  apply Func; exists n; exists m; exists (fun_gn n m); reflexivity.

Ltac term n m :=
   try constant n; try variable n; try function n m.

Ltac rel n m :=
  apply Rel; exists n; exists m; exists (rel_gn n m); reflexivity.

Section PA.
  Theorem zero : Term. constant 0. Defined.
  Theorem succ : Term. function 1 1. Defined.
  Theorem plus : Term. function 1 2. Defined.
  Theorem mul  : Term. function 2 2. Defined.
  Theorem equality : Relation. rel 1 1. Defined.
  Definition S := L ([zero; succ; plus; mul]) ([equality]).
End PA.

Inductive Formula : Set :=
| Atom : (exists (args : list Term) (n m gn : nat),
             length args = m -> rel_gn n m = gn) -> Formula
| Not : Formula -> Formula
| Forall : (exists n gn : nat, var_gn n = gn) -> Formula
| Exists : (exists n gn : nat, var_gn n = gn) -> Formula
| And : Formula -> Formula -> Formula
| Or : Formula -> Formula -> Formula
| Imp : Formula -> Formula -> Formula.

Ltac atom n ls :=
  apply Atom; exists ls; exists n; exists (length ls);
  exists (rel_gn n (length ls)); intro; reflexivity.

Ltac formula_forall n := apply Forall; exists n; exists (var_gn n); reflexivity.
Ltac formula_exists n := apply Exists; exists n; exists (var_gn n); reflexivity.

Definition Const_Interp {A : Set} (n : nat) (f : nat -> A)
  (_ :exists gn, const_gn n = gn) : A := f n.
Definition Var_Interp {A : Set} (n : nat) (f : nat -> A)
  (_ :exists gn, var_gn n = gn) : A := f n.
Definition Func_Interp {A : Set} (n m : nat) (f : nat -> nat -> A)
  (_ :exists gn, fun_gn n m = gn) : A := f n m.
Definition Rel_Interp {A : Set} (n m : nat) (f : nat -> nat -> A -> Prop)
  (_ :exists gn, rel_gn n m = gn) : A -> Prop := f n m.
Check (Const_Interp _ _).
Record Interpretation : Set := Interp {
  universe : A;
  term_interp :


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype.
Require Import bigop finset fingroup morphism automorphism quotient action.
Require Import gseries.

(******************************************************************************)
(* This files establishes Jordan-Holder theorems for finite groups. These     *)
(* theorems state the uniqueness up to permutation and isomorphism for the    *)
(* series of quotient built from the successive elements of any composition   *)
(* series of the same group. These quotients are also called factors of the   *)
(* composition series. To avoid the heavy use of highly polymorphic lists     *)
(* describing these quotient series, we introduce sections.                   *)
(* This library defines:                                                      *)
(*         (G1 / G2)%sec == alias for the pair (G1, G2) of groups in the same *)
(*                          finGroupType, coerced to the actual quotient group*)
(*                          group G1 / G2. We call this pseudo-quotient a     *)
(*                          section of G1 and G2.                             *)
(*    section_isog s1 s2 == s1 and s2 respectively coerce to isomorphic       *)
(*                          quotient groups.                                  *)
(*        section_repr s == canonical representative of the isomorphism class *)
(*                          of the section s.                                 *)
(*         mksrepr G1 G2 == canonical representative of the isomorphism class *)
(*                          of (G1 / G2)%sec.                                 *)
(*         mkfactors G s == if s is [:: s1, s2, ..., sn], constructs the list *)
(*                     [:: mksrepr G s1, mksrepr s1 s2, ..., mksrepr sn-1 sn] *)
(*             comps G s == s is a composition series for G i.e. s is a       *)
(*                          decreasing sequence of subgroups of G             *)
(*                          in which two adjacent elements are maxnormal one  *)
(*                          in the other and the last element of s is 1.      *)
(* Given aT and rT two finGroupTypes, (D : {group rT}), (A : {group aT}) and  *)
(* (to : groupAction A D) an external action.                                 *)
(*        maxainv to B C == C is a maximal proper normal subgroup of B        *)
(*                          invariant by (the external action of A via) to.   *)
(*          asimple to B == the maximal proper normal subgroup of B invariant *)
(*                          by the external action to is trivial.             *)
(*         acomps to G s == s is a composition series for G invariant by to,  *)
(*                          i.e. s is a decreasing sequence of subgroups of G *)
(*                          in which two adjacent elements are maximally      *)
(*                          invariant by to one in the other and the          *)
(*                          last element of s is 1.                           *)
(* We prove two versions of the result:                                       *)
(*    - JordanHolderUniqueness establishes the uniqueness up to permutation   *)
(*       and isomorphism of the lists of factors in composition series of a   *)
(*       given group.                                                         *)
(*    - StrongJordanHolderUniqueness extends the result to composition series *)
(*       invariant by an external group action.                               *)
(******************************************************************************)

Import GroupScope.

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

Inductive section (gT : finGroupType) := GSection of {group gT} * {group gT}.

Delimit Scope section_scope with sec.
Bind Scope section_scope with section.

Definition mkSec (gT : finGroupType) (G1 G2 : {group gT}) := GSection (G1, G2).

Infix "/" := mkSec : section_scope.

Coercion pair_of_section gT (s : section gT) := let: GSection u := s in u.

Coercion quotient_of_section gT (s : section gT) : GroupSet.sort _ := s.1 / s.2.

Coercion section_group gT (s : section gT) : {group (coset_of s.2)} :=
  Eval hnf in [group of s].

Section Sections.

Variables (gT : finGroupType).
Implicit Types (G : {group gT}) (s : section gT).

Canonical section_subType := Eval hnf in [newType for @pair_of_section gT].
Definition section_eqMixin := Eval hnf in [eqMixin of section gT by <:].
Canonical section_eqType := Eval hnf in EqType (section gT) section_eqMixin.
Definition section_choiceMixin := [choiceMixin of section gT by <:].
Canonical section_choiceType :=
  Eval hnf in ChoiceType (section gT) section_choiceMixin.
Definition section_countMixin := [countMixin of section gT by <:].
Canonical section_countType :=
  Eval hnf in CountType (section gT) section_countMixin.
Canonical section_subCountType := Eval hnf in [subCountType of section gT].
Definition section_finMixin := [finMixin of section gT by <:].
Canonical section_finType := Eval hnf in FinType (section gT) section_finMixin.
Canonical section_subFinType := Eval hnf in [subFinType of section gT].
Canonical section_group.

(* Isomorphic sections *)

Definition section_isog := [rel x y : section gT | x \isog y].

(* A witness of the isomorphism class of a section *)
Definition section_repr s := odflt (1 / 1)%sec (pick (section_isog ^~ s)).

Definition mksrepr G1 G2 := section_repr (mkSec G1 G2).

Lemma section_reprP s : section_repr s \isog s.
Proof.
by rewrite /section_repr; case: pickP => //= /(_ s); rewrite isog_refl.
Qed.

Lemma section_repr_isog s1 s2 :
  s1 \isog s2 -> section_repr s1 = section_repr s2.
Proof.
by move=> iso12; congr (odflt _ _); apply: eq_pick => s; exact: isog_transr.
Qed.

Definition mkfactors (G : {group gT}) (s : seq {group gT}) :=
  map section_repr (pairmap (@mkSec _) G s).

End Sections.

Section CompositionSeries.

Variable gT : finGroupType.
Local Notation gTg := {group gT}.
Implicit Types (G : gTg) (s : seq gTg).

Local Notation compo := [rel x y : {set gT} | maxnormal y x x].

Definition comps G s := ((last G s) == 1%G) && compo.-series G s.

Lemma compsP G s :
  reflect (last G s = 1%G /\  path [rel x y : gTg | maxnormal y x x] G s)
          (comps G s).
Proof. by apply: (iffP andP) => [] [/eqP]. Qed.

Lemma trivg_comps G s : comps G s -> (G :==: 1) = (s == [::]).
Proof.
case/andP=> ls cs; apply/eqP/eqP=> [G1 | s1]; last first.
  by rewrite s1 /= in ls; apply/eqP.
by case: s {ls} cs => //= H s /andP[/maxgroupp]; rewrite G1 /proper sub1G andbF.
Qed.

Lemma comps_cons G H s : comps G (H :: s) -> comps H s.
Proof. by case/andP => /= ls /andP[_]; rewrite /comps ls. Qed.

Lemma simple_compsP G s : comps G s -> reflect (s = [:: 1%G]) (simple G).
Proof.
move=> cs; apply: (iffP idP) => [|s1]; last first.
  by rewrite s1 /comps eqxx /= andbT -simple_maxnormal in cs.
case: s cs => [/trivg_comps/eqP-> | H s]; first by case/simpleP; rewrite eqxx.
rewrite [comps _ _]andbCA /= => /andP[/maxgroupp maxH /trivg_comps/esym nil_s].
rewrite simple_maxnormal => /maxgroupP[_ simG].
have H1: H = 1%G by apply/val_inj/simG; rewrite // sub1G.
by move: nil_s; rewrite H1 eqxx => /eqP->.
Qed.

Lemma exists_comps (G : gTg) : exists s, comps G s.
Proof.
elim: {G} #|G| {1 3}G (leqnn #|G|) => [G | n IHn G cG].
  by rewrite leqNgt cardG_gt0.
have [sG | nsG] := boolP (simple G).
  by exists [:: 1%G]; rewrite /comps eqxx /=  -simple_maxnormal andbT.
have [-> | ntG] := eqVneq G 1%G; first by exists [::]; rewrite /comps eqxx.
have [N maxN] := ex_maxnormal_ntrivg ntG.
have [|s /andP[ls cs]] := IHn N.
  by rewrite -ltnS (leq_trans _ cG) // proper_card // (maxnormal_proper maxN).
by exists (N :: s); exact/and3P.
Qed.

(******************************************************************************)
(* The factors associated to two composition series of the same group are     *)
(* the same up to isomorphism and permutation                                 *)
(******************************************************************************)

Lemma JordanHolderUniqueness (G : gTg) (s1 s2 : seq gTg) :
  comps G s1 -> comps G s2 -> perm_eq (mkfactors G s1) (mkfactors G s2).
Proof.
elim: {G}#|G| {-2}G (leqnn #|G|) => [|n Hi] G cG in s1 s2 * => cs1 cs2.
  by rewrite leqNgt cardG_gt0 in cG.
have [G1 | ntG] := boolP (G :==: 1).
  have -> : s1 = [::] by apply/eqP; rewrite -(trivg_comps cs1).
  have -> : s2 = [::] by apply/eqP; rewrite -(trivg_comps cs2).
  by rewrite /= perm_eq_refl.
have [sG | nsG] := boolP (simple G).
  by rewrite (simple_compsP cs1 sG) (simple_compsP cs2 sG) perm_eq_refl.
case es1: s1 cs1 => [|N1 st1] cs1.
  by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG.
case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}.
  by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG.
case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1.
case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2.
have cN1 : #|N1| <= n.
  by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxnormal_proper maxN_1).
have cN2 : #|N2| <= n.
  by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxnormal_proper maxN_2).
case: (N1 =P N2) {s2 es2} => [eN12 |].
  by rewrite eN12 /= perm_cons Hi // /comps ?lst2 //= -eN12 lst1.
move/eqP; rewrite -val_eqE /=; move/eqP=> neN12.
have nN1G : N1 <| G by apply: maxnormal_normal.
have nN2G : N2 <| G by apply: maxnormal_normal.
pose N := (N1 :&: N2)%G.
have nNG : N <| G.
  by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm.
have iso1 : (G / N1)%G \isog (N2 / N)%G.
  rewrite isog_sym /= -(maxnormalM maxN_1 maxN_2) //.
  rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm.
have iso2 : (G / N2)%G \isog (N1 / N)%G.
  rewrite isog_sym /= -(maxnormalM maxN_1 maxN_2) // setIC.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm.
have [sN /andP[lsN csN]] := exists_comps N.
have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1)
                  [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]).
  apply: Hi=> //; rewrite /comps ?lst1 //= lsN csN andbT /=.
  rewrite -quotient_simple.
    by rewrite -(isog_simple iso2) quotient_simple.
  by rewrite (normalS (subsetIl N1 N2) (normal_sub nN1G)).
have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2)
                  [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]).
  apply: Hi=> //; rewrite /comps ?lst2 //= lsN csN andbT /=.
  rewrite -quotient_simple.
    by rewrite -(isog_simple iso1) quotient_simple.
  by rewrite (normalS (subsetIr N1 N2) (normal_sub nN2G)).
pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
have i3 : perm_eq fG1 fG2.
  rewrite (@perm_catCA _ [::_] [::_]) /mksrepr.
  rewrite (@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso1).
  rewrite -(@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso2).
  exact: perm_eq_refl.
apply: (perm_eq_trans i1); apply: (perm_eq_trans i3); rewrite perm_eq_sym.
apply: perm_eq_trans i2; exact: perm_eq_refl.
Qed.

End CompositionSeries.

(******************************************************************************)
(* Helper lemmas for group actions.                                           *)
(******************************************************************************)

Section MoreGroupAction.

Variables (aT rT : finGroupType).
Variables (A : {group aT}) (D : {group rT}).
Variable to : groupAction A D.

Lemma gactsP (G : {set rT}) : reflect {acts A, on G | to} [acts A, on G | to].
Proof.
apply: (iffP idP) => [nGA x|nGA]; first exact: acts_act.
apply/subsetP=> a Aa; rewrite !inE; rewrite Aa.
by  apply/subsetP=> x; rewrite inE nGA.
Qed.

Lemma gactsM (N1 N2 : {set rT}) :
    N1 \subset D -> N2 \subset D ->
  [acts A, on N1 | to] -> [acts A, on N2 | to] -> [acts A, on N1 * N2 | to].
Proof.
move=> sN1D sN2D aAN1 aAN2; apply/gactsP=> x Ax y.
apply/idP/idP; case/mulsgP=> y1 y2 N1y1 N2y2 e.
  move: (actKin to Ax y); rewrite e; move<-.
  rewrite gactM ?groupV ?(subsetP sN1D y1) ?(subsetP sN2D) //.
  by apply: mem_mulg; rewrite ?(gactsP _ aAN1) ?(gactsP _ aAN2) // groupV.
rewrite e gactM // ?(subsetP sN1D y1) ?(subsetP sN2D) //.
by apply: mem_mulg; rewrite ?(gactsP _ aAN1) // ?(gactsP _ aAN2).
Qed.

Lemma gactsI (N1 N2 : {set rT}) :
  [acts A, on N1 | to] -> [acts A, on N2 | to] -> [acts A, on N1 :&: N2 | to].
Proof.
move=> aAN1 aAN2.
apply/subsetP=> x Ax; rewrite !inE Ax /=; apply/subsetP=> y Ny; rewrite inE.
case/setIP: Ny=> N1y N2y; rewrite inE ?astabs_act  ?N1y ?N2y //.
- by move/subsetP: aAN2; move/(_ x Ax).
- by move/subsetP: aAN1; move/(_ x Ax).
Qed.

Lemma gastabsP (S : {set rT}) (a : aT) :
  a \in A -> reflect (forall x, (to x a \in S) = (x \in S)) (a \in 'N(S | to)).
Proof.
move=> Aa; apply: (iffP idP) => [nSa x|nSa]; first exact: astabs_act.
by rewrite !inE Aa; apply/subsetP=> x; rewrite inE nSa.
Qed.

End MoreGroupAction.

(******************************************************************************)
(* Helper lemmas for quotient actions.                                        *)
(******************************************************************************)

Section MoreQuotientAction.

Variables (aT rT : finGroupType).
Variables (A : {group aT})(D : {group rT}).
Variable to : groupAction A D.

Lemma qact_dom_doms (H : {group rT}) : H \subset D -> qact_dom to H \subset A.
Proof.
by move=> sHD; apply/subsetP=> x; rewrite qact_domE // inE; case/andP.
Qed.

Lemma acts_qact_doms (H : {group rT}) :
  H \subset D -> [acts A, on H | to] -> qact_dom to H :=: A.
Proof.
move=> sHD aH; apply/eqP; rewrite eqEsubset; apply/andP.
split; first exact: qact_dom_doms.
apply/subsetP=> x Ax; rewrite qact_domE //; apply/gastabsP=> //.
by move/gactsP: aH; move/(_ x Ax).
Qed.

Lemma qacts_cosetpre (H : {group rT}) (K' : {group coset_of H}) :
    H \subset D -> [acts A, on H | to] ->
    [acts qact_dom to H, on K' | to / H] ->
  [acts A, on coset H @*^-1 K' | to].
Proof.
move=> sHD aH aK'; apply/subsetP=> x Ax; move: (Ax) (subsetP aK').
rewrite -{1}(acts_qact_doms sHD aH) => qdx; move/(_ x qdx) => nx.
rewrite !inE Ax; apply/subsetP=> y; case/morphpreP=> Ny /= K'Hy; rewrite inE.
apply/morphpreP; split; first by rewrite acts_qact_dom_norm.
by move/gastabsP: nx; move/(_  qdx (coset H y)); rewrite K'Hy qactE.
Qed.

Lemma qacts_coset (H K : {group rT}) :
    H \subset D -> [acts A, on K | to] ->
  [acts qact_dom to H, on (coset H) @* K | to / H].
Proof.
move=> sHD aK.
apply/subsetP=> x qdx; rewrite inE qdx inE; apply/subsetP=> y.
case/morphimP=> z Nz Kz /= e; rewrite e inE qactE // mem_imset // inE.
move/gactsP: aK; move/(_ x (subsetP (qact_dom_doms sHD) _ qdx) z); rewrite Kz.
move->; move/acts_act: (acts_qact_dom to H); move/(_ x qdx z).
by rewrite Nz andbT.
Qed.

End MoreQuotientAction.

Section StableCompositionSeries.

Variables (aT rT : finGroupType).
Variables (D : {group rT})(A : {group aT}).
Variable to : groupAction A D.

Definition maxainv (B C : {set rT}) :=
  [max C of H |
    [&& (H <| B), ~~ (B \subset H) & [acts A, on H | to]]].

Section MaxAinvProps.

Variables K N : {group rT}.

Lemma maxainv_norm : maxainv K N -> N <| K.
Proof. by move/maxgroupp; case/andP. Qed.

Lemma maxainv_proper : maxainv K N -> N \proper K.
Proof.
by move/maxgroupp; case/andP; rewrite properE; move/normal_sub->; case/andP.
Qed.

Lemma maxainv_sub : maxainv K N -> N \subset K.
Proof. move=> h; apply: proper_sub; exact: maxainv_proper. Qed.

Lemma maxainv_ainvar : maxainv K N -> A \subset 'N(N | to).
Proof. by move/maxgroupp; case/and3P. Qed.

Lemma maxainvS : maxainv K N -> N \subset K.
Proof. by move=> pNN; rewrite proper_sub // maxainv_proper. Qed.

Lemma maxainv_exists : K :!=: 1 -> {N : {group rT} | maxainv K N}.
Proof.
move=> nt; apply: ex_maxgroup. exists [1 rT]%G.
rewrite /= normal1 subG1 nt /=.
apply/subsetP=> a Da; rewrite !inE Da /= sub1set !inE.
by rewrite /= -actmE // morph1 eqxx.
Qed.

End MaxAinvProps.

Lemma maxainvM (G H K : {group rT}) :
    H \subset D -> K \subset D -> maxainv G H -> maxainv G K ->
  H :<>: K -> H * K = G.
Proof.
move: H K => N1 N2 sN1D sN2D pmN1 pmN2 neN12.
have cN12 : commute N1 N2.
  apply: normC; apply: (subset_trans (maxainv_sub pmN1)).
  by rewrite normal_norm ?maxainv_norm.
wlog nsN21 : G N1 N2 sN1D sN2D pmN1 pmN2 neN12 cN12/ ~~(N1 \subset N2).
  move/eqP: (neN12); rewrite eqEsubset negb_and; case/orP=> ns; first by apply.
  by rewrite cN12; apply=> //; apply: sym_not_eq.
have nP : N1 * N2 <| G by rewrite normalM ?maxainv_norm.
have sN2P : N2 \subset N1 * N2 by rewrite mulg_subr ?group1.
case/maxgroupP: (pmN1); case/andP=> nN1G pN1G mN1.
case/maxgroupP: (pmN2); case/andP=> nN2G pN2G mN2.
case/andP: pN1G=> nsGN1 ha1; case/andP: pN2G=> nsGN2 ha2.
case e : (G \subset N1 * N2).
  by apply/eqP; rewrite eqEsubset e mulG_subG !normal_sub.
have: N1 <*> N2 = N2 by apply: mN2; rewrite /= ?comm_joingE // nP e /= gactsM.
by rewrite comm_joingE // => h; move: nsN21; rewrite -h mulg_subl.
Qed.

Definition asimple (K : {set rT}) := maxainv K 1.

Implicit Types (H K : {group rT}) (s : seq {group rT}).

Lemma asimpleP K :
  reflect [/\ K :!=: 1
            & forall H, H <| K -> [acts A, on H | to] -> H :=: 1 \/ H :=: K]
          (asimple K).
Proof.
apply: (iffP idP).
  case/maxgroupP; rewrite normal1 /=; case/andP=> nsK1 aK H1.
  rewrite eqEsubset negb_and nsK1 /=; split => // H nHK ha.
  case eHK : (H :==: K); first by right; apply/eqP.
  left; apply: H1; rewrite ?sub1G // nHK; move/negbT: eHK.
  by rewrite eqEsubset negb_and normal_sub //=; move->.
case=> ntK h; apply/maxgroupP; split.
  move: ntK; rewrite eqEsubset sub1G andbT normal1; move->.
  apply/subsetP=> a Da; rewrite !inE Da /= sub1set !inE.
  by rewrite /= -actmE // morph1 eqxx.
move=> H /andP[nHK /andP[nsKH ha]] _.
case: (h _ nHK ha)=> // /eqP; rewrite eqEsubset.
by rewrite (negbTE nsKH) andbF.
Qed.

Definition acomps K s :=
  ((last K s) == 1%G) && path [rel x y : {group rT} | maxainv x y] K s.

Lemma acompsP K s :
  reflect (last K s = 1%G /\  path [rel x y : {group rT} | maxainv x y] K s)
          (acomps K s).
Proof. by apply: (iffP andP); case; move/eqP. Qed.

Lemma trivg_acomps K s : acomps K s -> (K :==: 1) = (s == [::]).
Proof.
case/andP=> ls cs; apply/eqP/eqP; last first.
  by move=> se; rewrite se /= in ls; apply/eqP.
move=> G1; case: s ls cs => // H s _ /=; case/andP; case/maxgroupP.
by rewrite G1 sub1G andbF.
Qed.

Lemma acomps_cons K H s : acomps K (H :: s) -> acomps H s.
Proof. by case/andP => /= ls; case/andP=> _ p; rewrite /acomps ls. Qed.

Lemma asimple_acompsP K s : acomps K s -> reflect (s = [:: 1%G]) (asimple K).
Proof.
move=> cs; apply: (iffP idP); last first.
  by move=> se; move: cs; rewrite se /=; case/andP=> /=; rewrite andbT.
case: s cs.
  by rewrite /acomps /= andbT; move/eqP->; case/asimpleP; rewrite eqxx.
move=> H s cs sG; apply/eqP.
rewrite eqseq_cons -(trivg_acomps (acomps_cons cs)) andbC andbb.
case/acompsP: cs => /= ls; case/andP=> mH ps.
case/maxgroupP: sG; case/and3P => _ ntG _ ->; rewrite ?sub1G //.
rewrite (maxainv_norm mH); case/andP: (maxainv_proper mH)=> _ ->.
exact: (maxainv_ainvar mH).
Qed.

Lemma exists_acomps K : exists s, acomps K s.
Proof.
elim: {K} #|K| {1 3}K (leqnn #|K|) => [K | n Hi K cK].
  by rewrite leqNgt cardG_gt0.
case/orP: (orbN (asimple K)) => [sK | nsK].
  by exists [:: (1%G : {group rT})]; rewrite /acomps eqxx /= andbT.
case/orP: (orbN (K :==: 1))=> [tK | ntK].
  by exists (Nil _); rewrite /acomps /= andbT.
case: (maxainv_exists ntK)=> N pmN.
have cN: #|N| <= n.
  by rewrite -ltnS (leq_trans _ cK) // proper_card // (maxainv_proper pmN).
case: (Hi _ cN)=> s; case/andP=> lasts ps; exists [:: N & s]; rewrite /acomps.
by rewrite last_cons lasts /= pmN.
Qed.

End StableCompositionSeries.

Arguments Scope maxainv
   [_ _ Group_scope Group_scope groupAction_scope group_scope group_scope].
Arguments Scope asimple
  [_ _ Group_scope Group_scope groupAction_scope group_scope].

Section StrongJordanHolder.

Section AuxiliaryLemmas.

Variables aT rT : finGroupType.
Variables (A : {group aT}) (D : {group rT}) (to : groupAction A D).

Lemma maxainv_asimple_quo (G H : {group rT}) :
   H \subset D -> maxainv to G H -> asimple (to / H) (G / H).
Proof.
move=> sHD /maxgroupP[/and3P[nHG pHG aH] Hmax].
apply/asimpleP; split; first by rewrite -subG1 quotient_sub1 ?normal_norm.
move=> K' nK'Q aK'.
have: (K' \proper (G / H)) || (G / H == K').
  by rewrite properE eqEsubset andbC (normal_sub nK'Q) !andbT orbC orbN.
case/orP=> [ pHQ | eQH]; last by right; apply sym_eq; apply/eqP.
left; pose K := ((coset H) @*^-1 K')%G.
have eK'I : K' \subset (coset H) @* 'N(H).
  by rewrite (subset_trans (normal_sub nK'Q)) ?morphimS ?normal_norm.
have eKK' : K' :=: K / H by rewrite /(K / H) morphpreK //=.
suff eKH : K :=: H by rewrite -trivg_quotient eKK' eKH.
have sHK : H \subset K by rewrite -ker_coset kerE morphpreS // sub1set group1.
apply: Hmax => //; apply/and3P; split; last exact: qacts_cosetpre.
  by rewrite -(quotientGK nHG) cosetpre_normal.
by move: (proper_subn pHQ); rewrite sub_morphim_pre ?normal_norm.
Qed.

Lemma asimple_quo_maxainv (G H : {group rT}) :
    H \subset D -> G \subset D -> [acts A, on G | to] -> [acts A, on H | to] ->
    H <| G -> asimple (to / H) (G / H) ->
  maxainv to G H.
Proof.
move=> sHD sGD aG aH nHG /asimpleP[ntQ maxQ]; apply/maxgroupP; split.
  by rewrite nHG -quotient_sub1 ?normal_norm // subG1 ntQ.
move=> K /and3P[nKG nsGK aK] sHK.
pose K' := (K / H)%G.
have K'dQ : K' <| (G / H)%G by apply: morphim_normal.
have nKH : H <| K by rewrite (normalS _ _ nHG) // normal_sub.
have: K' :=: 1%G \/ K' :=: (G / H).
  apply: (maxQ K' K'dQ) => /=.
  apply/subsetP=> x Adx. rewrite inE Adx /= inE. apply/subsetP=> y.
  rewrite quotientE; case/morphimP=> z Nz Kz ->; rewrite /= !inE qactE //.
  have ntoyx :  to z x \in 'N(H) by  rewrite (acts_qact_dom_norm Adx).
  apply/morphimP; exists (to z x) => //.
  suff h: qact_dom to H \subset A.
    by rewrite astabs_act // (subsetP aK) //; apply: (subsetP h).
  by apply/subsetP=> t; rewrite qact_domE // inE; case/ andP.
case; last first.
  move/quotient_injG; rewrite !inE /=; move/(_ nKH nHG)=> c; move: nsGK.
  by rewrite c subxx.
rewrite /= -trivg_quotient; move=> tK'; apply:(congr1 (@gval _)); move: tK'.
by apply: (@quotient_injG _ H); rewrite ?inE /= ?normal_refl.
Qed.

Lemma asimpleI (N1 N2 : {group rT}) :
    N2 \subset 'N(N1) -> N1 \subset D ->
    [acts A, on N1 | to] -> [acts A, on N2 | to] ->
    asimple (to / N1) (N2 / N1) ->
  asimple (to / (N2 :&: N1)) (N2 / (N2 :&: N1)).
Proof.
move=> nN21 sN1D aN1 aN2 /asimpleP[ntQ1 max1].
have [f1 [f1e f1ker f1pre f1im]] := restrmP (coset_morphism N1) nN21.
have hf2' : N2 \subset 'N(N2 :&: N1) by apply: normsI => //; rewrite normG.
have hf2'' : 'ker (coset (N2 :&: N1)) \subset 'ker f1.
  by rewrite f1ker !ker_coset.
pose f2 := factm_morphism  hf2'' hf2'.
apply/asimpleP; split.
   rewrite /= setIC; apply/negP; move: (second_isog nN21); move/isog_eq1->.
   by apply/negP.
move=> H nHQ2 aH; pose K := f2 @* H.
have nKQ1 : K <| N2 / N1.
  rewrite (_ : N2 / N1 = f2 @* (N2 / (N2 :&: N1))) ?morphim_normal //.
  by rewrite morphim_factm f1im.
have sqA : qact_dom to N1 \subset A.
  by apply/subsetP=> t; rewrite qact_domE // inE; case/andP.
have nNN2 : (N2 :&: N1) <| N2.
  rewrite /normal subsetIl; apply: normsI => //; exact: normG.
have aKQ1 : [acts qact_dom to N1, on K | to / N1].
  pose H':= coset (N2 :&: N1)@*^-1 H.
  have eHH' : H :=: H' / (N2 :&: N1) by rewrite cosetpreK.
  have -> : K :=: f1 @* H' by rewrite /K eHH' morphim_factm.
  have sH'N2 : H' \subset N2.
    rewrite /H' eHH' quotientGK ?normal_cosetpre //=.
    by rewrite sub_cosetpre_quo ?normal_sub.
  have -> : f1 @* H' = coset N1 @* H' by rewrite f1im //=.
  apply: qacts_coset => //; apply: qacts_cosetpre => //; last exact: gactsI.
  by apply: (subset_trans (subsetIr _ _)).
have injf2 : 'injm f2.
  by rewrite ker_factm f1ker /= ker_coset /= subG1 /= -quotientE trivg_quotient.
have iHK : H \isog K.
  apply/isogP; pose f3 := restrm_morphism (normal_sub nHQ2) f2.
  by exists f3; rewrite 1?injm_restrm // morphim_restrm setIid.
case: (max1 _ nKQ1 aKQ1).
  by move/eqP; rewrite -(isog_eq1 iHK); move/eqP->; left.
move=> he /=; right; apply/eqP; rewrite eqEcard normal_sub //=.
move: (second_isog nN21); rewrite setIC; move/card_isog->; rewrite -he.
by move/card_isog: iHK=> <-; rewrite leqnn.
Qed.

End AuxiliaryLemmas.

Variables (aT rT : finGroupType).
Variables (A : {group aT}) (D : {group rT}) (to : groupAction A D).

(******************************************************************************)
(* The factors associated to two A-stable composition series of the same      *)
(* group are the same up to isomorphism and permutation                       *)
(******************************************************************************)

Lemma StrongJordanHolderUniqueness (G : {group rT}) (s1 s2 : seq {group rT}) :
    G \subset D -> acomps to G s1 -> acomps to G s2 ->
  perm_eq (mkfactors G s1) (mkfactors G s2).
Proof.
elim: {G} #|G| {-2}G (leqnn #|G|) => [|n Hi] G cG in s1 s2 * => hsD cs1 cs2.
  by rewrite leqNgt cardG_gt0 in cG.
case/orP: (orbN (G :==: 1)) => [tG | ntG].
  have -> : s1 = [::] by apply/eqP; rewrite -(trivg_acomps cs1).
  have -> : s2 = [::] by apply/eqP; rewrite -(trivg_acomps cs2).
  by rewrite /= perm_eq_refl.
case/orP: (orbN (asimple to G))=> [sG | nsG].
  have -> : s1 = [:: 1%G ] by apply/(asimple_acompsP cs1).
  have -> : s2 = [:: 1%G ] by apply/(asimple_acompsP cs2).
  by rewrite /= perm_eq_refl.
case es1: s1 cs1 => [|N1 st1] cs1.
  by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG.
case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}.
  by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG.
case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1.
case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2.
have sN1D : N1 \subset D.
  by apply: subset_trans hsD; apply: maxainv_sub maxN_1.
have sN2D : N2 \subset D.
  by apply: subset_trans hsD; apply: maxainv_sub maxN_2.
have cN1 : #|N1| <= n.
  by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxainv_proper maxN_1).
have cN2 : #|N2| <= n.
  by rewrite -ltnS (leq_trans _ cG) ?proper_card ?(maxainv_proper maxN_2).
case: (N1 =P N2) {s2 es2} => [eN12 |].
  by rewrite eN12 /= perm_cons Hi // /acomps ?lst2 //= -eN12 lst1.
move/eqP; rewrite -val_eqE /=; move/eqP=> neN12.
have nN1G : N1 <| G by apply: (maxainv_norm maxN_1).
have nN2G : N2 <| G by apply: (maxainv_norm maxN_2).
pose N := (N1 :&: N2)%G.
have nNG : N <| G.
  by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm.
have iso1 : (G / N1)%G \isog (N2 / N)%G.
  rewrite isog_sym /= -(maxainvM _ _ maxN_1 maxN_2) //.
  rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm.
have iso2 : (G / N2)%G \isog (N1 / N)%G.
  rewrite isog_sym /= -(maxainvM _ _ maxN_1 maxN_2) // setIC.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm.
case: (exists_acomps to N)=> sN; case/andP=> lsN csN.
have aN1 : [acts A, on N1 | to].
  by case/maxgroupP: maxN_1; case/and3P.
have aN2 : [acts A, on N2 | to].
  by case/maxgroupP: maxN_2; case/and3P.
have nNN1 : N <| N1.
  by apply: (normalS _ _ nNG); rewrite ?subsetIl ?normal_sub.
have nNN2 : N <| N2.
  by apply: (normalS _ _ nNG); rewrite ?subsetIr ?normal_sub.
have aN : [ acts A, on N1 :&: N2 | to].
  apply/subsetP=> x Ax; rewrite !inE Ax /=; apply/subsetP=> y Ny; rewrite inE.
  case/setIP: Ny=> N1y N2y. rewrite inE ?astabs_act  ?N1y ?N2y //.
    by move/subsetP: aN2; move/(_ x Ax).
  by move/subsetP: aN1; move/(_ x Ax).
have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1)
                  [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]).
  apply: Hi=> //; rewrite /acomps ?lst1 //= lsN csN andbT /=.
  apply: asimple_quo_maxainv=> //; first by apply: subIset; rewrite sN1D.
  apply: asimpleI => //.
    apply: subset_trans (normal_norm nN2G); exact: normal_sub.
  rewrite -quotientMidl (maxainvM _ _ maxN_2) //.
    by apply: maxainv_asimple_quo.
  by move=> e; apply: neN12.
have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2)
                  [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]).
  apply: Hi=> //; rewrite /acomps ?lst2 //= lsN csN andbT /=.
  apply: asimple_quo_maxainv=> //; first by apply: subIset; rewrite sN1D.
  have e : N1 :&: N2 :=: N2 :&: N1 by rewrite setIC.
  rewrite (group_inj (setIC N1 N2)); apply: asimpleI => //.
    apply: subset_trans (normal_norm nN1G); exact: normal_sub.
  rewrite -quotientMidl (maxainvM _ _ maxN_1) //.
  exact: maxainv_asimple_quo.
pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
have i3 : perm_eq fG1 fG2.
  rewrite (@perm_catCA _ [::_] [::_]) /mksrepr.
  rewrite (@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso1).
  rewrite -(@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso2).
  exact: perm_eq_refl.
apply: (perm_eq_trans i1); apply: (perm_eq_trans i3); rewrite perm_eq_sym.
apply: perm_eq_trans i2; exact: perm_eq_refl.
Qed.

End StrongJordanHolder.


(*************************************************************************)
(** * Definition of STLC *)
(*************************************************************************)

(** This file containes all of the definitions for a locally-nameless
    representation of a Curry-Style simply-typed lambda calculus.

    This file was generated via Ott from `stlc.ott` and then edited to
    include explanation about the definitions. As a result, it is gathers
    all of the STLC definitions in one place, but the associated exercises
    are found elsewhere in the tutorial.  You'll want to refer back to
    this file as you progress through the rest of the material. *)

Require Import Metalib.Metatheory.

(*************************************************************************)
(** * Syntax of STLC *)
(*************************************************************************)

(** We use a locally nameless representation for the simply-typed lambda
    calculus, where bound variables are represented as natural numbers (de
    Bruijn indices) and free variables are represented as [atom]s.

    The type [atom], defined in the Metatheory library, represents names.
    Equality on names is decidable, and it is possible to generate an atom
    fresh for any given finite set of atoms ([atom_fresh]).

    Note: the type [var] is notation for [atom].
*)

Inductive typ : Set :=  (*r types *)
 | typ_base : typ
 | typ_nat : typ
 | typ_arrow (T1:typ) (T2:typ)
 | typ_mult (T1:typ) (T2:typ).

Inductive exp : Set :=  (*r expressions *)
 | var_b (_:nat)
 | var_f (x:var)
 | num (n:nat)
 | abs (e:exp)
 | app (e1:exp) (e2:exp)
 | pair (e1:exp) (e2:exp)
 | proj1 (e:exp)
 | proj2 (e:exp).

 Definition heap : Set := list (var * exp).

 Definition program : Set := (heap * exp).

(*************************************************************************)
(** * Substitution *)
(*************************************************************************)

(** Substitution replaces a free variable with a term.  The definition
    below is simple for two reasons:
      - Because bound variables are represented using indices, there
        is no need to worry about variable capture.
      - We assume that the term being substituted in is locally
        closed.  Thus, there is no need to shift indices when
        passing under a binder.
*)

(** The [Fixpoint] keyword defines a Coq function.  As all functions in Coq
    must be total.  The annotation [{struct e}] indicates the termination
    metric---all recursive calls in this definition are made to arguments that
    are structurally smaller than [e].

    Note also that [subst_exp] uses [x == y] for decidable equality.  This
    operation is defined in the Metatheory library.  *)

Fixpoint subst_exp (u:exp) (y:var) (e:exp) {struct e} : exp :=
  match e with
  | (var_b n)    => var_b n
  | (var_f x)    => (if x == y then u else (var_f x))
  | (num n)      => num n
  | (abs e1)     => abs (subst_exp u y e1)
  | (app e1 e2)  => app (subst_exp u y e1) (subst_exp u y e2)
  | (pair e1 e2) => pair (subst_exp u y e1) (subst_exp u y e2)
  | (proj1 e)    => proj1 (subst_exp u y e)
  | (proj2 e)    => proj2 (subst_exp u y e)
end.

(*************************************************************************)
(** * Free variables *)
(*************************************************************************)

(** The function [fv_exp], defined below, calculates the set of free
    variables in an expression.  Because we are using a locally
    nameless representation, where bound variables are represented as
    indices, any name we see is a free variable of a term.  In
    particular, this makes the [abs] case simple.
*)

Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (var_b nat)  => {}
  | (var_f x)    => {{x}}
  | (num _)      => {}
  | (abs e)      => fv_exp e
  | (app e1 e2)  => fv_exp e1 \u fv_exp e2
  | (pair e1 e2) => fv_exp e1 \u fv_exp e2
  | (proj1 e)    => fv_exp e
  | (proj2 e)    => fv_exp e
end.

Fixpoint fv_heap (h:heap) : vars :=
  match h with
  | nil => {}
  | (x, e) :: tl => fv_exp e \u fv_heap tl
end.

Definition fv_program (p:program) : vars :=
  match p with
  | (H, e) => AtomSetImpl.diff (fv_heap H \u fv_exp e) (dom H)
end.

Definition closed (p:program) : Prop := AtomSetImpl.Empty (fv_program p).

(** The type [vars] represents a finite set of elements of type [atom].
    The notations for the finite set definitions (empty set `{}`, singleton
    `{{x}}` and union `\u`) is also defined in the Metatheory library.  *)

(*************************************************************************)
(** * Opening *)
(*************************************************************************)

(** Opening replaces an index with a term.  It corresponds to informal
    substitution for a bound variable, such as in the rule for beta reduction.
    Note that only "dangling" indices (those that do not refer to any
    abstraction) can be opened.  Opening has no effect for terms that are
    locally closed.

    Natural numbers are just an inductive datatype with two constructors: [O]
    (as in the letter 'oh', not 'zero') and [S], defined in
    Coq.Init.Datatypes.  Coq allows literal natural numbers to be written
    using standard decimal notation, e.g., 0, 1, 2, etc.
    The function [lt_eq_lt_dec] compares its two arguments for ordering.

    We do not assume that zero is the only unbound index in the term.
    Consequently, we must substract one when we encounter other unbound
    indices (i.e. the [inright] case).

    However, we do assume that the argument [u] is locally closed.  This
    assumption simplifies the implementation since we do not need to shift
    indices in [u] when passing under a binder. *)

Fixpoint open_exp_wrt_exp_rec (k:nat) (u:exp) (e:exp) {struct e}: exp :=
  match e with
  | (var_b n) =>
      match lt_eq_lt_dec n k with
        | inleft (left _) => var_b n
        | inleft (right _) => u
        | inright _ => var_b (n - 1)
      end
  | (var_f x) => var_f x
  | (num n) => num n
  | (abs e) => abs (open_exp_wrt_exp_rec (S k) u e)
  | (app e1 e2) => app (open_exp_wrt_exp_rec k u e1)
                      (open_exp_wrt_exp_rec k u e2)
  | (pair e1 e2) => pair (open_exp_wrt_exp_rec k u e1)
                      (open_exp_wrt_exp_rec k u e2)
  | (proj1 e) => proj1 (open_exp_wrt_exp_rec k u e)
  | (proj2 e) => proj2 (open_exp_wrt_exp_rec k u e)
end.

(** Many common applications of opening replace index zero with an
    expression or variable.  The following definition provides a
    convenient shorthand for such uses.  Note that the order of
    arguments is switched relative to the definition above.  For
    example, [(open e x)] can be read as "substitute the variable [x]
    for index [0] in [e]" and "open [e] with the variable [x]."
*)

Definition open_exp_wrt_exp e u := open_exp_wrt_exp_rec 0 u e.

(*************************************************************************)
(** * Notations *)
(*************************************************************************)

Module LambdagcNotations.
Declare Scope exp_scope.
Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0) : exp_scope.
Notation open e1 e2     := (open_exp_wrt_exp e1 e2).
Notation "e ^ x"        := (open_exp_wrt_exp e (var_f x)) : exp_scope.
End LambdagcNotations.
Import LambdagcNotations.
Open Scope exp_scope.

(*************************************************************************)
(** * Local closure *)
(*************************************************************************)

(** Recall that [exp] admits terms that contain unbound indices.  We say that
    a term is locally closed when no indices appearing in it are unbound.  The
    proposition [lc_exp e] holds when an expression [e] is locally closed.

    The inductive definition below formalizes local closure such that the
    resulting induction principle serves as the structural induction principle
    over (locally closed) expressions.  In particular, unlike induction for
    type [exp], there are no cases for bound variables.  Thus, the induction
    principle corresponds more closely to informal practice than the one
    arising from the definition of pre-terms.  *)

Inductive lc_exp : exp -> Prop :=
 | lc_var_f : forall (x:var),
     lc_exp (var_f x)
 | lc_num : forall (n:nat),
     lc_exp (num n)
 | lc_abs : forall (e:exp),
      (forall x , lc_exp (open e (var_f x)))  ->
     lc_exp (abs e)
 | lc_app : forall (e1 e2:exp),
     lc_exp e1 ->
     lc_exp e2 ->
     lc_exp (app e1 e2)
 | lc_pair : forall (e1 e2:exp),
     lc_exp e1 ->
     lc_exp e2 ->
     lc_exp (pair e1 e2)
 | lc_proj1 : forall (e:exp),
     lc_exp e ->
     lc_exp (proj1 e)
 | lc_proj2 : forall (e:exp),
     lc_exp e ->
     lc_exp (proj2 e).

(*************************************************************************)
(** * Typing contexts *)
(*************************************************************************)

(** We represent typing contexts as association lists (lists of pairs of
    keys and values) whose keys are [atom]s.
*)

Definition ctx : Set := list (atom * typ).

(** For STLC, contexts bind [atom]s to [typ]s.

    Lists are defined in Coq's standard library, with the constructors [nil]
    and [cons].  The list library includes the [::] notation for cons as well
    as standard list operations such as append, map, and fold. The infix
    operation [++] is list append.

    The Metatheory library extends this reasoning by instantiating the
    AssocList library to provide support for association lists whose keys are
    [atom]s.  Everything in this library is polymorphic over the type of
    objects bound in the environment.  Look in AssocList.v for additional
    details about the functions and predicates that we mention below.
 *)

(*************************************************************************)
(** * Typing relation *)
(*************************************************************************)

(** The definition of the typing relation is straightforward.  In
    order to ensure that the relation holds for only well-formed
    environments, we check in the [typing_var] case that the
    environment is [uniq].  The structure of typing derivations
    implicitly ensures that the relation holds only for locally closed
    expressions.

    Finally, note the use of cofinite quantification in
    the [typing_abs] case.
*)

Inductive typing : ctx -> exp -> typ -> Prop :=
 | typing_var : forall (G:ctx) (x:var) (T:typ),
     uniq G ->
     binds x T G  ->
     typing G (var_f x) T
 | typing_num : forall (G:ctx) (n:nat),
     typing G (num n) (typ_nat)
 | typing_abs : forall (L:vars) (G:ctx) (T1:typ) (e:exp) (T2:typ),
     (forall x , x \notin L -> typing ([(x,T1)] ++ G) (e ^ x) T2)  ->
     typing G (abs e) (typ_arrow T1 T2)
 | typing_app : forall (G:ctx) (e1 e2:exp) (T2 T1:typ),
     typing G e1 (typ_arrow T1 T2) ->
     typing G e2 T1 ->
     typing G (app e1 e2) T2
 | typing_pair : forall (G:ctx) (e1 e2:exp) (T1 T2:typ),
     typing G e1 T1 ->
     typing G e2 T2 ->
     typing G (pair e1 e2) (typ_mult T1 T2)
 | typing_proj1 : forall (G:ctx) (e:exp) (T1 T2:typ),
     typing G e (typ_mult T1 T2) ->
     typing G (proj1 e) T1
 | typing_proj2 : forall (G:ctx) (e:exp) (T1 T2:typ),
     typing G e (typ_mult T1 T2) ->
     typing G (proj2 e) T2.

(*************************************************************************)
(** * Values and Small-step Evaluation *)
(*************************************************************************)

(** Finally, we define values and a call-by-name small-step evaluation
    relation. In STLC, abstractions are the only value. *)

Inductive is_heap_value : exp -> Prop :=
  | heap_abs : forall (e:exp),
    is_heap_value (abs e)
  | heap_num : forall (n:nat),
    is_heap_value (num n)
  | heap_pair : forall (x1 x2:var),
    is_heap_value (pair (var_f x1) (var_f x2)).

Inductive is_answer : program -> Prop :=
  | answer_var_f : forall (H:heap) (x:var),
    is_answer (H, var_f x).

(** For [step_beta], note that we use [open_exp_wrt_exp] instead of
    substitution --- no variable names are involved.

    Note also the hypotheses in [step] that ensure that the relation holds
    only for locally closed terms.  *)

Inductive step : program -> program -> Prop :=
 | step_alloc : forall (e:exp) (H:heap) (x:var),
     x `notin` ((dom H) \u fv_heap H \u fv_exp e) ->
     lc_exp e ->
     is_heap_value e ->
     step (H, e) ([(x, e)] ++ H, var_f x)
 | step_proj1_heap : forall (H:heap) (x x1 x2:var),
     binds x (pair (var_f x1) (var_f x2)) H ->
     step (H, proj1 (var_f x)) (H, var_f (x1))
 | step_proj2_heap : forall (H:heap) (x x1 x2:var),
     binds x (pair (var_f x1) (var_f x2)) H  ->
     step (H, proj2 (var_f x)) (H, var_f (x2))
 | step_app : forall (H:heap) (x y z:var) (e1 e2:exp),
     z `notin` ((dom H) \u fv_heap H \u fv_exp (app (var_f x) (var_f y))) ->
     binds x (abs e1) H ->
     binds y e2 H ->
     step (H, app (var_f x) (var_f y)) ([(z, e2)] ++ H, open e1 (var_f z))
 | step_app1 : forall (H H':heap) (e1 e1' e2:exp),
     lc_exp e2 ->
     step (H, e1) (H', e1') ->
     step (H, app e1 e2) (H', app e1' e2)
 | step_app2 : forall (H H':heap) (e2 e2':exp) (x1:var),
     step (H, e2) (H', e2') ->
     step (H, app (var_f x1) e2) (H', app (var_f x1) e2')
 | step_pair1 : forall (H H':heap) (e1 e1' e2:exp),
     lc_exp e2 ->
     step (H, e1) (H', e1') ->
     step (H, pair e1 e2) (H', pair e1' e2)
 | step_pair2 : forall (H H':heap) (e2 e2':exp) (x1:var),
     lc_exp e2 ->
     step (H, e2) (H', e2') ->
     step (H, pair (var_f x1) e2) (H', pair (var_f x1) e2')
 | step_proj1 : forall (H H':heap) (e e':exp),
     step (H, e) (H', e') ->
     step (H, proj1 e) (H', proj1 e')
 | step_proj2 : forall (H H':heap) (e e':exp),
     step (H, e) (H', e') ->
     step (H, proj2 e) (H', proj2 e').

Inductive multi {X : Type} (R : relation X) : relation X :=
 | multi_refl : forall (x : X), multi R x x
 | multi_step : forall (x y z : X),
                R x y ->
                multi R y z ->
                multi R x z.

Definition equiv (p p':program)  (r r':relation program) : Prop :=
    forall (n:nat),
    (exists x H, multi r p (H, var_f x) /\ binds x (num n) H) <->
    (exists x' H', multi r' p' (H', var_f x') /\ binds x' (num n) H').

Hint Constructors typing step lc_exp multi : core.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   lfind. Admitted.


From Coq Require Import Arith Psatz Bool String List Nat Program.Equality.

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

Require Import DanTrick.StackLanguage DanTrick.StackLangEval DanTrick.LogicProp.
(* DanTrick.StackLogicBase DanTrick.StackPure. *)

(* A stronger version of pure -- this stipulates that not only is the stack not changed
   by functions, but it doesn't actually _need_ any indices outside of a given frame *)

Inductive aexp_frame_rule : aexp_stack -> fun_env_stk -> nat -> Prop :=
| FrameConst :
  forall fenv frame n,
    aexp_frame_rule (Const_Stk n) fenv frame
| FrameVar :
  forall fenv frame k,
    1 <= k ->
    k <= frame ->
    aexp_frame_rule (Var_Stk k) fenv frame
| FramePlus :
  forall fenv frame a1 a2,
    aexp_frame_rule a1 fenv frame ->
    aexp_frame_rule a2 fenv frame ->
    aexp_frame_rule (Plus_Stk a1 a2) fenv frame
| FrameMinus :
  forall fenv frame a1 a2,
    aexp_frame_rule a1 fenv frame ->
    aexp_frame_rule a2 fenv frame ->
    aexp_frame_rule (Minus_Stk a1 a2) fenv frame
| FrameApp :
  forall fenv frame f args func,
    args_frame_rule args fenv frame ->
    func = fenv f ->
    imp_frame_rule (Body func) fenv (Args func) (Args func + Return_pop func) ->
    aexp_frame_rule (Return_expr func) fenv (Args func + Return_pop func) ->
    aexp_frame_rule (App_Stk f args) fenv frame
with args_frame_rule : list aexp_stack -> fun_env_stk -> nat -> Prop :=
| FrameArgsNil :
  forall fenv frame,
    args_frame_rule nil fenv frame
| FrameArgsCons :
  forall fenv frame arg args,
    aexp_frame_rule arg fenv frame ->
    args_frame_rule args fenv frame ->
    args_frame_rule (arg :: args) fenv frame
with bexp_frame_rule : bexp_stack -> fun_env_stk -> nat -> Prop :=
| FrameTrue :
  forall fenv frame,
    bexp_frame_rule True_Stk fenv frame
| FrameFalse :
  forall fenv frame,
    bexp_frame_rule False_Stk fenv frame
| FrameNeg :
  forall fenv frame b,
    bexp_frame_rule b fenv frame ->
    bexp_frame_rule (Neg_Stk b) fenv frame
| FrameAnd :
  forall fenv frame b1 b2,
    bexp_frame_rule b1 fenv frame ->
    bexp_frame_rule b2 fenv frame ->
    bexp_frame_rule (And_Stk b1 b2) fenv frame
| FrameOr :
  forall fenv frame b1 b2,
    bexp_frame_rule b1 fenv frame ->
    bexp_frame_rule b2 fenv frame ->
    bexp_frame_rule (Or_Stk b1 b2) fenv frame
| FrameLeq :
  forall fenv frame a1 a2,
    aexp_frame_rule a1 fenv frame ->
    aexp_frame_rule a2 fenv frame ->
    bexp_frame_rule (Leq_Stk a1 a2) fenv frame
| FrameEq :
  forall fenv frame a1 a2,
    aexp_frame_rule a1 fenv frame ->
    aexp_frame_rule a2 fenv frame ->
    bexp_frame_rule (Eq_Stk a1 a2) fenv frame
with imp_frame_rule : imp_stack -> fun_env_stk -> nat -> nat -> Prop :=
| FrameSkip :
  forall fenv frame,
    imp_frame_rule Skip_Stk fenv frame frame
| FrameAssign :
  forall fenv frame k a,
    1 <= k ->
    k <= frame ->
    aexp_frame_rule a fenv frame ->
    imp_frame_rule (Assign_Stk k a) fenv frame frame
| FramePush :
  forall fenv frame,
    imp_frame_rule Push_Stk fenv frame (frame + 1)
| FramePop :
  forall fenv frame,
    frame >= 1 ->
    imp_frame_rule Pop_Stk fenv frame (frame - 1)
| FrameSeq :
  forall fenv frame i1 i2 frame' frame'',
    imp_frame_rule i1 fenv frame frame' ->
    imp_frame_rule i2 fenv frame' frame'' ->
    imp_frame_rule (Seq_Stk i1 i2) fenv frame frame''
| FrameIf :
  forall fenv frame b i1 i2 frame',
    bexp_frame_rule b fenv frame ->
    imp_frame_rule i1 fenv frame frame' ->
    imp_frame_rule i2 fenv frame frame' ->
    imp_frame_rule (If_Stk b i1 i2) fenv frame frame'
| FrameWhile :
  forall fenv frame b loop_body,
    bexp_frame_rule b fenv frame ->
    imp_frame_rule loop_body fenv frame frame ->
    imp_frame_rule (While_Stk b loop_body) fenv frame frame.

Scheme aexp_frame_rule_ind' := Induction for aexp_frame_rule Sort Prop
    with args_frame_rule_ind' := Induction for args_frame_rule Sort Prop
    with bexp_frame_rule_ind' := Induction for bexp_frame_rule Sort Prop
with imp_frame_rule_ind' := Induction for imp_frame_rule Sort Prop.

Combined Scheme stack_frame_rule_mut_ind from aexp_frame_rule_ind', args_frame_rule_ind', bexp_frame_rule_ind', imp_frame_rule_ind'.


From mathcomp Require Import all_ssreflect.
Require Import core_mf core_inseg.
Require Import Psatz ClassicalChoice FunctionalExtensionality.

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

Local Open Scope coq_nat_scope.
Section COUNTABILITY.
Definition is_count Q :=
	exists cnt: nat -> option Q, cnt \is_surjective_function.
Notation "T '\is_countable'" := (is_count T) (at level 2).

Lemma classic_eqClass Q : exists P : Equality.class_of Q, True.
Proof.
have /choice[eq eqP]: (fun q b => (q.1 = q.2 :> Q) <-> (b = true)) \is_total.
  by move=> q; case: (classic (q.1 = q.2)) => ass; [exists true|exists false].
unshelve eexists (@Equality.Mixin _ (fun x y => eq (x, y)) _) => //.
by move=> x y; apply: (iffP idP) => [/eqP//|->]; apply/eqP.
Qed.

Lemma count_countMixin Q : Q \is_countable ->
  exists P : Countable.mixin_of Q, True.
Proof.
move => [cnt sur]; have [sec [issec min]] := minimal_section sur.
unshelve eexists (@Countable.Mixin _ (sec \o some) cnt _) => //.
by move=> x /=; rewrite issec.
Qed.

Lemma count_countClass Q  : Q \is_countable ->
  exists P : Countable.class_of Q, True.
Proof.
move=> /count_countMixin[cmQ _]; have [eqQ _] := classic_eqClass Q.
set QeqType := EqType Q eqQ.
set QchoiceType := ChoiceType QeqType (CountChoiceMixin cmQ).
by exists (Countable.class (CountType QchoiceType cmQ)).
Qed.

Lemma countMixin_count T : Countable.mixin_of T -> T \is_countable.
Proof.
move=> [pickle unpickle pickleK].
exists (fun n => if n isn't n.+1 then None else unpickle n).
move=> [x|]; last by exists 0.
by exists (pickle x).+1; rewrite pickleK.
Qed.

Lemma countType_count (T : countType) : T \is_countable.
Proof. by apply: countMixin_count; case: T => [?[]]. Qed.

Lemma nat_count: nat \is_countable.
Proof. exact: countType_count. Qed.

Lemma option_count T : T \is_countable -> (option T) \is_countable.
Proof.
move=> /count_countClass [cT _]; set T' : Type := Countable.Pack cT T.
by rewrite -[T]/T'; apply: countType_count.
Qed.

Lemma sum_count Q Q': Q \is_countable -> Q' \is_countable ->
  (Q + Q') \is_countable.
Proof.
move=> /count_countClass [cQ _]; set QC : Type := Countable.Pack cQ Q.
move=> /count_countClass [cQ' _]; set Q'C : Type := Countable.Pack cQ' Q'.
by rewrite -[Q]/QC -[Q']/Q'C; apply: countType_count.
Qed.

Lemma prod_count Q Q':
  Q \is_countable -> Q' \is_countable -> (Q * Q') \is_countable.
Proof.
move=> /count_countClass [cQ _]; set QC : Type := Countable.Pack cQ Q.
move=> /count_countClass [cQ' _]; set Q'C : Type := Countable.Pack cQ' Q'.
by rewrite -[Q]/QC -[Q']/Q'C; apply: countType_count.
Qed.

Lemma list_count Q: Q \is_countable -> (list Q) \is_countable.
Proof.
move=> /count_countClass [cQ _]; set QC : Type := Countable.Pack cQ Q.
by rewrite -[Q]/QC; apply: countType_count.
Qed.

Lemma count_sur Q: (exists cnt: nat -> Q, cnt \is_surjective_function) <-> inhabited Q /\ Q \is_countable.
Proof.
split => [ [cnt sur] | [[someq [cnt sur]]]].
	split; first exact (inhabits (cnt 0)).
	exists (fun n => match n with
		| 0 => None
		| S n' => Some (cnt n')
	end).
	move => q.
	case: q; last by exists 0.
	move => q.
	have [n val] := sur (q).
	by exists (S n); rewrite val.
exists (fun n => match cnt n with
	| None => someq
	| Some q => q
end) => q.
have [n val] := sur (some q).
by exists n; rewrite val.
Qed.

End COUNTABILITY.
Notation "T '\is_countable'" := (is_count T) (at level 2).


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* RndNat -- a computation that returns a random nat uniformly distributed in a specified range. *)

Set Implicit Arguments.

Require Import FCF.Crypto.
Require Import Permutation.
Require Import FCF.NotationV1.

Definition RndNat_unchecked(n : nat) :=
  v <-$ {0,1} ^ (lognat n);
  let n := (bvToNat v) in
    ret n.

Definition ltNatBool := fun x1 x2 => if (lt_dec x1 x2) then true else false.

(* RndNat uses Repeat to get a number strictly less than n *)
Definition RndNat(n : nat) :=
    (Repeat (RndNat_unchecked n) (fun x => (ltNatBool x n))).

Notation "[ 0 '..' n )" := (RndNat n)
  (right associativity, at level 77) : comp_scope.

Lemma well_formed_RndNat : forall n,
  n > O ->
  well_formed_comp (RndNat n).

  intuition.
  unfold RndNat.
  eapply (well_formed_Repeat).
  unfold eq_dec.
  intuition.
  eapply eq_nat_dec.
  unfold RndNat_unchecked.
  eapply well_formed_Bind.
  eapply well_formed_Rnd.
  intuition.
  eapply well_formed_Ret.
  eapply filter_In.
  intuition.
  2:{
    unfold ltNatBool.
    assert ((if (lt_dec O n) then true else false) = true).
    destruct (lt_dec O n).
    trivial.
    omega.
    eapply H0.
  }
  simpl.
  eapply Fold.in_getUnique.
  eapply Fold.in_flatten.
  econstructor.
  split.

  eapply in_map_iff.
  econstructor.
  split.
  eauto.

  eapply in_getAllBvectors.

  specialize (bvNat_zero (lognat n)); intuition.
  simpl in *.
  left.
  eapply H0.

Qed.

Lemma RndNat_support_lt : forall n x,
  In x (getSupport (RndNat n)) ->
  x < n.

  intuition.
  unfold RndNat in *.
  simpl in *.
  eapply filter_In in H.
  intuition.
  unfold ltNatBool in *.
  destruct (lt_dec x n); congruence.
Qed.

Hint Resolve well_formed_RndNat : wftac.

Lemma RndNat_unchecked_lt_support : forall n v,
  v < n ->
  In v (getSupport (RndNat_unchecked n)).

  intuition.
  unfold RndNat_unchecked.

  eapply getSupport_In_Seq.
  eapply in_getAllBvectors.
  simpl.
  left.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  omega.

Qed.

Local Open Scope rat_scope.

Lemma RndNat_uniform : forall v1 v2 n,
  v1 < n ->
  v2 < n ->
  evalDist (RndNat n) v1 == evalDist (RndNat n) v2.

  intuition.

  eapply evalDist_Repeat_eq; intuition.
  unfold RndNat_unchecked.
  remember (lognat n) as length.
  eapply (evalDist_iso
    (BVxor length (BVxor length (natToBv length v1) (natToBv length v2)))
    (BVxor length (BVxor length (natToBv length v1) (natToBv length v2)))); intuition.

(*
  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
*)

  remember (BVxor length (natToBv length v1) (natToBv length v2)) as z.
  rewrite <- BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  trivial.

  rewrite <- BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  trivial.

  simpl.
  eapply in_getAllBvectors.

  eapply uniformity.

  simpl.
  destruct (EqDec_dec nat_EqDec (bvToNat x) v2); subst.
  destruct (EqDec_dec nat_EqDec
    (bvToNat
      (BVxor (lognat n)
        (BVxor (lognat n) (natToBv (lognat n) v1)
          (natToBv (lognat n) (bvToNat x))) x)) v1).
  intuition.
  exfalso.
  eapply n0.

  rewrite natToBv_bvToNat_inverse.

  rewrite BVxor_assoc.
  rewrite BVxor_same_id.
  rewrite BVxor_id_r.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  omega.

  destruct (EqDec_dec nat_EqDec
    (bvToNat
      (BVxor (lognat n)
        (BVxor (lognat n) (natToBv (lognat n) v1)
          (natToBv (lognat n) v2)) x)) v1).
  exfalso.
  eapply n0.
  rewrite BVxor_assoc in e.
  assert ((BVxor (lognat n) (natToBv (lognat n) v2) x) = (Bvect_false (lognat n))).
  eapply BVxor_id_r_inv.
  eapply bvToNat_natToBv_eq.
  eauto.
  apply BVxor_id_inv in H2.
  rewrite <- H2.

  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  omega.

  intuition.

  unfold ltNatBool.
  destruct (lt_dec v1 n); destruct (lt_dec v2 n); congruence.

  eapply filter_In; intuition.
  eapply RndNat_unchecked_lt_support.
  trivial.
  unfold ltNatBool.
  destruct (lt_dec v1 n); congruence.
Qed.

Lemma in_getSupport_RndNat : forall x k,
  x < k ->
  In x (getSupport (RndNat k)).

  intuition.
  simpl.
  eapply filter_In.
  split.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eapply in_getAllBvectors.
  simpl.
  left.
  eapply bvToNat_natToBv_inverse.
  eapply lognat_monotonic.
  trivial.
  unfold ltNatBool.
  destruct (lt_dec x k); intuition.
Qed.

Lemma RndNat_support_length :
  forall n,
    length (getSupport (RndNat n)) = n.

  intuition.
  rewrite (@Permutation_length _ _ (forNats n)).
  eapply forNats_length.
  eapply NoDup_Permutation.
  eapply getSupport_NoDup.
  eapply forNats_NoDup.
  intuition.

  eapply forNats_In.
  eapply RndNat_support_lt; intuition.

  eapply in_getSupport_RndNat.
  eapply forNats_In; intuition.

Qed.

Theorem RndNat_prob :
  forall n i (nzn : nz n),
    i < n ->
    evalDist (RndNat n) i == 1 / n.

  intuition.

  eapply (@ratMult_same_r_inv _ (n / 1)).
  rewrite ratMult_eq_rat1.
  eapply eqRat_trans.
  2:{
    eapply evalDist_lossless.
    eapply well_formed_RndNat.
    destruct nzn.
    apply agz.
  }

  symmetry.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  eapply (@RndNat_uniform _ i).
  eapply RndNat_support_lt; intuition.
  trivial.
  rewrite sumList_body_const.

  rewrite RndNat_support_length.
  intuition.
  intuition.
  eapply rat_num_nz.
  destruct nzn.
  eapply agz.
  eauto.
Qed.

Theorem RndNat_seq :
  forall (n : posnat)(A : Set)(c : nat -> Comp A) a,
    evalDist (x <-$ RndNat n; c x) a ==
    (1 / n) * sumList (allNatsLt n) (fun z => evalDist (c z) a).

  intuition.
  rewrite evalDist_seq_step.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intros.
  eapply ratMult_eqRat_compat.
  eapply RndNat_prob.
  eapply RndNat_support_lt.
  trivial.
  eapply eqRat_refl.
  rewrite sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.
  eapply sumList_permutation.
  eapply NoDup_Permutation.
  eapply getSupport_NoDup.
  eapply allNatsLt_NoDup.
  intuition.
  eapply allNatsLt_lt_if.
  eapply RndNat_support_lt.
  trivial.
  eapply in_getSupport_RndNat.
  eapply allNatsLt_lt.
  trivial.

Qed.

Lemma rndNat_sumList :
  forall (A : Set)(f : nat -> Comp A) n (nzn : nz n) x,
    evalDist (i <-$ RndNat n; f i) x ==
    sumList (forNats n) (fun i => (1 / n) * (evalDist (f i) x)).

  intuition.
  unfold evalDist.
  fold evalDist.
  rewrite sumList_permutation.
  2:{
    eapply (@NoDup_Permutation _ _ (forNats n)).
    eapply getSupport_NoDup.
    eapply forNats_NoDup.
    intuition.

    eapply forNats_In.
    eapply RndNat_support_lt.
    trivial.
    eapply in_getSupport_RndNat.
    eapply forNats_In.
    trivial.
  }

  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat; intuition.

  eapply RndNat_prob.
  eapply forNats_In.
  trivial.
Qed.