 Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From Coq Require Import Strings.String.

Module STLCExtended.

  Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
  Tactic Notation "normalize" :=
    repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
    apply multi_refl.

  (* Syntax *)
  Inductive ty : Type :=
  | Arrow : ty -> ty -> ty
  | Nat : ty
  | Sum : ty -> ty -> ty
  | List : ty -> ty
  | Unit : ty
  | Prod : ty -> ty -> ty.
  Inductive tm : Type :=
  (* pure STLC *)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  (* numbers *)
  | const : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm
  | mlt : tm -> tm -> tm
  | test0 : tm -> tm -> tm -> tm
  (* sums *)
  | tinl : ty -> tm -> tm
  | tinr : ty -> tm -> tm
  | tcase : tm -> string -> tm -> string -> tm -> tm
  (* i.e., case t0 of inl x1 ⇒ t1 | inr x2 ⇒ t2 *)
  (* lists *)
  | tnil : ty -> tm
  | tcons : tm -> tm -> tm
  | tlcase : tm -> tm -> string -> string -> tm -> tm
  (* i.e., lcase t1 of | nil ⇒ t2 | x::y ⇒ t3 *)
  (* unit *)
  | unit : tm
  (* You are going to be working on the following extensions: *)
  (* pairs *)
  | pair : tm -> tm -> tm
  | fst : tm -> tm
  | snd : tm -> tm
  (* let *)
  | tlet : string -> tm -> tm -> tm
         (* i.e., let x = t1 in t2 *)
  (* fix *)
  | tfix : tm -> tm.

  (* substitution *)

  Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
    match t with
    (* pure STLC *)
    | var y =>
          if eqb_string x y then s else t
    | abs y T t1 =>
          abs y T (if eqb_string x y then t1 else (subst x s t1))
    | app t1 t2 =>
          app (subst x s t1) (subst x s t2)
    (* numbers *)
    | const n =>
            const n
    | scc t1 =>
          scc (subst x s t1)
    | prd t1 =>
          prd (subst x s t1)
    | mlt t1 t2 =>
          mlt (subst x s t1) (subst x s t2)
    | test0 t1 t2 t3 =>
            test0 (subst x s t1) (subst x s t2) (subst x s t3)
    (* sums *)
    | tinl T t1 =>
           tinl T (subst x s t1)
    | tinr T t1 =>
           tinr T (subst x s t1)
    | tcase t0 y1 t1 y2 t2 =>
            tcase (subst x s t0)
            y1 (if eqb_string x y1 then t1 else (subst x s t1))
            y2 (if eqb_string x y2 then t2 else (subst x s t2))
    (* lists *)
    | tnil T =>
           tnil T
    | tcons t1 t2 =>
            tcons (subst x s t1) (subst x s t2)
    | tlcase t1 t2 y1 y2 t3 =>
             tlcase (subst x s t1) (subst x s t2) y1 y2
             (if eqb_string x y1 then
                t3
              else if eqb_string x y2 then t3
                   else (subst x s t3))
    (* unit *)
    | unit => unit
    (* Complete the following cases. *)
    (* pairs *)
    | pair t1 t2 =>
      pair (subst x s t1) (subst x s t2)
    | fst t1 =>
      fst (subst x s t1)
    | snd t1 =>
      snd (subst x s t1)
    (* let *)
    (* if x = y, nothing need to be changed *)
    | tlet y t1 t2 =>
      tlet y (subst x s t1) (if eqb_string x y then t2 else (subst x s t2))
    (* fix *)
    | tfix t1 =>
      tfix (subst x s t1)
    end.

    Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

    Inductive value : tm -> Prop :=
    (* In pure STLC, function abstractions are values: *)
    | v_abs : forall x T11 t12,
        value (abs x T11 t12)
    (* Numbers are values: *)
    | v_nat : forall n1,
        value (const n1)
    (* A tagged value is a value:  *)
    | v_inl : forall v T,
        value v ->
        value (tinl T v)
    | v_inr : forall v T,
        value v ->
        value (tinr T v)
    (* A list is a value iff its head and tail are values: *)
    | v_lnil : forall T, value (tnil T)
    | v_lcons : forall v1 vl,
        value v1 ->
        value vl ->
        value (tcons v1 vl)
    (* A unit is always a value *)
    | v_unit : value unit
    (* A pair is a value if both components are: *)
    | v_pair : forall v1 v2,
        value v1 ->
        value v2 ->
        value (pair v1 v2).
    Hint Constructors value.
    Reserved Notation "t1 '-->' t2" (at level 40).
    Inductive step : tm -> tm -> Prop :=
    (* pure STLC *)
    | ST_AppAbs : forall x T11 t12 v2,
        value v2 ->
        (app (abs x T11 t12) v2) --> [x:=v2]t12
    | ST_App1 : forall t1 t1' t2,
        t1 --> t1' ->
        (app t1 t2) --> (app t1' t2)
    | ST_App2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        (app v1 t2) --> (app v1 t2')
    (* numbers *)
    | ST_Succ1 : forall t1 t1',
        t1 --> t1' ->
        (scc t1) --> (scc t1')
    | ST_SuccNat : forall n1,
        (scc (const n1)) --> (const (S n1))
    | ST_Pred : forall t1 t1',
        t1 --> t1' ->
        (prd t1) --> (prd t1')
    | ST_PredNat : forall n1,
        (prd (const n1)) --> (const (pred n1))
    | ST_Mult1 : forall t1 t1' t2,
        t1 --> t1' ->
        (mlt t1 t2) --> (mlt t1' t2)
    | ST_Mult2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        (mlt v1 t2) --> (mlt v1 t2')
    | ST_Mulconsts : forall n1 n2,
        (mlt (const n1) (const n2)) --> (const (mult n1 n2))
    | ST_Test01 : forall t1 t1' t2 t3,
        t1 --> t1' ->
        (test0 t1 t2 t3) --> (test0 t1' t2 t3)
    | ST_Test0Zero : forall t2 t3,
        (test0 (const 0) t2 t3) --> t2
    | ST_Test0Nonzero : forall n t2 t3,
        (test0 (const (S n)) t2 t3) --> t3
    (* sums *)
    | ST_Inl : forall t1 t1' T,
        t1 --> t1' ->
        (tinl T t1) --> (tinl T t1')
    | ST_Inr : forall t1 t1' T,
        t1 --> t1' ->
        (tinr T t1) --> (tinr T t1')
    | ST_Case : forall t0 t0' x1 t1 x2 t2,
        t0 --> t0' ->
        (tcase t0 x1 t1 x2 t2) --> (tcase t0' x1 t1 x2 t2)
    | ST_CaseInl : forall v0 x1 t1 x2 t2 T,
        value v0 ->
        (tcase (tinl T v0) x1 t1 x2 t2) --> [x1:=v0]t1
    | ST_CaseInr : forall v0 x1 t1 x2 t2 T,
        value v0 ->
        (tcase (tinr T v0) x1 t1 x2 t2) --> [x2:=v0]t2
    (* lists *)
    | ST_Cons1 : forall t1 t1' t2,
        t1 --> t1' ->
        (tcons t1 t2) --> (tcons t1' t2)
    | ST_Cons2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        (tcons v1 t2) --> (tcons v1 t2')
    | ST_Lcase1 : forall t1 t1' t2 x1 x2 t3,
        t1 --> t1' ->
        (tlcase t1 t2 x1 x2 t3) --> (tlcase t1' t2 x1 x2 t3)
    | ST_LcaseNil : forall T t2 x1 x2 t3,
        (tlcase (tnil T) t2 x1 x2 t3) --> t2
    | ST_LcaseCons : forall v1 vl t2 x1 x2 t3,
        value v1 ->
        value vl ->
        (tlcase (tcons v1 vl) t2 x1 x2 t3)
          --> (subst x2 vl (subst x1 v1 t3))

    (* Add rules for the following extensions. *)

    (* pairs *)
    | ST_Pair1 : forall t1 t2 t1',
        t1 --> t1' ->
        (pair t1 t2) --> (pair t1' t2)
    | ST_Pair2 : forall t1 t2 t2',
        t2 --> t2' ->
        (pair t1 t2) --> (pair t1 t2')
    | ST_Fst1 : forall t1 t1',
        t1 --> t1' ->
        (fst t1) --> (fst t1')
    | ST_FstPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (fst (pair v1 v2)) --> v1
    | ST_Snd1 : forall t1 t1',
        t1 --> t1' ->
        (snd t1) --> (snd t1')
    | ST_SndPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (snd (pair v1 v2)) --> v2
    (* let *)
    | ST_Let1 : forall x t1 t1' t2,
        t1 --> t1' ->
        (tlet x t1 t2) --> (tlet x t1' t2)
    |ST_LetValue : forall x v1 t2,
        value v1 ->
        (tlet x v1 t2) --> (subst x v1 t2)
    (* fix *)
    | ST_Fix1 : forall t1 t1',
        t1 --> t1' ->
        (tfix t1) --> (tfix t1')
    | ST_FixAbs : forall xf t2 T1,
        (tfix (abs xf T1 t2)) -->
        (subst xf (tfix (abs xf T1 t2)) t2)

    where "t1 '-->' t2" := (step t1 t2).
    Notation multistep := (multi step).
    Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).
    Hint Constructors step.

    Definition context := partial_map ty.

    Reserved Notation "Gamma '|-' t '∈' T" (at level 40).
    Inductive has_type : context -> tm -> ty -> Prop :=
    (* Typing rules for pure STLC *)
    | T_Var : forall Gamma x T,
        Gamma x = Some T ->
        Gamma |- (var x) ∈ T
    | T_Abs : forall Gamma x T11 T12 t12,
        (update Gamma x T11) |- t12 ∈ T12 ->
        Gamma |- (abs x T11 t12) ∈ (Arrow T11 T12)
    | T_App : forall T1 T2 Gamma t1 t2,
        Gamma |- t1 ∈ (Arrow T1 T2) ->
        Gamma |- t2 ∈ T1 ->
        Gamma |- (app t1 t2) ∈ T2
    (* numbers *)
    | T_Nat : forall Gamma n1,
        Gamma |- (const n1) ∈ Nat
    | T_Succ : forall Gamma t1,
        Gamma |- t1 ∈ Nat ->
        Gamma |- (scc t1) ∈ Nat
    | T_Pred : forall Gamma t1,
        Gamma |- t1 ∈ Nat ->
        Gamma |- (prd t1) ∈ Nat
    | T_Mult : forall Gamma t1 t2,
        Gamma |- t1 ∈ Nat ->
        Gamma |- t2 ∈ Nat ->
        Gamma |- (mlt t1 t2) ∈ Nat
    | T_Test0 : forall Gamma t1 t2 t3 T1,
        Gamma |- t1 ∈ Nat ->
        Gamma |- t2 ∈ T1 ->
        Gamma |- t3 ∈ T1 ->
        Gamma |- (test0 t1 t2 t3) ∈ T1
    (* sums *)
    | T_Inl : forall Gamma t1 T1 T2,
        Gamma |- t1 ∈ T1 ->
        Gamma |- (tinl T2 t1) ∈ (Sum T1 T2)
    | T_Inr : forall Gamma t2 T1 T2,
        Gamma |- t2 ∈ T2 ->
        Gamma |- (tinr T1 t2) ∈ (Sum T1 T2)
    | T_Case : forall Gamma t0 x1 T1 t1 x2 T2 t2 T,
        Gamma |- t0 ∈ (Sum T1 T2) ->
        (update Gamma x1 T1) |- t1 ∈ T ->
        (update Gamma x2 T2) |- t2 ∈ T ->
        Gamma |- (tcase t0 x1 t1 x2 t2) ∈ T
    (* lists *)
    | T_Nil : forall Gamma T,
        Gamma |- (tnil T) ∈ (List T)
    | T_Cons : forall Gamma t1 t2 T1,
        Gamma |- t1 ∈ T1 ->
        Gamma |- t2 ∈ (List T1) ->
        Gamma |- (tcons t1 t2) ∈ (List T1)
    | T_Lcase : forall Gamma t1 T1 t2 x1 x2 t3 T2,
        Gamma |- t1 ∈ (List T1) ->
        Gamma |- t2 ∈ T2 ->
        (update (update Gamma x2 (List T1)) x1 T1) |- t3 ∈ T2 ->
        Gamma |- (tlcase t1 t2 x1 x2 t3) ∈ T2
    (* unit *)
    | T_Unit : forall Gamma,
        Gamma |- unit ∈ Unit

    (* Add rules for the following extensions. *)

    (* pairs *)
    | T_Pair : forall Gamma t1 t2 T1 T2,
        Gamma |- t1 ∈ T1 ->
        Gamma |- t2 ∈ T2 ->
        Gamma |- (pair t1 t2) ∈ (Prod T1 T2)
    | T_Fst : forall Gamma t T1 T2,
        Gamma |- t ∈ (Prod T1 T2) ->
        Gamma |- (fst t) ∈ T1
    | T_Snd : forall Gamma t T1 T2,
        Gamma |- t ∈ (Prod T1 T2) ->
        Gamma |- (snd t) ∈ T2
    (* let *)
    | T_Let : forall Gamma x t1 t2 T1 T2,
        Gamma |- t1 ∈ T1 ->
        (x |-> T1; Gamma) |- t2 ∈ T2 ->
        Gamma |- (tlet x t1 t2) ∈ T2
    (* fix *)
    | T_Fix : forall Gamma t1 T1,
        Gamma |- t1 ∈ (Arrow T1 T1) ->
        Gamma |- (tfix t1) ∈ T1

    where "Gamma '|-' t '∈' T" := (has_type Gamma t T).
    Hint Constructors has_type.

    Module Examples.

      Open Scope string_scope.
      Notation x := "x".
      Notation y := "y".
      Notation a := "a".
      Notation f := "f".
      Notation g := "g".
      Notation l := "l".
      Notation k := "k".
      Notation i1 := "i1".
      Notation i2 := "i2".
      Notation processSum := "processSum".
      Notation n := "n".
      Notation eq := "eq".
      Notation m := "m".
      Notation evenodd := "evenodd".
      Notation even := "even".
      Notation odd := "odd".
      Notation eo := "eo".

      Hint Extern 2 (has_type _ (app _ _) _) =>
           eapply T_App; auto.
      Hint Extern 2 (has_type _ (tlcase _ _ _ _ _) _) =>
           eapply T_Lcase; auto.
      Hint Extern 2 (_ = _) => compute; reflexivity.

      Module Numtest.
        (* test0 (pred (succ (pred (2 * 0))) then 5 else 6 *)
        Definition test :=
          test0
            (prd
               (scc
                  (prd
                     (mlt
                        (const 2)
                        (const 0)))))
            (const 5)
            (const 6).
        Example typechecks :
          empty |- test ∈ Nat.
        Proof.
          unfold test.
          (* This typing derivation is quite deep, so we need
     to increase the max search depth of auto from the
     default 5 to 10. *)
          auto 10.
        Qed.

        Example numtest_reduces :
          test -->* const 5.
        Proof.
          unfold test.
          normalize.
        Qed.

        (*
  unfold test. normalize.
         *)
      End Numtest.

      Module Prodtest.
        (* ((5,6),7).fst.snd *)
        Definition test :=
          snd
            (fst
               (pair
                  (pair
                     (const 5)
                     (const 6))
                  (const 7))).
        Example typechecks :
          empty |- test ∈ Nat.
        Proof. unfold test. eauto 15.
               Qed.
        (* GRADE_THEOREM 0.25: typechecks *)
        Example reduces :
          test -->* const 6.
        Proof.
          unfold test. normalize.
          (* FILL IN HERE *)
        Qed.

        (* GRADE_THEOREM 0.25: reduces *)
      End Prodtest.

      Module LetTest.
        (* let x = pred 6 in succ x *)
        Definition test :=
          tlet
            x
            (prd (const 6))
            (scc (var x)).
        Example typechecks :
          empty |- test ∈ Nat.
        Proof.
          unfold test. eauto 15.
        Qed.
        (* GRADE_THEOREM 0.25: typechecks *)
        Example reduces :
          test -->* const 6.
        Proof.
          unfold test. normalize.
        Qed.

        (* GRADE_THEOREM 0.25: reduces *)
      End LetTest.

      Module Sumtest1.
        (* case (inl Nat 5) of
     inl x => x
   | inr y => y *)
        Definition test :=
          tcase (tinl Nat (const 5))
                x (var x)
                y (var y).
        Example typechecks :
          empty |- test ∈ Nat.
        Proof. unfold test. eauto 15. Qed.
        Example reduces :
          test -->* (const 5).
        Proof.
          unfold test. normalize. Qed.
      End Sumtest1.
      Module Sumtest2.
        (* let processSum =
     \x:Nat+Nat.
        case x of
          inl n => n
          inr n => test0 n then 1 else 0 in
   (processSum (inl Nat 5), processSum (inr Nat 5))    *)
        Definition test :=
          tlet
            processSum
            (abs x (Sum Nat Nat)
                 (tcase (var x)
                        n (var n)
                        n (test0 (var n) (const 1) (const 0))))
            (pair
               (app (var processSum) (tinl Nat (const 5)))
               (app (var processSum) (tinr Nat (const 5)))).
        Example typechecks :
          empty |- test ∈ (Prod Nat Nat).
        Proof. unfold test. eauto 15. Qed.
        Example reduces :
          test -->* (pair (const 5) (const 0)).
        Proof.
          unfold test. normalize. Qed.

      End Sumtest2.

      Module ListTest.
        (* let l = cons 5 (cons 6 (nil Nat)) in
   lcase l of
     nil => 0
   | x::y => x*x *)
        Definition test :=
          tlet l
               (tcons (const 5) (tcons (const 6) (tnil Nat)))
               (tlcase (var l)
                       (const 0)
                       x y (mlt (var x) (var x))).
        Example typechecks :
          empty |- test ∈ Nat.
        Proof. unfold test. eauto 20. Qed.
        Example reduces :
          test -->* (const 25).
        Proof.
          unfold test. normalize. Qed.
      End ListTest.

        Module FixTest1.
      (* fact := fix
             (\f:nat->nat.
                \a:nat.
                   test a=0 then 1 else a * (f (pred a))) *)
          Definition fact :=
            tfix
              (abs f (Arrow Nat Nat)
                   (abs a Nat
                        (test0
                           (var a)
                           (const 1)
                           (mlt
                              (var a)
                              (app (var f) (prd (var a))))))).

          Example typechecks :
            empty |- fact ∈ (Arrow Nat Nat).
          Proof. unfold fact. auto 10. Qed. (* FILL IN HERE *)
          (* GRADE_THEOREM 0.25: typechecks *)
          Example reduces :
            (app fact (const 4)) -->* (const 24).
          Proof.
          (*
  unfold fact. normalize.
           *)
          (* FILL IN HERE *) Admitted.
          (* GRADE_THEOREM 0.25: reduces *)
    End FixTest1.
    Module FixTest2.
      (* map :=
     \g:nat->nat.
       fix
         (\f:nat->nat.
            \l:nat.
               case l of
               |  ->
               | x::l -> (g x)::(f l)) *)
      Definition map :=
        abs g (Arrow Nat Nat)
            (tfix
               (abs f (Arrow (List Nat) (List Nat))
                    (abs l (List Nat)
                         (tlcase (var l)
                                 (tnil Nat)
                                 a l (tcons (app (var g) (var a))
                                            (app (var f) (var l))))))).
      Example typechecks :
        empty |- map ∈
              (Arrow (Arrow Nat Nat)
                     (Arrow (List Nat)
                            (List Nat))).
      Proof. unfold map. auto 10. Qed.
      (* GRADE_THEOREM 0.25: typechecks *)
      Example reduces :
        app (app map (abs a Nat (scc (var a))))
            (tcons (const 1) (tcons (const 2) (tnil Nat)))
            -->* (tcons (const 2) (tcons (const 3) (tnil Nat))).
      Proof.
        unfold map. normalize. Qed.

      (* GRADE_THEOREM 0.25: reduces *)
    End FixTest2.
    Module FixTest3.
      (* equal =
      fix
        (\eq:Nat->Nat->Bool.
           \m:Nat. \n:Nat.
             test0 m then (test0 n then 1 else 0)
             else test0 n then 0
             else eq (pred m) (pred n))   *)
      Definition equal :=
        tfix
          (abs eq (Arrow Nat (Arrow Nat Nat))
               (abs m Nat
                    (abs n Nat
                         (test0 (var m)
                                (test0 (var n) (const 1) (const 0))
                                (test0 (var n)
                                       (const 0)
                                       (app (app (var eq)
                                                 (prd (var m)))
                                            (prd (var n)))))))).
      Example typechecks :
        empty |- equal ∈ (Arrow Nat (Arrow Nat Nat)).
      Proof. unfold equal. auto 10. Qed.
      (* GRADE_THEOREM 0.25: typechecks *)
      Example reduces :
        (app (app equal (const 4)) (const 4)) -->* (const 1).
      Proof.
        unfold equal. normalize. Qed.

      (* GRADE_THEOREM 0.25: reduces *)
      Example reduces2 :
        (app (app equal (const 4)) (const 5)) -->* (const 0).
      Proof.
        unfold equal. normalize. Qed.
    End FixTest3.
    Module FixTest4.
      (* let evenodd =
         fix
           (\eo: (Nat->Nat * Nat->Nat).
              let e = \n:Nat. test0 n then 1 else eo.snd (pred n) in
              let o = \n:Nat. test0 n then 0 else eo.fst (pred n) in
              (e,o)) in
    let even = evenodd.fst in
    let odd  = evenodd.snd in
    (even 3, even 4)
       *)
      Definition eotest :=
        tlet evenodd
             (tfix
                (abs eo (Prod (Arrow Nat Nat) (Arrow Nat Nat))
                     (pair
                        (abs n Nat
                             (test0 (var n)
                                    (const 1)
                                    (app (snd (var eo)) (prd (var n)))))
                        (abs n Nat
                             (test0 (var n)
                                    (const 0)
                                    (app (fst (var eo)) (prd (var n))))))))
             (tlet even (fst (var evenodd))
                   (tlet odd (snd (var evenodd))
                         (pair
                            (app (var even) (const 3))
                            (app (var even) (const 4))))).
      Example typechecks :
        empty |- eotest ∈ (Prod Nat Nat).
      Proof. unfold eotest. eauto 30. Qed.
      (* GRADE_THEOREM 0.25: typechecks *)
      Example reduces :
        eotest -->* (pair (const 0) (const 1)).
      Proof.
        unfold eotest. normalize. Qed.
      (* GRADE_THEOREM 0.25: reduces *)
    End FixTest4.
    End Examples.

    Theorem progress : forall t T,
        empty |- t ∈ T ->
        value t \/ exists t', t --> t'.
    Proof with eauto.
      intros t T Ht.
      remember empty as Gamma.
      generalize dependent HeqGamma.
      induction Ht; intros HeqGamma; subst.
      - (* T_Var *)
        (* The final rule in the given typing derivation cannot be
       T_Var, since it can never be the case that
       empty ⊢ x : T (since the context is empty). *)
        inversion H.
      - (* T_Abs *)
        (* If the T_Abs rule was the last used, then
       t = abs x T11 t12, which is a value. *)
        left...
      - (* T_App *)
        (* If the last rule applied was T_App, then t = t1 t2,
       and we know from the form of the rule that
         empty ⊢ t1 : T1 → T2
         empty ⊢ t2 : T1
       By the induction hypothesis, each of t1 and t2 either is
       a value or can take a step. *)
        right.
        destruct IHHt1; subst...
        + (* t1 is a value *)
          destruct IHHt2; subst...
          * (* t2 is a value *)
            (* If both t1 and t2 are values, then we know that
           t1 = abs x T11 t12, since abstractions are the
           only values that can have an arrow type.  But
           (abs x T11 t12) t2 --> [x:=t2]t12 by ST_AppAbs. *)
            inversion H; subst; try solve_by_invert.
            exists(subst x t2 t12)...
          * (* t2 steps *)
            (* If t1 is a value and t2 --> t2',
           then t1 t2 --> t1 t2' by ST_App2. *)
            inversion H0 as [t2' Hstp]. exists (app t1 t2')...
        + (* t1 steps *)
          (* Finally, If t1 --> t1', then t1 t2 --> t1' t2
         by ST_App1. *)
          inversion H as [t1' Hstp]. exists (app t1' t2)...
      - (* T_Nat *)
        left...
      - (* T_Succ *)
        right.
        destruct IHHt...
        + (* t1 is a value *)
          inversion H; subst; try solve_by_invert.
          exists (const (S n1))...
        + (* t1 steps *)
          inversion H as [t1' Hstp].
          exists (scc t1')...
      - (* T_Pred *)
        right.
        destruct IHHt...
        + (* t1 is a value *)
          inversion H; subst; try solve_by_invert.
          exists(const (pred n1))...
        + (* t1 steps *)
          inversion H as [t1' Hstp].
          exists(prd t1')...
      - (* T_Mult *)
        right.
        destruct IHHt1...
        + (* t1 is a value *)
          destruct IHHt2...
          * (* t2 is a value *)
            inversion H; subst; try solve_by_invert.
            inversion H0; subst; try solve_by_invert.
            exists(const (mult n1 n0))...
          * (* t2 steps *)
            inversion H0 as [t2' Hstp].
            exists(mlt t1 t2')...
        + (* t1 steps *)
          inversion H as [t1' Hstp].
          exists(mlt t1' t2)...
      - (* T_Test0 *)
        right.
        destruct IHHt1...
        + (* t1 is a value *)
          inversion H; subst; try solve_by_invert.
          destruct n1 as [|n1'].
          * (* n1=0 *)
            exists t2...
          * (* n1<>0 *)
            exists t3...
        + (* t1 steps *)
          inversion H as [t1' H0].
          exists (test0 t1' t2 t3)...
      - (* T_Inl *)
        destruct IHHt...
        + (* t1 steps *)
          right. inversion H as [t1' Hstp]...
      (* exists (tinl _ t1')... *)
      - (* T_Inr *)
        destruct IHHt...
        + (* t1 steps *)
          right. inversion H as [t1' Hstp]...
      (* exists (tinr _ t1')... *)
      - (* T_Case *)
        right.
        destruct IHHt1...
        + (* t0 is a value *)
          inversion H; subst; try solve_by_invert.
          * (* t0 is inl *)
            exists ([x1:=v]t1)...
          * (* t0 is inr *)
            exists ([x2:=v]t2)...
        + (* t0 steps *)
          inversion H as [t0' Hstp].
          exists (tcase t0' x1 t1 x2 t2)...
      - (* T_Nil *)
        left...
      - (* T_Cons *)
        destruct IHHt1...
        + (* head is a value *)
          destruct IHHt2...
          * (* tail steps *)
            right. inversion H0 as [t2' Hstp].
            exists (tcons t1 t2')...
        + (* head steps *)
          right. inversion H as [t1' Hstp].
          exists (tcons t1' t2)...
      - (* T_Lcase *)
        right.
        destruct IHHt1...
        + (* t1 is a value *)
          inversion H; subst; try solve_by_invert.
          * (* t1=tnil *)
            exists t2...
          * (* t1=tcons v1 vl *)
            exists ([x2:=vl]([x1:=v1]t3))...
        + (* t1 steps *)
          inversion H as [t1' Hstp].
          exists (tlcase t1' t2 x1 x2 t3)...
      - (* T_Unit *)
        left...
      - (* pairs *)
        destruct IHHt1...
        + (* t1 is value *)
          destruct IHHt2...
          inversion H0. eauto.
        + (* t1 steps *)
          destruct IHHt2...
          inversion H. eauto.
          destruct H. destruct H0. eauto.
      - (* fst *)
        destruct IHHt...
        right. inversion Ht;subst; try solve_by_invert.
        inversion H;subst. eauto.
        right. destruct H. eauto.
      - destruct IHHt...
        right. inversion Ht; subst;try solve_by_invert.
        inversion H...
        right. destruct H...
      - (* let *)
        right.
        destruct IHHt1...
        destruct H...
      - (* fix *)
        right.
        destruct IHHt...
        inversion H;subst; try solve_by_invert.
        eauto.
        destruct H...
    Qed.

    Inductive appears_free_in : string -> tm -> Prop :=
    | afi_var : forall x,
        appears_free_in x (var x)
    | afi_app1 : forall x t1 t2,
        appears_free_in x t1 -> appears_free_in x (app t1 t2)
    | afi_app2 : forall x t1 t2,
        appears_free_in x t2 -> appears_free_in x (app t1 t2)
    | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
    (* numbers *)
    | afi_succ : forall x t,
        appears_free_in x t ->
        appears_free_in x (scc t)
    | afi_pred : forall x t,
        appears_free_in x t ->
        appears_free_in x (prd t)
    | afi_mult1 : forall x t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (mlt t1 t2)
    | afi_mult2 : forall x t1 t2,
        appears_free_in x t2 ->
        appears_free_in x (mlt t1 t2)
    | afi_test01 : forall x t1 t2 t3,
        appears_free_in x t1 ->
        appears_free_in x (test0 t1 t2 t3)
    | afi_test02 : forall x t1 t2 t3,
        appears_free_in x t2 ->
        appears_free_in x (test0 t1 t2 t3)
    | afi_test03 : forall x t1 t2 t3,
        appears_free_in x t3 ->
        appears_free_in x (test0 t1 t2 t3)
    (* sums *)
    | afi_inl : forall x t T,
        appears_free_in x t ->
        appears_free_in x (tinl T t)
    | afi_inr : forall x t T,
        appears_free_in x t ->
        appears_free_in x (tinr T t)
    | afi_case0 : forall x t0 x1 t1 x2 t2,
        appears_free_in x t0 ->
        appears_free_in x (tcase t0 x1 t1 x2 t2)
    | afi_case1 : forall x t0 x1 t1 x2 t2,
        x1 <> x ->
        appears_free_in x t1 ->
        appears_free_in x (tcase t0 x1 t1 x2 t2)
    | afi_case2 : forall x t0 x1 t1 x2 t2,
        x2 <> x ->
        appears_free_in x t2 ->
        appears_free_in x (tcase t0 x1 t1 x2 t2)
    (* lists *)
    | afi_cons1 : forall x t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (tcons t1 t2)
    | afi_cons2 : forall x t1 t2,
        appears_free_in x t2 ->
        appears_free_in x (tcons t1 t2)
    | afi_lcase1 : forall x t1 t2 y1 y2 t3,
        appears_free_in x t1 ->
        appears_free_in x (tlcase t1 t2 y1 y2 t3)
    | afi_lcase2 : forall x t1 t2 y1 y2 t3,
        appears_free_in x t2 ->
        appears_free_in x (tlcase t1 t2 y1 y2 t3)
    | afi_lcase3 : forall x t1 t2 y1 y2 t3,
        y1 <> x ->
        y2 <> x ->
        appears_free_in x t3 ->
        appears_free_in x (tlcase t1 t2 y1 y2 t3)

    (* Add rules for the following extensions. *)

    (* pairs *)
    | afi_pair1 : forall x t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (pair t1 t2)
    | afi_pair2 : forall x t1 t2,
        appears_free_in x t2 ->
        appears_free_in x (pair t1 t2)
    | afi_fst : forall x t,
        appears_free_in x t ->
        appears_free_in x (fst t)
    | afi_snd : forall x t,
        appears_free_in x t ->
        appears_free_in x (snd t)
    (* let *)
    (* y is not in t1 here no no need to check eq of x y *)
    | afi_let1 : forall x y t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (tlet y t1 t2)
    | afi_let2 : forall x y t1 t2,
        x <> y ->
        appears_free_in x t2 ->
        appears_free_in x (tlet y t1 t2)
    (* fix *)
    | afi_fix : forall x t,
        appears_free_in x t ->
        appears_free_in x (tfix t)
    .
    Hint Constructors appears_free_in.

    Lemma context_invariance : forall Gamma Gamma' t S,
        Gamma |- t ∈ S ->
        (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
        Gamma' |- t ∈ S.
    (* Increasing the depth of eauto allows some more simple cases to
   be dispatched automatically. *)
    Proof with eauto 30.
      intros. generalize dependent Gamma'.
      induction H;
        intros Gamma' Heqv...
      - (* T_Var *)
        apply T_Var... rewrite <- Heqv...
      - (* T_Abs *)
        apply T_Abs... apply IHhas_type. intros y Hafi.
        unfold update, t_update.
        destruct (eqb_stringP x y)...
      - (* T_Case *)
        eapply T_Case...
        + apply IHhas_type2. intros y Hafi.
          unfold update, t_update.
          destruct (eqb_stringP x1 y)...
        + apply IHhas_type3. intros y Hafi.
          unfold update, t_update.
          destruct (eqb_stringP x2 y)...
      - (* T_Lcase *)
        eapply T_Lcase... apply IHhas_type3. intros y Hafi.
        unfold update, t_update.
        destruct (eqb_stringP x1 y)...
        destruct (eqb_stringP x2 y)...
      - (* T_Let *)
        econstructor.
        eapply IHhas_type1. intros. apply Heqv.
        econstructor...
        eapply IHhas_type2. intros.
        unfold update, t_update.
        destruct (eqb_stringP x x0)...
    Qed.

    Lemma free_in_context : forall x t T Gamma,
        appears_free_in x t ->
        Gamma |- t ∈ T ->
        exists T', Gamma x = Some T'.
    Proof with eauto.
      intros x t T Gamma Hafi Htyp.
      induction Htyp; inversion Hafi; subst...
      - (* T_Abs *)
        destruct IHHtyp as [T' Hctx]... exists T'.
        unfold update, t_update in Hctx.
        rewrite false_eqb_string in Hctx...
      (* T_Case *)
      - (* left *)
        destruct IHHtyp2 as [T' Hctx]... exists T'.
        unfold update, t_update in Hctx.
        rewrite false_eqb_string in Hctx...
      - (* right *)
        destruct IHHtyp3 as [T' Hctx]... exists T'.
        unfold update, t_update in Hctx.
        rewrite false_eqb_string in Hctx...
      - (* T_Lcase *)
        clear Htyp1 IHHtyp1 Htyp2 IHHtyp2.
        destruct IHHtyp3 as [T' Hctx]... exists T'.
        unfold update, t_update in Hctx.
        rewrite false_eqb_string in Hctx...
        rewrite false_eqb_string in Hctx...
      - (* T_Let *)
        apply IHHtyp2 in H4. destruct H4. exists x1.
        unfold update, t_update in H.
        rewrite false_eqb_string in H...
    Qed.

    Lemma substitution_preserves_typing : forall Gamma x U v t S,
        (update Gamma x U) |- t ∈ S ->
        empty |- v ∈ U ->
        Gamma |- ([x:=v]t) ∈ S.
    Proof with eauto.
      (* Theorem: If (x⊢>U ; Gamma) ⊢ t ∈ S and empty ⊢ v ∈ U,
     then Gamma ⊢ [x:=v]t ∈ S. *)
      intros Gamma x U v t S Htypt Htypv.
      generalize dependent Gamma. generalize dependent S.
      (* Proof: By induction on the term t.  Most cases follow
     directly from the IH, with the exception of var
     and abs. These aren't automatic because we must
     reason about how the variables interact. *)
      induction t;
        intros S Gamma Htypt; simpl; inversion Htypt; subst...
      - (* var *)
        simpl. rename s into y.
        (* If t = y, we know that empty ⊢ v ∈ U
                            and (x⊢>U;Gamma) ⊢ y ∈ S
       and, by inversion, update Gamma x U y = Some S.
       We want to show that Gamma ⊢ [x:=v]y ∈ S.

       There are two cases to consider: either x=y or x≠y. *)
        unfold update, t_update in H1.
        destruct (eqb_stringP x y).
        + (* x=y *)
          (* If x = y, then we know that U = S, and that
         [x:=v]y = v.  So what we really must show is
         that if empty ⊢ v ∈ U then Gamma ⊢ v ∈ U.
         We have already proven a more general version
         of this theorem, called context invariance. *)
          subst.
          inversion H1; subst. clear H1.
          eapply context_invariance...
          intros x Hcontra.
          destruct (free_in_context _ _ S empty Hcontra)
            as [T' HT']...
          inversion HT'.
        + (* x<>y *)
          (* If x ≠ y, then Gamma y = Some S and the substitution has no
       effect.  We can show that Gamma ⊢ y ∈ S by T_Var. *)
          apply T_Var...
      - (* abs *)
        rename s into y. rename t into T11.
        (* If t = abs y T11 t0, then we know that
         (x⊢>U;Gamma) ⊢ abs y T11 t0 ∈ T11→T12
         (y⊢>T11;x⊢>U;Gamma) ⊢ t0 ∈ T12
         empty ⊢ v ∈ U
       As our IH, we know that for all S and Gamma,
         if (x⊢>U;Gamma) ⊢ t0 ∈ S
         then Gamma ⊢ [x:=v]t0 ∈ S.

       We can calculate that
         [x:=v]t = abs y T11 (if eqb_string x y then t0 else [x:=v]t0)
       And we must show that Gamma ⊢ [x:=v]t ∈ T11→T12.  We know
       we will do so using T_Abs, so it remains to be shown that:
         (y⊢>T11;Gamma) ⊢ if eqb_string x y then t0 else [x:=v]t0 ∈ T12
       We consider two cases: x = y and x ≠ y.
         *)
        apply T_Abs...
        destruct (eqb_stringP x y) as [Hxy|Hxy].
        + (* x=y *)
          (* If x = y, then the substitution has no effect.  Context
       invariance shows that y:T11;y⊢>U;Gamma and y⊢>T11;Gamma
       are equivalent.  Since the former context shows that
       t0 ∈ T12, so does the latter. *)
          eapply context_invariance...
          subst.
          intros x Hafi. unfold update, t_update.
          destruct (eqb_string y x)...
        + (* x<>y *)
          (* If x ≠ y, then the IH and context invariance allow
         us to show that
           (y⊢>T11;x⊢>U;Gamma) ⊢ t0 ∈ T12       =>
           (x⊢>U;y⊢>T11;Gamma) ⊢ t0 ∈ T12       =>
           (y⊢>T11;Gamma) ⊢ [x:=v]t0 ∈ T12 *)
          apply IHt. eapply context_invariance...
          intros z Hafi. unfold update, t_update.
          destruct (eqb_stringP y z) as [Hyz|Hyz]...
          subst.
          rewrite false_eqb_string...
      - (* tcase *)
        rename s into x1. rename s0 into x2.
        eapply T_Case...
        + (* left arm *)
          destruct (eqb_stringP x x1) as [Hxx1|Hxx1].
          * (* x = x1 *)
            eapply context_invariance...
            subst.
            intros z Hafi. unfold update, t_update.
            destruct (eqb_string x1 z)...
          * (* x <> x1 *)
            apply IHt2. eapply context_invariance...
            intros z Hafi. unfold update, t_update.
            destruct (eqb_stringP x1 z) as [Hx1z|Hx1z]...
            subst. rewrite false_eqb_string...
        + (* right arm *)
          destruct (eqb_stringP x x2) as [Hxx2|Hxx2].
          * (* x = x2 *)
            eapply context_invariance...
            subst.
            intros z Hafi. unfold update, t_update.
            destruct (eqb_string x2 z)...
          * (* x <> x2 *)
            apply IHt3. eapply context_invariance...
            intros z Hafi. unfold update, t_update.
            destruct (eqb_stringP x2 z)...
            subst. rewrite false_eqb_string...
      - (* tlcase *)
        rename s into y1. rename s0 into y2.
        eapply T_Lcase...
        destruct (eqb_stringP x y1).
        + (* x=y1 *)
          simpl.
          eapply context_invariance...
          subst.
          intros z Hafi. unfold update, t_update.
          destruct (eqb_stringP y1 z)...
        + (* x<>y1 *)
          destruct (eqb_stringP x y2).
          * (* x=y2 *)
            eapply context_invariance...
            subst.
            intros z Hafi. unfold update, t_update.
            destruct (eqb_stringP y2 z)...
          * (* x<>y2 *)
            apply IHt3. eapply context_invariance...
            intros z Hafi. unfold update, t_update.
            destruct (eqb_stringP y1 z)...
            subst. rewrite false_eqb_string...
            destruct (eqb_stringP y2 z)...
            subst. rewrite false_eqb_string...
      - (* tlet *)
        econstructor...
        destruct (eqb_stringP x s).
        + subst.
          rewrite update_shadow in H5...
        + apply IHt2.
          rewrite update_permute...
    Qed.

    Theorem preservation : forall t t' T,
        empty |- t ∈ T ->
        t --> t' ->
        empty |- t' ∈ T.
    Proof with eauto.
      intros t t' T HT.
      (* Theorem: If empty ⊢ t ∈ T and t --> t', then
     empty ⊢ t' ∈ T. *)
      remember empty as Gamma. generalize dependent HeqGamma.
      generalize dependent t'.
      (* Proof: By induction on the given typing derivation.  Many
     cases are contradictory (T_Var, T_Abs).  We show just
     the interesting ones. *)
      induction HT;
        intros t' HeqGamma HE; subst; inversion HE; subst...
      - (* T_App *)
        (* If the last rule used was T_App, then t = t1 t2, and
       three rules could have been used to show t --> t':
       ST_App1, ST_App2, and ST_AppAbs. In the first two
       cases, the result follows directly from the IH. *)
        inversion HE; subst...
        + (* ST_AppAbs *)
          (* For the third case, suppose
           t1 = abs x T11 t12
         and
           t2 = v2.
         We must show that empty ⊢ [x:=v2]t12 ∈ T2.
         We know by assumption that
             empty ⊢ abs x T11 t12 ∈ T1→T2
         and by inversion
             x⊢>T1 ⊢ t12 ∈ T2
         We have already proven that substitution preserves
         typing, and
             empty ⊢ v2 ∈ T1
         by assumption, so we are done. *)
          apply substitution_preserves_typing with T1...
          inversion HT1...
      (* T_Case *)
      - (* ST_CaseInl *)
        inversion HT1; subst.
        eapply substitution_preserves_typing...
      - (* ST_CaseInr *)
        inversion HT1; subst.
        eapply substitution_preserves_typing...
      - (* T_Lcase *)
        + (* ST_LcaseCons *)
          inversion HT1; subst.
          apply substitution_preserves_typing with (List T1)...
          apply substitution_preserves_typing with T1...
      - inversion HT;subst...
      - inversion HT;subst...
      - eapply substitution_preserves_typing...
      - eapply substitution_preserves_typing...
        inversion HT;subst...
    Qed.

End STLCExtended.


Require Import FiatFormal.Data.List.Base.
Require Import FiatFormal.Data.Nat.
Require Import FiatFormal.Tactics.

(* Replace the element at point in the list.
   If the list is shorter than expected then do nothing
 *)
Fixpoint replace {A: Type} (ix: nat) (x': A) (xs: list A) : list A :=
 match ix, xs with
 | _,     nil      => nil
 | S ix', y :: xs' => y  :: (replace ix' x' xs')
 | O    , x :: xs' => x' :: xs'
 end.

Lemma replace_nil
 :  forall {A} n (x : A)
 ,  replace n x nil = nil.
Proof.
 intros. destruct n; auto.
Qed.

Lemma replace_length
 : forall {A} n x (xs : list A)
 , length (replace n x xs) = length xs.
Proof.
 intros. gen n.
 induction xs; intros.
  rewrite replace_nil; auto.
  destruct n; burn.
Qed.

Lemma replace_get_eq
 :  forall {A} (xs: list A) x x' n
 ,  get n xs                  = Some x
 -> get n (replace n x' xs)   = Some x'.
Proof.
 intros. gen n.
 induction xs; intros.
  rewrite replace_nil.
   false.
  destruct n.
   simpl. auto.
   simpl. simpl in H.
   auto.
Qed.
Hint Resolve replace_get_eq.

Lemma replace_get_neq
 :  forall {A} (xs: list A) x n0 n1
 ,  n0 <> n1
 -> get n0 (replace n1 x xs) = get n0 xs.
Proof.
 intros. gen n0 n1.
 induction xs; intros.
  rewrite replace_nil. auto.
  destruct n1.
   simpl.
   destruct n0.
    burn. auto.
   simpl.
   destruct n0.
    auto. auto.
Qed.
Hint Resolve replace_get_neq.

Lemma replace_id
 :  forall {A} x (xs: list A) i
 ,  get i xs = Some x
 -> replace i x xs = xs.
Proof.
 intros. gen i.
 induction xs; intros.
  rewrite replace_nil. auto.
  destruct i.
   simpl.
   simpl in H. inverts H. auto.
   simpl. rs.
Qed.
Hint Resolve replace_id.


(** * matrix: constructing matrices over the various typed structures

   Given an [l]-monoid structure, we build an [l]-monoid of matrices
   above it.  This works whenever we have unions and bottom elements
   ([BSL ≪ l]) for structures without residuals; to build residuals, we
   moreover need intersections and top elements ([BDL ≪ l]).

   We do these constructions once and forall, thanks to our
   first-class level constraints.

   We can build rectangular matrices, and not only square ones, thanks
   to our typed structures: [MX n m] denotes the set of [(n,m)]-matrices. *)

Require Export comparisons.
Require Import kleene sums normalisation.
Import lset Fix ordinal.

(** A matrix of size [(n,m)] over a set [X] is just a curried function
   from indices ([ord n ⋅ ord m]) to [X] *)
Definition mx X n m := ord n -> ord m -> X.

(** * [(n,m)]-matrices as a lattice *)

(** when X is a lattice, matrix lattice operations and laws are
   obtained for free, by two successive pointwise liftings of X *)

Canonical Structure mx_lattice_ops (X: lattice.ops) n m :=
  lattice.mk_ops (mx X n m) leq weq cup cap neg bot top.

#[export] Instance mx_lattice_laws `{L: lattice.laws} n m: lattice.laws l (mx_lattice_ops X n m).
Proof. apply pw_laws. Qed.

(** supremums (or sums) are computed pointwise *)
Lemma mx_sup `{X: lattice.ops} n m I J (f: I -> mx X n m) i j:
  (\sup_(x\in J) f x) i j = \sup_(x\in J) f x i j.
Proof. apply (f_sup_eq (fun x: mx X n m => x i j)); now f_equal. Qed.

Section d.

Context {X: Type}.
Notation mx := (mx X).

(** ** scalar (1,1)-matrices *)

Definition scal_mx x: mx 1 1 := fun _ _ => x.
Definition mx_scal (M: mx 1 1) := M ord0 ord0.

(** ** block matrix operations *)

(** following ssreflect methodology, we decompose the standard block
   matrix construction, with four quadrants, into two constructions,
   for column and line block matrices. *)

Definition col_mx {n1 n2 m} (M1: mx n1 m) (M2: mx n2 m): mx (n1+n2) m :=
  fun i j =>
    match split i with
      | inl i1 => M1 i1 j
      | inr i2 => M2 i2 j
    end.
Definition row_mx {n m1 m2} (M1: mx n m1) (M2: mx n m2): mx n (m1+m2) :=
  fun i j =>
    match split j with
      | inl j1 => M1 i j1
      | inr j2 => M2 i j2
    end.

Definition blk_mx {n1 n2 m1 m2} (A: mx n1 m1) (B: mx n1 m2) (C: mx n2 m1) (D: mx n2 m2) :=
  col_mx (row_mx A B) (row_mx C D).

Definition tsub_mx {n1 n2 m} (M: mx (n1+n2) m): mx n1 m :=
  fun i j => M (lshift i) j.
Definition bsub_mx {n1 n2 m} (M: mx (n1+n2) m): mx n2 m :=
  fun i j => M (rshift i) j.
Definition lsub_mx {n m1 m2} (M: mx n (m1+m2)): mx n m1 :=
  fun i j => M i (lshift j).
Definition rsub_mx {n m1 m2 }(M: mx n (m1+m2)): mx n m2 :=
  fun i j => M i (rshift j).

Definition sub00_mx {n1 n2 m1 m2} (M: mx (n1+n2) (m1+m2)) := tsub_mx (lsub_mx M).
Definition sub01_mx {n1 n2 m1 m2} (M: mx (n1+n2) (m1+m2)) := tsub_mx (rsub_mx M).
Definition sub10_mx {n1 n2 m1 m2} (M: mx (n1+n2) (m1+m2)) := bsub_mx (lsub_mx M).
Definition sub11_mx {n1 n2 m1 m2} (M: mx (n1+n2) (m1+m2)) := bsub_mx (rsub_mx M).

End d.

(** all block matrix operations are monotone *)

#[export] Instance col_mx_leq `{L: lattice.laws} n1 n2 m: Proper (leq ==> leq ==> leq) (@col_mx X n1 n2 m).
Proof.
  intros ? ? H ? ? H' i j. unfold col_mx.
  case split_spec; intros ? ->. apply H. apply H'.
Qed.
#[export] Instance col_mx_weq `{L: lattice.laws} n1 n2 m: Proper (weq ==> weq ==> weq) (@col_mx X n1 n2 m)
  := op_leq_weq_2.

Lemma col_mx_leq_iff `{L: lattice.laws} n1 n2 m M1 M2 N1 N2:
  @col_mx X n1 n2 m M1 M2 ≦ col_mx N1 N2 <-> M1 ≦N1 /\ M2 ≦N2.
Proof.
  split. unfold col_mx. intro H. split; intros i j.
  generalize (H (lshift i) j). now rewrite split_lshift.
  generalize (H (rshift i) j). now rewrite split_rshift.
  intros [? ?]. now apply col_mx_leq.
Qed.

#[export] Instance row_mx_leq `{L: lattice.laws} n m1 m2: Proper (leq ==> leq ==> leq) (@row_mx X n m1 m2).
Proof.
  intros ? ? H ? ? H' i j. unfold row_mx.
  case split_spec; intros i' ->. apply H. apply H'.
Qed.
#[export] Instance row_mx_weq `{L: lattice.laws} n m1 m2: Proper (weq ==> weq ==> weq) (@row_mx X n m1 m2)
  := op_leq_weq_2.

Lemma row_mx_leq_iff `{L: lattice.laws} n m1 m2 M1 M2 N1 N2:
  @row_mx X n m1 m2 M1 M2 ≦ row_mx N1 N2 <-> M1 ≦N1 /\ M2 ≦N2.
Proof.
  split. unfold row_mx. intro H. split; intros i j.
  generalize (H i (lshift j)). now rewrite split_lshift.
  generalize (H i (rshift j)). now rewrite split_rshift.
  intros [? ?]. now apply row_mx_leq.
Qed.

#[export] Instance blk_mx_leq `{L: lattice.laws} n1 n2 m1 m2:
  Proper (leq ==> leq ==> leq ==> leq ==> leq) (@blk_mx X n1 n2 m1 m2).
Proof. do 12 intro. now apply col_mx_leq; apply row_mx_leq. Qed.

#[export] Instance blk_mx_weq `{L: lattice.laws} n1 n2 m1 m2:
  Proper (weq ==> weq ==> weq ==> weq ==> weq) (@blk_mx X n1 n2 m1 m2).
Proof. do 12 intro. now apply col_mx_weq; apply row_mx_weq. Qed.

Lemma blk_mx' `{L: lattice.laws} {n1 n2 m1 m2} A B C D:
  @blk_mx X n1 n2 m1 m2 A B C D ≡ row_mx (col_mx A C) (col_mx B D).
Proof.
  intros i j. unfold blk_mx, row_mx, col_mx.
  case split; case split; intros; reflexivity.
Qed.

Lemma to_col_mx `{L: lattice.laws} {n1 n2 m} (M: mx X (n1+n2) m):
  M ≡ col_mx (tsub_mx M) (bsub_mx M).
Proof.
  intros i j. unfold col_mx, tsub_mx, bsub_mx.
  now case split_spec; intros i' ->.
Qed.

Lemma to_row_mx `{L: lattice.laws} {n m1 m2} (M: mx X n (m1+m2)):
  M ≡ row_mx (lsub_mx M) (rsub_mx M).
Proof.
  intros i j. unfold row_mx, lsub_mx, rsub_mx.
  now case split_spec; intros i' ->.
Qed.

Lemma to_blk_mx `{L: lattice.laws} {n1 n2 m1 m2} (M: mx X (n1+n2) (m1+m2)):
  M ≡ blk_mx (sub00_mx M) (sub01_mx M) (sub10_mx M) (sub11_mx M).
Proof. rewrite to_row_mx at 1. rewrite to_col_mx. reflexivity. Qed.

Lemma col_mx_cup `{L: lattice.laws} n1 n2 m M M' N N':
  @col_mx X n1 n2 m (M ⊔ M') (N ⊔ N') ≡ col_mx M N ⊔ col_mx M' N'.
Proof. intros i j. unfold col_mx. simpl. case split; reflexivity. Qed.

Lemma row_mx_cup `{L: lattice.laws} n m1 m2 M M' N N':
  @row_mx X n m1 m2 (M ⊔ M') (N ⊔ N') ≡ row_mx M N ⊔ row_mx M' N'.
Proof. intros i j. unfold row_mx. simpl. case split; reflexivity. Qed.

(** * [(n,m)]-matrices as a monoid *)

(** when [X] is at least an idempotent semiring ([BSL]), the set of matrices
   has a monoid structure *)

(** Note: since the underlying monoid ([X]) is typed a priori, we
   could do a much more general matrix construction, using heavily
   dependent types. We do not need it since we actually construct
   matrices on [bool], [Prop], and [regex], which are all flat
   monoids.  Therefore, we simply fix a object [u] of [X], and we
   construct matrices on [X u u]. ([u] will be instantiated with the
   unique objects of the aformentioned models.) *)

Section m.
Variable X: ops.
Variable u: ob X.
Notation U := (car (@mor X u u)).
Notation mx := (mx U).

(** identity matrix  *)
Definition mx_one n: mx n n :=
  fun i j => ofbool (eqb_ord i j).

(** matrix product  *)
Definition mx_dot n m p (M: mx n m) (N: mx m p): mx n p :=
  fun i k => \sum_(j<m) M i j ⋅ N j k.
Local Infix "**" := (mx_dot _ _ _) (at level 40).

(** left and right residuals (using infimums, as explained above)  *)
Definition mx_ldv n m p (M: mx n m) (N: mx n p): mx m p :=
  fun j k => \inf_(i<n) (M i j -o N i k).

Definition mx_rdv n m p (M: mx m n) (N: mx p n): mx p m :=
  fun k j => \inf_(i<n) (N k i o- M j i).

(** transposed matrix (note that the elements are also transposed) *)
Definition mx_cnv n m (M: mx n m): mx m n :=
  fun i j => (M j i)°.

(** Kleene star of a matrix, defined inductively, by block matrix constructions *)

(** we follow standard textbooks and papers, except that we define
   first an auxiliary function, which we iterate to get the final
   matrix construction: this allows us to state easily that the actual
   block decomposition used doesn't matter [matrix_ext.mx_str_blk] *)

Definition mx_str_build n m
  (sn: mx n n -> mx n n) (sm: mx m m -> mx m m)
  (M: mx (n+m) (n+m)): mx (n+m) (n+m) :=
  let a := sub00_mx M in
  let b := sub01_mx M in
  let c := sub10_mx M in
  let d := sub11_mx M in
  let e := sm d in
  let be:= b**e in
  let ec:= e**c in
  let f := sn (a ⊔ be**c) in
  let fbe := f**be in
  let ecf := ec**f in
    blk_mx f fbe ecf (e ⊔ ecf**be).

Fixpoint mx_str n: mx n n -> mx n n :=
  match n with
    | O => fun M => M
    | S n => mx_str_build 1 n (fun M => scal_mx ((mx_scal M)^*)) (mx_str n)
  end.

(** strict iteration is derived from Kleene star *)
Definition mx_itr n M := M ** mx_str n M.

(** packing all operations as a canonical structure *)
Canonical Structure mx_ops :=
  mk_ops nat _ mx_dot mx_one mx_itr mx_str mx_cnv mx_ldv mx_rdv.

End m.

(** ** matrices form a BSL-monoid *)

(** we prove that the matrix constructions are correct in two steps:
   we first get the BSL-structure (idempotent semirings), and then we
   add the laws corresponding to the other operations. This allows us
   to benefit from tools about idempotent semirings for the latter
   proofs, notably for Kleene star. *)

Section bsl.
Context `{L: laws} `{Hl: BSL ≪ l} {u: ob X}.
Notation U := (car (@mor X u u)).
Notation mx := (mx U).

(** matrix product is associative *)
Lemma mx_dotA n m p q (M: mx n m) N (P: mx p q): M⋅(N⋅P) ≡ (M⋅N)⋅P.
Proof.
  intros i j. simpl. unfold mx_dot.
  setoid_rewrite dotxsum. rewrite sup_swap.
  apply sup_weq; trivial. intro. rewrite dotsumx.
  apply sup_weq; trivial. intro. apply dotA.
Qed.

(** and admits identities as left and right units *)
Lemma mx_dot1x n m (M: mx n m): 1⋅M ≡ M.
Proof.
  intros i j. simpl. unfold mx_dot, mx_one. apply antisym.
   apply leq_supx. intros i' _. case eqb_ord_spec; simpl.
    intros <-. apply weq_leq, dot1x.
    intros _. rewrite dot0x. apply leq_bx.
   rewrite <- (leq_xsup _ _ i) by apply in_seq.
   rewrite eqb_refl. simpl. now rewrite dot1x.
Qed.

Lemma mx_dotx1 n m (M: mx m n): M⋅1 ≡ M.
Proof.
  intros i j. simpl. unfold mx_dot, mx_one. apply antisym.
   apply leq_supx. intros i' _. case eqb_ord_spec; simpl.
    intros <-. apply weq_leq, dotx1.
    intros _. rewrite dotx0. apply leq_bx.
   rewrite <- (leq_xsup _ _ j) by apply in_seq.
   rewrite eqb_refl. simpl. now rewrite dotx1.
Qed.

(** matrix product is monotone *)
Lemma mx_dot_leq n m p: Proper (leq ==> leq ==> leq) (mx_dot X u n m p).
Proof.
  intros ? ? H ? ? H' i j. apply sup_leq; trivial. intro k.
  apply dot_leq. apply H. apply H'.
Qed.

(** matrix product distributes over the sup-semilattice structure *)

Lemma mx_dotplsx_ n m p (M N: mx n m) (P: mx m p): (M+N)⋅P ≦ M⋅P+N⋅P.
Proof. intros i j. simpl. unfold mx_dot. setoid_rewrite dotplsx. now rewrite supcup. Qed.

Lemma mx_dotxpls_ n m p (M N: mx m n) (P: mx p m): P⋅(M+N) ≦ P⋅M+P⋅N.
Proof. intros i j. simpl. unfold mx_dot. setoid_rewrite dotxpls. now rewrite supcup. Qed.

Lemma mx_dot0x_ n m p (P: mx m p): (zer n m)⋅P ≦ 0.
Proof.
  intros i j. simpl. unfold mx_dot. setoid_rewrite dot0x.
  apply leq_supx. intros. apply leq_bx.
Qed.

Lemma mx_dotx0_ n m p (P: mx p m): P⋅(zer m n) ≦ 0.
Proof.
  intros i j. simpl. unfold mx_dot. setoid_rewrite dotx0.
  apply leq_supx. intros. apply leq_bx.
Qed.

(** packing everything, we get a [BSL]-monoid structure *)
Instance mx_bsl_laws: laws BSL (mx_ops X u).
Proof.
  constructor; try discriminate; repeat right.
  intros. apply lower_lattice_laws.
  exact mx_dotA.
  exact mx_dot1x.
  exact mx_dotx1.
  exact mx_dot_leq.
  exact mx_dotplsx_.
  exact mx_dotxpls_.
  exact mx_dot0x_.
  exact mx_dotx0_.
Qed.

(** ** properties of block matrix multiplication *)

Lemma mx_dot_colx n1 n2 m p (M1: mx n1 m) (M2: mx n2 m) (N: mx m p):
  col_mx M1 M2 ⋅ N ≡ col_mx (M1⋅N) (M2⋅N).
Proof. intros i j. simpl. unfold mx_dot, col_mx. now case split_spec; intros i' ->. Qed.

Lemma mx_dot_xrow n m1 m2 p (M1: mx n m1) (M2: mx n m2) (N: mx p n):
  N ⋅ row_mx M1 M2 ≡ row_mx (N⋅M1) (N⋅M2).
Proof. intros i j. simpl. unfold mx_dot, row_mx. now case split_spec; intros i' ->. Qed.

Lemma mx_dot_colrow n1 n2 m p1 p2 (M1: mx n1 m) (M2: mx n2 m) (N1: mx m p1) (N2: mx m p2):
  col_mx M1 M2 ⋅ row_mx N1 N2 ≡ blk_mx (M1⋅N1) (M1⋅N2) (M2⋅N1) (M2⋅N2).
Proof. now rewrite mx_dot_colx, 2mx_dot_xrow. Qed.

Lemma mx_dot_rowcol n m1 m2 p (M1: mx n m1) (M2: mx n m2) (N1: mx m1 p) (N2: mx m2 p):
  row_mx M1 M2 ⋅ col_mx N1 N2 ≡ M1⋅N1 + M2⋅N2.
Proof.
  intros i j. setoid_rewrite sup_cut. unfold row_mx, col_mx.
  setoid_rewrite split_lshift. setoid_rewrite split_rshift. reflexivity.
Qed.

Lemma mx_dot_blk n1 n2 m1 m2 p1 p2
  (M11: mx n1 m1) (M12: mx n1 m2) (M21: mx n2 m1) (M22: mx n2 m2)
  (N11: mx m1 p1) (N12: mx m1 p2) (N21: mx m2 p1) (N22: mx m2 p2):
  blk_mx M11 M12 M21 M22 ⋅ blk_mx N11 N12 N21 N22 ≡
  blk_mx (M11⋅N11+M12⋅N21) (M11⋅N12+M12⋅N22) (M21⋅N11+M22⋅N21) (M21⋅N12+M22⋅N22).
Proof.
  setoid_rewrite blk_mx' at 2. setoid_rewrite mx_dot_colrow.
  now rewrite 4mx_dot_rowcol.
Qed.

Lemma one_blk_mx n m: (1: mx (n+m) (n+m)) ≡ blk_mx 1 0 0 1.
Proof.
  intros i j. unfold blk_mx, col_mx, row_mx.
  case split_spec; intros [i' Hi] ->; case split_spec; intros [j' Hj] ->.
   reflexivity.
   simpl. unfold mx_one. now setoid_rewrite eqb_ord_lrshift.
   simpl. unfold mx_one. now setoid_rewrite eqb_ord_rlshift.
   simpl. unfold mx_one. now setoid_rewrite eqb_ord_rrshift.
Qed.

End bsl.

(** ** matrices have a converse if the underlying monoid has one  *)

Section cbsl.
Context `{L: laws} `{Hl: BSL+CNV ≪ l} {u: ob X}.
Notation U := (car (@mor X u u)).
Notation mx := (mx U).

Canonical Structure lset_ops A := lattice.mk_ops (list A)
  (fun h k => forall a, List.In a h -> List.In a k)
  (fun h k => forall a, List.In a h <-> List.In a k)
  (@app A) (@app A) (assert_false id) (@nil A) (@nil A).

Lemma mx_cnvdot_ n m p (M: mx n m) (N: mx m p): (M⋅N)° ≦ N°⋅M°.
Proof. intros i j. setoid_rewrite cnvsum. now setoid_rewrite cnvdot. Qed.

Lemma mx_cnv_invol n m (M: mx n m): M°° ≡ M.
Proof. intros i j. apply cnv_invol. Qed.

Lemma mx_cnv_leq n m: Proper (leq ==> leq) (mx_cnv X u n m).
Proof. intros ? ? H i j. apply cnv_leq, H. Qed.

Lemma mx_cnv_ext n m (M: mx n m): M ≦ M⋅M°⋅M.
Proof.
  intros i j. simpl. unfold mx_dot, mx_cnv. setoid_rewrite dotsumx.
  rewrite <- (leq_xsup _ _ i) by apply in_seq.
  rewrite <- (leq_xsup _ _ j) by apply in_seq.
  apply cnv_ext.
Qed.

End cbsl.

(** ** matrices have a Kleene star if the underlying monoid has one  *)

Section ka.
Context `{L: laws} `{Hl: BKA ≪ l} {u: ob X}.
Notation U := (car (@mor X u u)).
Notation mx := (mx U).

Existing Instance mx_bsl_laws.

Section build.

(** *** properties of the auxiliary [mx_str_build] functional   *)

(** we prove a slightly more general property about the auxiliary
   [mx_str_build] functionnal, so that we can reuse these proofs to
   establish properties of Kleene star on arbitrary block matrices *)

Variables (n m: nat) (sn: mx n n -> mx n n) (sm: mx m m -> mx m m).
Notation s := (mx_str_build X u n m sn sm).

(** we want to show that the auxiliary [mx_str_build] functionnal
   preserves some invariants ; this is easier to state with the
   following definition *)

Definition transfers (P: forall {p}, mx p p -> mx p p -> Prop) :=
  (forall M, P M (sn M)) ->
  (forall M, P M (sm M)) ->
  (forall M, P M (s  M)).

(** dedicated tactic to unfold [mx_str_build] without losing the
   sharing between the various expressions *)
Ltac unfold_s M :=
  set (a := sub00_mx M);
  set (b := sub01_mx M);
  set (c := sub10_mx M);
  set (d := sub11_mx M);
  set (e := sm d);
  set (f := sn (a + (b⋅e)⋅c));
  change (s M) with (blk_mx f (f⋅(b⋅e)) ((e⋅c)⋅f) (e+((e⋅c)⋅f)⋅(b⋅e))).

(** [mx_str_build] preserves the left star unfolding axiom *)
Lemma mx_str_build_unfold_l: transfers (fun n M sM => 1+M⋅sM ≦ sM).
Proof.
  intros Hf He M. rewrite (to_blk_mx M) at 1. unfold_s M.
  specialize (Hf (a+b⋅e⋅c)). specialize (He d). fold e in He. fold f in Hf.
  clearbody a b c d e f. clear - He Hf L Hl. apply leq_cupx.

  (* TODO: optimize the line below *)
  rewrite one_blk_mx. apply blk_mx_leq; hlattice.

  rewrite mx_dot_blk. apply blk_mx_leq.
  rewrite <- Hf at 3. ra.
  rewrite <- Hf at 3. ra.
  rewrite <- He at 2. ra.
  rewrite <- He at 5 6. ra.
Qed.

(** [mx_str_build] preserves the left induction rule for star *)
Lemma mx_str_build_ind_l: transfers (fun n M sM => forall p (N: mx n p), M⋅N ≦ N -> sM⋅N ≦ N).
Proof.
  intros Hf He M p N. rewrite (to_blk_mx M) at 1. unfold_s M.
  rewrite (to_col_mx N). set (h := tsub_mx N). set (k:= bsub_mx N).
  specialize (Hf (a+b⋅e⋅c) p h). specialize (He d p k). fold e in He. fold f in Hf.
  clearbody a b c d e f h k. clear - He Hf L Hl.
  rewrite 2blk_mx', 2mx_dot_rowcol, 4mx_dot_colx. setoid_rewrite <-col_mx_cup.
  setoid_rewrite col_mx_leq_iff. rewrite 2cup_spec. intros [[Ha Hb] [Hc Hd]].
  specialize (He Hd). revert Hf.
  rewrite 2dotplsx, 4cup_spec, <-!dotA. intro Hf. apply apply in Hf;
  repeat split; repeat (trivial; rewrite ?Ha, ?Hb, ?Hc, ?Hd, ?He, ?Hf).
Qed.

(** [mx_str_build] preserves the right induction rule for star *)
Lemma mx_str_build_ind_r: transfers (fun n M sM => forall p (N: mx p n), N⋅M ≦ N -> N⋅sM ≦ N).
Proof.
  intros Hf He M p N. rewrite (to_blk_mx M) at 1. unfold_s M.
  rewrite (to_row_mx N). set (h := lsub_mx N). set (k:= rsub_mx N).
  specialize (Hf (a+b⋅e⋅c) p h). specialize (He d p k). fold e in He. fold f in Hf.
  clearbody a b c d e f h k. clear - He Hf L Hl. unfold blk_mx.
  rewrite 2mx_dot_rowcol, 4mx_dot_xrow. setoid_rewrite <-row_mx_cup.
  setoid_rewrite row_mx_leq_iff. rewrite 2cup_spec. intros [[Ha Hb] [Hc Hd]].
  specialize (He Hd). revert Hf.
  rewrite 2dotxpls, 4cup_spec, !dotA. intro Hf. apply apply in Hf;
  repeat split; repeat (trivial; rewrite ?Ha, ?Hb, ?Hc, ?Hd, ?He, ?Hf).
Qed.

End build.

(** *** packing everything by induction to get properties of the
   Kleene star matrix construction *)

Lemma mx_str_unfold_l n (M: mx n n): 1 + M ⋅ mx_str _ _ _ M ≦ mx_str _ _ _ M.
Proof.
  induction n. intro i; elim (ord_0_empty i).
  simpl mx_str. apply (mx_str_build_unfold_l 1); trivial.
  intros N i j. simpl. unfold mx_dot, scal_mx, mx_one.
  simpl. setoid_rewrite ord0_unique. simpl. now rewrite cupxb, <-str_unfold_l.
Qed.

Lemma mx_str_refl n (M: mx n n): 1 ≦ mx_str _ _ _ M.
Proof. rewrite <-mx_str_unfold_l. apply leq_xcup. now left. Qed.

Lemma mx_str_cons n (M: mx n n): M ⋅ mx_str _ _ _ M ≦ mx_str _ _ _ M.
Proof. rewrite <-mx_str_unfold_l at 2. apply leq_xcup. now right. Qed.

Lemma mx_str_ind_l n m (M: mx n n) (N: mx n m): M ⋅ N ≦ N -> mx_str _ _ _ M ⋅ N ≦ N.
Proof.
  revert m N. induction n. intros ? ? _ i; elim (ord_0_empty i).
  simpl mx_str. apply (mx_str_build_ind_l 1); trivial. clear M IHn.
  intros M p N H i j. simpl. unfold mx_dot, scal_mx.
  simpl. setoid_rewrite ord0_unique. rewrite cupxb.
  apply str_ind_l. rewrite <-(H ord0 j) at 2.
  apply weq_geq. apply cupxb.
Qed.

Lemma mx_str_ind_r n m (M: mx n n) (N: mx m n): N ⋅ M ≦ N -> N ⋅ mx_str _ _ _ M ≦ N.
Proof.
  revert m N. induction n. intros ? ? _ ? i; elim (ord_0_empty i).
  simpl mx_str. apply (mx_str_build_ind_r 1); trivial. clear M IHn.
  intros M p N H i j. simpl. unfold mx_dot, scal_mx.
  simpl. setoid_rewrite ord0_unique. rewrite cupxb.
  apply str_ind_r. rewrite <-(H i ord0) at 2.
  apply weq_geq. apply cupxb.
Qed.

End ka.

(** * Exported matrix construction

   Matrices on [X] form an [l]-monoid provided that
   1/ [X] is an [l]-monoid, and
   2/ [l] is rich enough (i.e., it contains at least [BSL],
      and [BDL] if [l] has residuals )

   We express the latter constraint using the following definition *)

Definition mx_level l := (if has_div l then BDL+l else BSL+l)%level.

Lemma mx_div_level l : DIV ≪ l -> mx_level l ≪ l -> BDL+DIV ≪ l.
Proof.
  rewrite 3lower_spec. unfold mx_level. simpl.
  case (has_div l). simpl. tauto. intuition discriminate.
Qed.

Local Hint Extern 0 (_ ≪ _) => solve_lower': typeclass_instances.

(* NOTE: the following instance could alternatively be stated as:
   Instance mx_laws {l h X} {L: laws l X} {Hl: mx_level h ≪ l} u: laws h (mx_ops X u).

   We don't do this because we want inferred laws instances to be
   closed (evar free) and "maximal", the inferred instance has the
   maximal possible level. *)

#[export] Instance mx_laws `{L: laws} `{Hl: mx_level l ≪ l} u: laws l (mx_ops X u) |1.
Proof.
  assert (Hl': BSL ≪ l). revert Hl. unfold mx_level. case has_div; intro; solve_lower.
  constructor; repeat right.
  intros. apply pw_laws.
  exact mx_dotA.
  exact mx_dot1x.
  exact mx_dotx1.
  exact mx_dot_leq.
  exact mx_dotplsx_.
  exact mx_dotxpls_.
  exact mx_dot0x_.
  exact mx_dotx0_.
  intro. apply mx_cnvdot_.
  intro. apply mx_cnv_invol.
  intro. apply mx_cnv_leq.
  apply mx_cnv_ext.
  (* TODO: improve constraint resolution *)
  intro. apply (mx_str_refl (Hl:=lower_mergex _ _ _ Hl' H)).
  intro. apply (mx_str_cons (Hl:=lower_mergex _ _ _ Hl' H)).
  intro. apply (mx_str_ind_l (Hl:=lower_mergex _ _ _ Hl' H)).
  apply (mx_str_ind_r (Hl:=lower_mergex _ _ _ Hl' H)).
  reflexivity.
  intros Hl'' n m p M N O i j. simpl. unfold mx_dot, mx_cnv.
  apply (lower_mergex _ _ _ Hl'') in Hl'. clear Hl Hl''.
  rewrite capsupx. setoid_rewrite capxsup. setoid_rewrite dotxsum.
  apply sup_leq; trivial. intro i'. rewrite <- (leq_xsup _ _ i) by apply in_seq. apply capdotx.
  intro Hl''. pose proof (mx_div_level _ Hl'' Hl). clear Hl Hl' Hl''.
   intros. simpl. unfold mx_ldv, mx_dot.
    setoid_rewrite sup_spec. setoid_rewrite inf_spec. setoid_rewrite ldv_spec.
    clear. split; auto using in_seq.
  intro Hl''. pose proof (mx_div_level _ Hl'' Hl). clear Hl Hl' Hl''.
   intros. simpl. unfold mx_rdv, mx_dot.
    setoid_rewrite sup_spec. setoid_rewrite inf_spec. setoid_rewrite rdv_spec.
    clear. split; auto using in_seq.
Qed.


Require Import PropExtensionality.

Definition monic {A B} (f : A -> B) :=
  forall x y, f x = f y -> x = y.

Section Johnstone.

Variables
  (p : Prop)
  (f : Prop -> Prop)
  (m : monic f).

Definition UT := {q | f q}.
Definition VT := {q | f q /\ q}.
Definition UP := exists q, f q.
Definition VP := exists q, f q /\ q.

Definition H0 (w : f True) : VP :=
  ex_intro _ True (conj w I).

Definition H1 (w : VP) : f True :=
  match w with
  | ex_intro _ q (conj w0 w1) =>
    eq_ind _ _ w0 _
      (propositional_extensionality
        _ _
        (conj
          (fun _ => I)
          (fun _ => w1)))
  end.

Definition H2 : f True = VP :=
  propositional_extensionality
    _ _ (conj H0 H1).

Definition H3 (t : UT) :
  proj1_sig t -> VP :=
  match t with
  | exist _ q w0 =>
    fun (w1 : q) =>
      ex_intro _ q (conj w0 w1)
  end.

Definition H4 (t : UT) (w : VP) :
  proj1_sig t :=
  match t, w with
  | exist _ q0 w0, ex_intro _ q1 (conj w1 w2) =>
    eq_ind _ _ w2 _
      (m q1 q0
        (propositional_extensionality
          _ _
          (conj
            (fun _ => w0)
            (fun _ => w1))))
  end.

Definition H5 (t : UT) :
  proj1_sig t = VP :=
  propositional_extensionality _ _
    (conj (H3 t) (H4 t)).

Definition H6 (w : f VP) : UP :=
  ex_intro _ VP w.

Definition H7 (w : UP) : f VP :=
  match w with
  | ex_intro _ q w0 =>
    eq_ind _ _ w0 _ (H5 (exist _ q w0))
  end.

Definition H8 : f VP = UP :=
  propositional_extensionality _ _
    (conj H6 H7).

Definition H9 (t : UT) (v : proj1_sig t) :
  proj1_sig t = UP :=
  match t with
  | exist _ q w0 =>
    propositional_extensionality _ _
      (conj
        (fun _ => ex_intro _ q w0)
        (fun _ => v))
  end.

Definition H10 (w : f True) : f UP :=
  eq_ind _ _ w _
    (H9 (exist _ True w) I).

Definition H11 (w : f UP) : f True :=
  H1
    (ex_intro _ UP
      (conj w (ex_intro _ UP w))).

Definition H12 : f UP = f True :=
  propositional_extensionality _ _
    (conj H11 H10).

Definition H13 : UP = True :=
  m UP True H12.

Definition H14 : f (f True) = True :=
  eq_trans
    (f_equal f H2)
    (eq_trans H8 H13).

Definition H15 (w : f (f p)) : p :=
  eq_ind _ _ I _
    (m True p
      (m (f True) (f p)
        (eq_trans H14
          (propositional_extensionality
            _ _
            (conj
              (fun _ => w)
              (fun _ => I)))))).

Definition H16 (w : p) : f (f p) :=
  eq_ind _ id I _
    (eq_trans (eq_sym H14)
      (f_equal f
        (f_equal f
          (propositional_extensionality
            _ _
            (conj
              (fun _ => w)
              (fun _ => I)))))).

Definition Johnstone : f (f p) = p :=
  propositional_extensionality
    _ _
    (conj H15 H16).

End Johnstone.


Section Pierce.

  Parameter pierce : forall A B, ((A -> B) -> A) -> A.

  Theorem nnpp : forall A, ~~A -> A.
  Proof.
    intros A nna.
    unfold not in *.
    apply (pierce _ False).
    intro na.
    specialize (nna na).
    contradiction.
  Defined.

  Theorem pem : forall A, A \/ ~A.
  Proof.
    intros.
    apply (pierce _ False).
    unfold not in *.
    intro npem.
    right.
    intro a.
    apply npem.
    left.
    exact a.
  Defined.

  Definition pemd A: A \/ ~A := pierce (A \/ ~A) False (fun npem => or_intror (fun a => npem (or_introl a))).

  Theorem ip : forall A B : Prop, (A -> B) <-> (~B -> ~A).
  Proof.
    intros.
    split.
    intro ab.
    unfold not.
    intros nb a.
    apply nb, ab, a.
    intros nbna a.
    destruct (pem B) as [b | nb].
    exact b.
    specialize (nbna nb).
    contradiction.
  Defined.

  Compute pem.

End Pierce.


Inductive and (A B:Prop) : Prop :=
  conj : A -> B -> A /\ B
where "A /\ B" := (and A B) : type_scope.

Goal forall P Q, P /\ Q -> Q /\ P.
Proof.
  intros.
  elim H.
  intros.
  apply conj.
    - trivial.
    - trivial.
Qed.