From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality.
From CDF Require Import Sequences IMP Simulation.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope list_scope.

(** * 2. Compiling IMP to a stack machine *)

(** ** 2.1.  The target language: a stack machine pile *)

(** Our compiler will translate IMP to the language of a simple stack
    machine.  The stack contains numbers and the machine instructions
    pop their arguments off the stack and push their results back.
    This machine is similar to the "Reverse Polish Notation"
    used by old HP pocket calculators.  It is also close to a subset
    of the JVM, the Java virtual machine. *)

(** *** 2.1.1.  Instruction set *)

(** Here is the instruction set of the machine: *)

Inductive instr : Type :=
  | Iconst (n: Z)           (**r push the integer [n] *)
  | Ivar (x: ident)         (**r push the current value of variable [x] *)
  | Isetvar (x: ident)      (**r pop an integer and assign it to variable [x] *)
  | Iadd                    (**r pop two integers, push their sum *)
  | Iopp                    (**r pop one integer, push its opposite *)
  | Ibranch (d: Z)          (**r skip forward or backward [d] instructions *)
  | Ibeq (d1: Z) (d0: Z)    (**r pop two integers, skip [d1] instructions if equal, [d0] if not equal *)
  | Ible (d1: Z) (d0: Z)    (**r pop two integer, skip [d1] instructions if less or equal, [d0] if greater *)
  | Ihalt.                  (**r stop execution *)

(** A piece of machine code is a list of instructions. *)

Definition code := list instr.

(** The length (number of instructions) of a piece of code. *)

Definition codelen (c: code) : Z := Z.of_nat (List.length c).

(** *** 2.1.2.  Operational semantics *)

(** The machine operates on a code [C] (a fixed list of instructions)
    and three variable components:
  - a program counter [pc], denoting a position in [C]
  - an evaluation stack, containing integers
  - a store assigning integer values to variables.
*)

Definition stack : Type := list Z.

Definition config : Type := (Z * stack * store)%type.

(** [instr_at C pc = Some i] if [i] is the instruction at position [pc] in [C]. *)

Fixpoint instr_at (C: code) (pc: Z) : option instr :=
  match C with
  | nil => None
  | i :: C' => if pc =? 0 then Some i else instr_at C' (pc - 1)
  end.

(** The semantics of the machine is given in small-step style as a
    transition system: a relation between machine configurations
    "before" and "after" execution of the instruction at the current
    program point.  The transition relation is parameterized by the code
    [C] for the whole program.  There is one transition for each kind of
    instruction, except [Ihalt], which has no transition. *)

Inductive transition (C: code): config -> config -> Prop :=
  | trans_const: forall pc σ s n,
      instr_at C pc = Some(Iconst n) ->
      transition C (pc    , σ     , s)
                   (pc + 1, n :: σ, s)
  | trans_var: forall pc σ s x,
      instr_at C pc = Some(Ivar x) ->
      transition C (pc    , σ       , s)
                   (pc + 1, s x :: σ, s)
  | trans_setvar: forall pc σ s x n,
      instr_at C pc = Some(Isetvar x) ->
      transition C (pc    , n :: σ, s)
                   (pc + 1, σ     , update x n s)
  | trans_add: forall pc σ s n1 n2,
      instr_at C pc = Some(Iadd) ->
      transition C (pc    , n2 :: n1 :: σ , s)
                   (pc + 1, (n1 + n2) :: σ, s)
  | trans_opp: forall pc σ s n,
      instr_at C pc = Some(Iopp) ->
      transition C (pc    , n :: σ    , s)
                   (pc + 1, (- n) :: σ, s)
  | trans_branch: forall pc σ s d pc',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      transition C (pc , σ, s)
                   (pc', σ, s)
  | trans_beq: forall pc σ s d1 d0 n1 n2 pc',
      instr_at C pc = Some(Ibeq d1 d0) ->
      pc' = pc + 1 + (if n1 =? n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: σ, s)
                   (pc', σ            , s)
  | trans_ble: forall pc σ s d1 d0 n1 n2 pc',
      instr_at C pc = Some(Ible d1 d0) ->
      pc' = pc + 1 + (if n1 <=? n2 then d1 else d0) ->
      transition C (pc , n2 :: n1 :: σ, s)
                   (pc', σ            , s).

(** As we did for the IMP reduction semantics, we form sequences of
    machine transitions to define the behavior of a code. *)

Definition transitions (C: code): config -> config -> Prop :=
  star (transition C).

(** Execution starts with [pc = 0] and an empty evaluation stack.
    It stops successfully if [pc] points to an [Ihalt] instruction
    and the evaluation stack is empty. *)

Definition machine_terminates (C: code) (s_init: store) (s_final: store) : Prop :=
  exists pc, transitions C (0, nil, s_init) (pc, nil, s_final)
          /\ instr_at C pc = Some Ihalt.

(** The machine can also run forever, making infinitely many transitions. *)

Definition machine_diverges (C: code) (s_init: store) : Prop :=
  infseq (transition C) (0, nil, s_init).

(** Yet another possibility is that the machine gets stuck after some
    transitions. *)

Definition machine_goes_wrong (C: code) (s_init: store) : Prop :=
  exists pc σ s,
      transitions C (0, nil, s_init) (pc, σ, s)
   /\ irred (transition C) (pc, σ, s)
   /\ (instr_at C pc <> Some Ihalt \/ σ <> nil).

(** *** Exercise (2 stars). *)

(** To quickly see how a machine program executes, it is convenient
    to redefine the semantics of the machine as an executable function
    instead of inductively-defined relations.  This is similar to the
    [cinterp] function for the IMP language.

    To ensure termination of the machine interpreter, we need to bound
    the number of instructions it can execute.  The result of the
    machine interpreter, therefore, is of the following type:
*)

Inductive machine_result : Type :=
  | Timeout                (**r the interpreter ran out of fuel *)
  | Stuck                  (**r the machine goes wrong on an impossible case *)
  | Terminates (s: store). (**r the machine successfully stops with the given store *)

(** Please fill in the blanks in the following definition for a
    machine interpreter: *)

Fixpoint mach_exec (C: code) (fuel: nat)
                   (pc: Z) (σ: stack) (s: store) : machine_result :=
  match fuel with
  | O => Timeout
  | S fuel' =>
      match instr_at C pc, σ with
      | Some Ihalt, nil => Terminates s
      | Some (Iconst n), σ => mach_exec C fuel' (pc + 1) (n :: σ) s
      (* FILL IN HERE *)
      | _, _ => Stuck
      end
  end.

(** ** 2.2. The compilation scheme *)

(** We now define the compilation of IMP expressions and commands to
    sequence of machine instructions. *)

(** The code for an arithmetic expression [a] executes in sequence
    (no branches), and deposits the value of [a] at the top of the stack.
    This is the familiar translation to "reverse Polish notation".  The
    only twist here is that the machine has no "subtract" instruction.
    However, it can compute the difference [a - b] by adding [a] to the
    opposite of [b].  *)

Fixpoint compile_aexp (a: aexp) : code :=
  match a with
  | CONST n => Iconst n :: nil
  | VAR x => Ivar x :: nil
  | PLUS a1 a2  => compile_aexp a1 ++ compile_aexp a2 ++ Iadd :: nil
  | MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Iopp :: Iadd :: nil
  end.

(** Examples of compiled code. *)

Eval compute in (compile_aexp (PLUS (CONST 1) (CONST 2))).

(** Result: [Iconst 1 :: Iconst 2 :: Iadd :: nil] *)

Eval compute in (compile_aexp (PLUS (VAR "x") (MINUS (VAR "y") (CONST 1)))).

(** Result: [Ivar "x" :: Ivar "y" :: Iconst 1 :: Iopp :: Iadd :: Iadd :: nil]. *)

(** For Boolean expressions [b], we could produce code that deposits [1] or [0]
    at the top of the stack, depending on whether [b] is true or false.
    The compiled code for [IFTHENELSE] and [WHILE] commands would, then,
    perform an [Ibeq] jump conditional on this 0/1 value.

    However, it is simpler and more efficient to compile a Boolean
    expression [b] to a piece of code that directly jumps [d1] or [d0]
    instructions forward, depending on whether [b] is true or false.
    The actual value of [b] is never computed as an integer, and the
    stack is unchanged.
*)

Fixpoint compile_bexp (b: bexp) (d1: Z) (d0: Z) : code :=
  match b with
  | TRUE => if d1 =? 0 then nil else Ibranch d1 :: nil
  | FALSE => if d0 =? 0 then nil else Ibranch d0 :: nil
  | EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ibeq d1 d0 :: nil
  | LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ible d1 d0 :: nil
  | NOT b1 => compile_bexp b1 d0 d1
  | AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0 in
      let code1 := compile_bexp b1 0 (codelen code2 + d0) in
      code1 ++ code2
  end.

(** See the lecture slides for an explanation of the mysterious
    offsets in the [AND] case. *)

(** Examples are in order. *)

Eval compute in (compile_bexp (EQUAL (VAR "x") (CONST 1)) 12 34).

(** Result: [ Ivar "x" :: Iconst 1 :: Ibeq 12 34 :: nil ]. *)

Eval compute in (compile_bexp (AND (LESSEQUAL (CONST 1) (VAR "x"))
                                   (LESSEQUAL (VAR "x") (CONST 10))) 0 10).

(** Result: [ Iconst 1 :: Ivar "x" :: Ible 0 13 ::
              Ivar "x" :: Iconst 10 :: Ible 0 10 :: nil ] *)

Eval compute in (compile_bexp (OR (LESSEQUAL (CONST 1) (VAR "x"))
                                  (LESSEQUAL (VAR "x") (CONST 10))) 0 10).

(** Result: [ Iconst 1 :: Ivar "x" :: Ible 3 0 ::
              Ivar "x" :: Iconst 10 :: Ible 0 10 :: nil ] *)

Eval compute in (compile_bexp (NOT (AND TRUE FALSE)) 12 34).

(** Result: [ Ibranch 12 :: nil ] *)

(** Finally, here is the compilation of commands.  The code for a
    command [c] updates the store (the values of variables) as prescribed
    by [c].  It leaves the stack unchanged.

    Again, see the lecture slides for explanations of the generated
    branch offsets.
*)

Fixpoint compile_com (c: com) : code :=
  match c with
  | SKIP =>
      nil
  | ASSIGN x a =>
      compile_aexp a ++ Isetvar x :: nil
  | SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso in
      let code_ifnot := compile_com ifnot in
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ Ibranch (codelen code_ifnot)
      :: code_ifnot
  | WHILE b body =>
      let code_body := compile_com body in
      let code_test := compile_bexp b 0 (codelen code_body + 1) in
      code_test
      ++ code_body
      ++ Ibranch (- (codelen code_test + codelen code_body + 1)) :: nil
  end.

(** The code for a whole program [p] (a command) is similar, but terminates
    cleanly on an [Ihalt] instruction. *)

Definition compile_program (p: com) : code :=
  compile_com p ++ Ihalt :: nil.

(** Examples of compilation: *)

Eval compute in (compile_program (ASSIGN "x" (PLUS (VAR "x") (CONST 1)))).

(** Result: [ Ivar "x" :: Iconst 1 :: Iadd :: Isetvar "x" :: Ihalt :: nil ] *)

Eval compute in (compile_program (WHILE TRUE SKIP)).

(** Result: [ Ibranch (-1) :: Ihalt :: nil ]. *)

Eval compute in (compile_program (IFTHENELSE (EQUAL (VAR "x") (CONST 1)) (ASSIGN "x" (CONST 0)) SKIP)).

(** Result: [ Ivar "x" :: Iconst 1 :: Ibeq 0 3 ::
              Iconst 0 :: Isetvar "x" :: Ibranch 0 :: Ihalt :: nil ]. *)

(** *** Exercise (1 star) *)

(** The last example shows a slight inefficiency in the code generated for
    [IFTHENELSE b c SKIP].  How would you change [compile_com]
    to generate better code?  Hint: the following function could be useful. *)

Definition smart_Ibranch (d: Z) : code :=
  if d =? 0 then nil else Ibranch d :: nil.

(** ** 2.3.  Correctness of the compiled code for expressions *)

(** To reason about the execution of compiled code, we need to consider
    code sequences [C2] that are at position [pc] in a bigger code
    sequence [C = C1 ++ C2 ++ C3].  The following predicate
    [code_at C pc C2] does just this. *)

Inductive code_at: code -> Z -> code -> Prop :=
  | code_at_intro: forall C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2.

(** We show a number of useful lemmas about [instr_at] and [code_at]. *)

Lemma codelen_cons:
  forall i c, codelen (i :: c) = codelen c + 1.
Proof.
  unfold codelen; intros; cbn; lia.
Qed.

Lemma codelen_app:
  forall c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2.
Proof.
  induction c1; intros.
- auto.
- cbn [app]. rewrite ! codelen_cons. rewrite IHc1. lia.
Qed.

Lemma instr_at_app:
  forall i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ i :: c2) pc = Some i.
Proof.
  induction c1; simpl; intros; subst pc.
- auto.
- assert (A: codelen (a :: c1) =? 0 = false).
  { apply Z.eqb_neq. unfold codelen. cbn [length]. lia. }
  rewrite A. rewrite codelen_cons. apply IHc1. lia.
Qed.

Lemma code_at_head:
  forall C pc i C',
  code_at C pc (i :: C') ->
  instr_at C pc = Some i.
Proof.
  intros. inversion H. simpl. apply instr_at_app. auto.
Qed.

Lemma code_at_tail:
  forall C pc i C',
  code_at C pc (i :: C') ->
  code_at C (pc + 1) C'.
Proof.
  intros. inversion H.
  change (C1 ++ (i :: C') ++ C3)
    with (C1 ++ (i :: nil) ++ C' ++ C3).
  rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_left:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C pc C1.
Proof.
  intros. inversion H. rewrite app_ass. constructor. auto.
Qed.

Lemma code_at_app_right:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. inversion H. rewrite app_ass. rewrite <- app_ass.
  constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_right2:
  forall C pc C1 C2 C3,
  code_at C pc (C1 ++ C2 ++ C3) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. apply code_at_app_right. apply code_at_app_left with (C2 := C3).
  rewrite app_ass; auto.
Qed.

Lemma code_at_nil:
  forall C pc C1,
  code_at C pc C1 -> code_at C pc nil.
Proof.
  intros. inversion H. subst. change (C1 ++ C3) with (nil ++ C1 ++ C3).
  constructor. auto.
Qed.

Lemma instr_at_code_at_nil:
  forall C pc i, instr_at C pc = Some i -> code_at C pc nil.
Proof.
  induction C; cbn; intros.
- discriminate.
- destruct (pc =? 0) eqn:PC.
+ assert (pc = 0) by (apply Z.eqb_eq; auto). subst pc.
  change (a :: C) with (nil ++ nil ++ (a :: C)). constructor. auto.
+ assert (A: code_at C (pc - 1) nil) by eauto.
  inversion A; subst.
  apply code_at_intro with (C1 := a :: C1) (C3 := C3).
  rewrite codelen_cons. lia.
Qed.

(** We put these lemmas in a "hint database" so that Coq can use them
    automatically. *)

Hint Resolve code_at_head code_at_tail code_at_app_left code_at_app_right
             code_at_app_right2 code_at_nil instr_at_code_at_nil: code.
Hint Rewrite codelen_app codelen_cons Z.add_assoc Z.add_0_r : code.

(** Remember the informal specification we gave for the code generated
    for an arithmetic expression [a].  It should
  - execute in sequence (no branches)
  - deposit the value of [a] at the top of the stack
  - preserve the variable state.

    We now prove that the code [compile_aexp a] fulfills this contract.
    The proof is a nice induction on the structure of [a]. *)

Lemma compile_aexp_correct:
  forall C s a pc σ,
  code_at C pc (compile_aexp a) ->
  transitions C
       (pc, σ, s)
       (pc + codelen (compile_aexp a), aeval a s :: σ, s).
Proof.
  induction a; simpl; intros.

- (* CONST *)
  apply star_one. apply trans_const. eauto with code.

- (* VAR *)
  apply star_one. apply trans_var. eauto with code.

- (* PLUS *)
  eapply star_trans. apply IHa1. eauto with code.
  eapply star_trans. apply IHa2. eauto with code.
  apply star_one. autorewrite with code. apply trans_add. eauto with code.

- (* MINUS *)
  eapply star_trans. apply IHa1. eauto with code.
  eapply star_trans. apply IHa2. eauto with code.
  eapply star_trans.
  apply star_one. apply trans_opp. eauto with code.
  apply star_one.
  replace (aeval a1 s - aeval a2 s)
     with (aeval a1 s + (- aeval a2 s))
       by lia.
  autorewrite with code. apply trans_add. eauto with code.
Qed.

(** The proof for the compilation of Boolean expressions is similar.
    We recall the informal specification for the code generated by
    [compile_bexp b d1 d0]: it should
  - skip [d1] instructions if [b] evaluates to true,
         [d0] if [b] evaluates to false
  - leave the stack unchanged
  - leave the store unchanged.
*)

Lemma compile_bexp_correct:
  forall C s b d1 d0 pc σ,
  code_at C pc (compile_bexp b d1 d0) ->
  transitions C
       (pc, σ, s)
       (pc + codelen (compile_bexp b d1 d0) + (if beval b s then d1 else d0), σ, s).
Proof.
  induction b; cbn; intros.

- (* TRUE *)
  destruct (d1 =? 0) eqn:Z.
  + (* zero displacement: no instruction generated *)
    assert (d1 = 0) by (apply Z.eqb_eq; auto). subst d1.
    autorewrite with code. apply star_refl.
  + (* a branch is generated *)
    apply star_one. apply trans_branch with (d := d1). eauto with code. auto.

- (* FALSE *)
  destruct (d0 =? 0) eqn:Z.
  + (* zero displacement: no instruction generated *)
    assert (d0 = 0) by (apply Z.eqb_eq; auto). subst d0.
    autorewrite with code. apply star_refl.
  + (* a branch is generated *)
    apply star_one. apply trans_branch with (d := d0). eauto with code. auto.

- (* EQUAL *)
  eapply star_trans. apply compile_aexp_correct with (a := a1). eauto with code.
  eapply star_trans. apply compile_aexp_correct with (a := a2). eauto with code.
  apply star_one. apply trans_beq with (d1 := d1) (d0 := d0). eauto with code.
  autorewrite with code. auto.

- (* LESSEQUAL *)
  eapply star_trans. apply compile_aexp_correct with (a := a1). eauto with code.
  eapply star_trans. apply compile_aexp_correct with (a := a2). eauto with code.
  apply star_one. apply trans_ble with (d1 := d1) (d0 := d0). eauto with code.
  autorewrite with code. auto.

- (* NOT *)
  replace (if negb (beval b s) then d1 else d0)
     with (if beval b s then d0 else d1).
  apply IHb. auto.
  destruct (beval b s); auto.

- (* AND *)
  set (code2 := compile_bexp b2 d1 d0) in *.
  set (code1 := compile_bexp b1 0 (codelen code2 + d0)) in *.
  eapply star_trans. apply IHb1. eauto with code.
  fold code1. destruct (beval b1 s); cbn.
  + (* b1 evaluates to true, the code for b2 is executed *)
    autorewrite with code. apply IHb2. eauto with code.
  + (* b1 evaluates to false, the code for b2 is skipped *)
    autorewrite with code. apply star_refl.
Qed.

(** ** 2.4.  Correctness of generated code for terminating commands *)

(** Assume that command [c], started in state [s], terminates in state [s'].
    We then show that the machine, started at the beginning of the code
    [compile_com c] and with initial state [s], performs finitely many
    transitions and reaches the end of the code [compile_com c]
    with state [s'].

    To characterize the termination of command [c], we use IMP's natural
    semantics, with its predicate [exec s c s'].
    The proof is a simple induction over the derivation of this
    [exec s c s'] execution.  An induction on the structure of command [c]
    would not suffice in the case of loops.
*)

Lemma compile_com_correct_terminating:
  forall s c s',
  cexec s c s' ->
  forall C pc σ,
  code_at C pc (compile_com c) ->
  transitions C
      (pc, σ, s)
      (pc + codelen (compile_com c), σ, s').
Proof.
  induction 1; cbn; intros.

- (* SKIP *)
  autorewrite with code. apply star_refl.

- (* ASSIGN *)
  eapply star_trans. apply compile_aexp_correct with (a := a). eauto with code.
  apply star_one. autorewrite with code. apply trans_setvar. eauto with code.

- (* SEQUENCE *)
  eapply star_trans.
  apply IHcexec1. eauto with code.
  autorewrite with code. apply IHcexec2. eauto with code.

- (* IFTHENELSE *)
  set (code1 := compile_com c1) in *.
  set (code2 := compile_com c2) in *.
  set (codeb := compile_bexp b 0 (codelen code1 + 1)) in *.
  eapply star_trans.
  apply compile_bexp_correct with (b := b). eauto with code.
  fold codeb. destruct (beval b s); autorewrite with code.
  + (* the "then" branch is executed *)
    eapply star_trans. apply IHcexec. eauto with code.
    fold code1. apply star_one. apply trans_branch with (d := codelen code2). eauto with code. lia.
  + (* the "else" branch is executed *)
    replace (pc + codelen codeb + codelen code1 + codelen code2 + 1)
       with (pc + codelen codeb + codelen code1 + 1 + codelen code2) by lia.
    apply IHcexec. eauto with code.

- (* WHILE stop *)
  set (code_body := compile_com c) in *.
  set (code_branch := compile_bexp b 0 (codelen code_body + 1)) in *.
  set (d := - (codelen code_branch + codelen code_body + 1)) in *.
  eapply star_trans. apply compile_bexp_correct with (b := b). eauto with code.
  rewrite H. fold code_branch. autorewrite with code. apply star_refl.

- (* WHILE loop *)
  set (code_body := compile_com c) in *.
  set (code_branch := compile_bexp b 0 (codelen code_body + 1)) in *.
  set (d := - (codelen code_branch + codelen code_body + 1)) in *.
  eapply star_trans. apply compile_bexp_correct with (b := b). eauto with code.
  rewrite H. fold code_branch. autorewrite with code.
  eapply star_trans. apply IHcexec1. eauto with code.
  eapply star_trans.
  apply star_one. apply trans_branch with (d := d). eauto with code. eauto.
  replace (pc + codelen code_branch + codelen code_body + 1 + d)
     with pc
       by lia.
  replace (pc + codelen code_branch + codelen code_body + 1)
     with (pc + codelen (compile_com (WHILE b c)))
       by (cbn; autorewrite with code; auto).
  apply IHcexec2. auto.
Qed.

(** As a corollary, we obtain the correctness of the compiled code for
    a whole program [p], in the case where the execution of [p] terminates. *)

Theorem compile_program_correct_terminating:
  forall s c s',
  cexec s c s' ->
  machine_terminates (compile_program c) s s'.
Proof.
  intros.
  set (C := compile_program c).
  assert (CODEAT: code_at C 0 (compile_com c ++ Ihalt :: nil)).
  { replace C with (nil ++ compile_program c ++ nil).
    apply code_at_intro. auto.
    rewrite app_nil_r; auto. }
  unfold machine_terminates.
  exists (0 + codelen (compile_com c)); split.
- apply compile_com_correct_terminating. auto. eauto with code.
- eauto with code.
Qed.

(** *** Exercise (2 stars) *)

(** In a previous exercise, we modified [compile_com] to use
    [smart_Ibranch] instead of [Ibranch], producing more efficient code.
    Now, please update the proof of [compile_com_correct_terminating]
    to take this modification into account.
    Hint: first, show the following lemma. *)

Lemma transitions_smart_Ibranch:
  forall C pc d pc' σ s,
  code_at C pc (smart_Ibranch d) ->
  pc' = pc + codelen (smart_Ibranch d) + d ->
  transitions C (pc, σ, s) (pc', σ, s).
Proof.
  unfold smart_Ibranch; intros.
  (* FILL IN HERE *)
Abort.

(** *** Exercise (4 stars). *)

(** Consider a loop with a simple test, such as [WHILE (LESSEQUAL a1 a2) c].
    Currently, the compiled code executes two branch instructions per
    iteration of the loop: one [Ible] to test the condition and one
    [Ibranch] to go back to the beginning of the loop.  We can reduce
    this to one [Ible] instruction per iteration, by putting the code
    for [c] before the code for the test:
<<
     compile_com c ++ compile_bexp b delta1 0
>>
    with [delta1] chosen so as to branch back to the beginning of
    [compile_com c] when [b] is true.

    By itself, this would compile while loops like do-while loops, which is
    incorrect.  On the first iteration, we must skip over the code for [c]
    and branch to the code that tests [b]:
<<
    Ibranch (codesize(compile_com c)) :: compile_com c ++ compile_bexp b delta1 0
>>
    In this exercise, you should modify [compile_com] to implement this
    alternate compilation schema for loops, then show its correctness
    by updating the statement and proof of [compile_com_correct_terminating].
    The difficulty (and the reason for the 4 stars) is that the hypothesis
    [code_at C pc (compile_com c)] no longer holds if [c] is a while loop
    and we are at the second iteration of the loop.  You need to come up
    with a more flexible way to relate the command [c] and the PC.
*)

(** ** 2.5.  Correctness of generated code for commands, general case *)

(** We would like to strengthen the correctness result above so that it
    is not restricted to terminating source programs, but also applies
    to source program that diverge.  To this end, we abandon the
    big-step semantics for commands and switch to the small-step
    semantics with continuations.  We then show a simulation theorem,
    establishing that every transition of the small-step semantics in
    the source program is simulated (in a sense to be made precise
    below) by zero, one or several transitions of the machine executing
    the compiled code for the source program. *)

(** Our first task is to relate configurations [(c, k, s)] of the small-step
    semantics with configurations [(C, pc, σ, s)] of the machine.
    We already know how to relate a command [c] with the machine code,
    using the [codeseq_at] predicate.  What needs to be defined is a relation
    between the continuation [k] and the machine code.

    Intuitively, when the machine finishes executing the generated code for
    command [c], that is, when it reaches the program point
    [pc + length(compile_com c)], the machine should continue by executing
    instructions that perform the pending computations described by
    continuation [k], then reach an [Ihalt] instruction to stop cleanly.

    We formalize this intuition by the following inductive predicate
    [compile_cont C k pc], which states that, starting at program point [pc],
    there are instructions that perform the computations described in [k]
    and reach an [Ihalt] instruction. *)

Inductive compile_cont (C: code): cont -> Z -> Prop :=
  | ccont_stop: forall pc,
      instr_at C pc = Some Ihalt ->
      compile_cont C Kstop pc
  | ccont_seq: forall c k pc pc',
      code_at C pc (compile_com c) ->
      pc' = pc + codelen (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (Kseq c k) pc
  | ccont_while: forall b c k pc d pc' pc'',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      code_at C pc' (compile_com (WHILE b c)) ->
      pc'' = pc' + codelen (compile_com (WHILE b c)) ->
      compile_cont C k pc'' ->
      compile_cont C (Kwhile b c k) pc
  | ccont_branch: forall d k pc pc',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      compile_cont C k pc' ->
      compile_cont C k pc.

(** Then, a configuration [(c, k, s)] of the small-step semantics
    matches a configuration [(C, pc, σ, s')] of the machine if the
    following conditions hold:
  - The stores are identical: [s' = s].
  - The machine stack is empty: [σ = nil].
  - The machine code at point [pc] is the compiled code for [c]:
    [code_at C pc (compile_com c)].
  - The machine code at point [pc + codelen (compile_com c)] matches
    continuation [k], in the sense of [compile_cont] above.
*)

Inductive match_config (C: code): com * cont * store -> config -> Prop :=
  | match_config_intro: forall c k st pc,
      code_at C pc (compile_com c) ->
      compile_cont C k (pc + codelen (compile_com c)) ->
      match_config C (c, k, st) (pc, nil, st).

(** We are now ready to prove the expected simulation property.
    Since some transitions in the source command correspond to zero
    transitions in the compiled code, we need a simulation diagram of
    the "star" kind (see the lecture slides).
<<
                      match_config
     c / k / st  ----------------------- machconfig
       |                                   |
       |                                   | + or ( * and |c',k'| < |c,k} )
       |                                   |
       v                                   v
    c' / k' / st' ----------------------- machconfig'
                      match_config
>>
    Note the stronger conclusion on the right:
  - either the virtual machine does one or several transitions
  - or it does zero, one or several transitions, but the size of the [c,k]
    pair decreases strictly.

    It would be equivalent to state:
  - either the virtual machine does one or several transitions
  - or it does zero transitions, but the size of the [c,k] pair
    decreases strictly.

    However, the formulation above, with the "star" case, is often
    more convenient.
*)

(** Finding an appropriate "anti-stuttering" measure is a bit of a black art.
    After trial and error, we find that the following measure works.
    It is the sum of the sizes of the command [c] under focus and all
    the commands appearing in the continuation [k]. *)

Fixpoint com_size (c: com) : nat :=
  match c with
  | SKIP => 1%nat
  | ASSIGN x a => 1%nat
  | SEQ c1 c2 => (com_size c1 + com_size c2 + 1)%nat
  | IFTHENELSE b c1 c2 => (com_size c1 + com_size c2 + 1)%nat
  | WHILE b c1 => (com_size c1 + 1)%nat
  end.

Remark com_size_nonzero: forall c, (com_size c > 0)%nat.
Proof.
  induction c; cbn; lia.
Qed.

Fixpoint cont_size (k: cont) : nat :=
  match k with
  | Kstop => 0%nat
  | Kseq c k' => (com_size c + cont_size k')%nat
  | Kwhile b c k' => cont_size k'
  end.

Definition measure (impconf: com * cont * store) : nat :=
  match impconf with (c, k, m) => (com_size c + cont_size k)%nat end.

(** We will need some inversion lemmas for the [compile_cont] predicate. *)

Lemma compile_cont_Kstop_inv:
  forall C pc s,
  compile_cont C Kstop pc ->
  exists pc',
  star (transition C) (pc, nil, s) (pc', nil, s)
  /\ instr_at C pc' = Some Ihalt.
Proof.
  intros. dependent induction H.
- exists pc; split. apply star_refl. auto.
- destruct IHcompile_cont as (pc'' & A & B); auto.
  exists pc''; split; auto.
  eapply star_step; eauto. eapply trans_branch; eauto.
Qed.

Lemma compile_cont_Kseq_inv:
  forall C c k pc s,
  compile_cont C (Kseq c k) pc ->
  exists pc',
  star (transition C) (pc, nil, s) (pc', nil, s)
  /\ code_at C pc' (compile_com c)
  /\ compile_cont C k (pc' + codelen(compile_com c)).
Proof.
  intros. dependent induction H.
- exists pc; split. apply star_refl. split; congruence.
- edestruct IHcompile_cont as (pc'' & A & B). eauto.
  exists pc''; split; auto.
  eapply star_step; eauto. eapply trans_branch; eauto.
Qed.

Lemma compile_cont_Kwhile_inv:
  forall C b c k pc s,
  compile_cont C (Kwhile b c k) pc ->
  exists pc',
  plus (transition C) (pc, nil, s) (pc', nil, s)
  /\ code_at C pc' (compile_com (WHILE b c))
  /\ compile_cont C k (pc' + codelen(compile_com (WHILE b c))).
Proof.
  intros. dependent induction H.
- exists (pc + 1 + d); split.
  apply plus_one. eapply trans_branch; eauto.
  split; congruence.
- edestruct IHcompile_cont as (pc'' & A & B & D). eauto.
  exists pc''; split; auto.
  eapply plus_left. eapply trans_branch; eauto. apply plus_star; auto.
Qed.

Lemma match_config_skip:
  forall C k s pc,
  compile_cont C k pc ->
  match_config C (SKIP, k, s) (pc, nil, s).
Proof.
  intros. constructor.
- cbn. inversion H; eauto with code.
- cbn. autorewrite with code. auto.
Qed.

(** At last, we can state and prove the simulation diagram. *)

Lemma simulation_step:
  forall C impconf1 impconf2, step impconf1 impconf2 ->
  forall machconf1, match_config C impconf1 machconf1 ->
  exists machconf2,
      (plus (transition C) machconf1 machconf2
       \/ (star (transition C) machconf1 machconf2
           /\ (measure impconf2 < measure impconf1)%nat))
   /\ match_config C impconf2 machconf2.
Proof.
  destruct 1; intros machconf1 MATCH; inversion MATCH; clear MATCH; subst; cbn in *.

- (* assign *)
  econstructor; split.
+ left. eapply plus_right. eapply compile_aexp_correct; eauto with code.
  eapply trans_setvar; eauto with code.
+ autorewrite with code in *. apply match_config_skip. auto.

- (* seq *)
  econstructor; split.
+ right; split. apply star_refl. lia.
+ autorewrite with code in *. constructor. eauto with code.
  eapply ccont_seq; eauto with code.

- (* if *)
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b 0 (codelen code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  autorewrite with code in *.
  econstructor; split.
+ right; split.
  apply compile_bexp_correct with (b := b). eauto with code.
  destruct (beval b s); lia.
+ fold codeb. destruct (beval b s).
  * autorewrite with code. constructor. eauto with code.
    eapply ccont_branch. eauto with code. eauto.
    fold code1.
    replace (pc + codelen codeb + codelen code1 + 1 + codelen code2)
       with (pc + codelen codeb + codelen code1 + codelen code2 + 1) by lia.
    auto.
  * autorewrite with code. constructor. eauto with code. auto.
    fold code2.
    replace (pc + codelen codeb + codelen code1 + 1 + codelen code2)
       with (pc + codelen codeb + codelen code1 + codelen code2 + 1) by lia.
    auto.

- (* while stop *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b 0 (codelen codec + 1)) in *.
  econstructor; split.
+ right; split.
  apply compile_bexp_correct with (b := b). eauto with code.
  assert (com_size c > 0)%nat by apply com_size_nonzero. lia.
+ rewrite H. fold codeb. autorewrite with code in *.
  apply match_config_skip. auto.

- (* while loop *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b 0 (codelen codec + 1)) in *.
  econstructor; split.
+ right; split.
  apply compile_bexp_correct with (b := b). eauto with code.
  lia.
+ rewrite H. fold codeb. autorewrite with code in *.
  constructor. eauto with code.
  eapply ccont_while with (pc' := pc). eauto with code. fold codec. lia.
  auto.
  cbn. fold codec; fold codeb. eauto.
  autorewrite with code. auto.

- (* skip seq *)
  autorewrite with code in *.
  edestruct compile_cont_Kseq_inv as (pc' & X & Y & Z). eauto.
  econstructor; split.
+ right; split. eauto. lia.
+ constructor; auto.

- (* skip while *)
  autorewrite with code in *.
  edestruct compile_cont_Kwhile_inv as (pc' & X & Y & Z). eauto.
  econstructor; split.
+ left. eauto.
+ constructor; auto.
Qed.

(** The hard work is done!  Nice consequences will follow, using
    the general theorems about simulations provided by module [Simulation].

    First, we get an alternate proof that terminating programs are
    correctly compiled, using the continuation semantics instead of
    the big-step semantics to characterize termination of the source
    program. *)

Lemma match_initial_configs:
  forall c s,
  match_config (compile_program c) (c, Kstop, s) (0, nil, s).
Proof.
  intros. set (C := compile_program c).
  assert (code_at C 0 (compile_com c ++ Ihalt :: nil)).
  { replace C with (nil ++ (compile_com c ++ Ihalt :: nil) ++ nil).
    constructor; auto.
    rewrite app_nil_r; auto. }
  constructor.
- eauto with code.
- apply ccont_stop. eauto with code.
Qed.

Theorem compile_program_correct_terminating_2:
  forall c s s',
  star step (c, Kstop, s) (SKIP, Kstop, s') ->
  machine_terminates (compile_program c) s s'.
Proof.
  intros. set (C := compile_program c).
  edestruct (simulation_star _ _ _ _ _ _ (simulation_step C)) as (ms & A & B).
  eauto. apply match_initial_configs.
  inversion B; subst.
  edestruct compile_cont_Kstop_inv as (pc' & D & E). eauto.
  exists pc'; split; auto.
  eapply star_trans. eauto. cbn in D; autorewrite with code in D. eauto.
Qed.

(** Second, and more importantly, we get a proof of semantic
    preservation for diverging source programs: if the program makes
    infinitely many steps, the generated code makes infinitely many
    machine transitions. *)

Theorem compile_program_correct_diverging:
  forall c s,
  infseq step (c, Kstop, s) ->
  machine_diverges (compile_program c) s.
Proof.
  intros. set (C := compile_program c).
  eapply (simulation_infseq _ _ _ _ _ _ (simulation_step C)).
  eauto. apply match_initial_configs.
Qed.


(** * CFG: Control-flow Graphs *)

Require Import Arith.
Require Import Vminus.Util.
Require Import Vminus.Classes.
Require Import Vminus.Vminus.

(** Vminus programs are structured into _control-flow graphs_
    (CFG), which, conceptually, are graphs whose _nodes_ are
    instructions and whose _edges_ are determined by the control
    structure of the program.

    To characterize this structure abstractly, we define a notion of
    _program point_ [pc], which is a location of an instruction in the
    control-flow graph (i.e. each program point is a node of the
    graph).

    The program points are themselves organized into _basic blocks_.
    A basic block consists of a non-empty sequence of program points
    ending in a terminator instruction.
 *)

(* ################################################################# *)
(** * Program points *)

(** Program points (a.k.a. "program counters").
    Concretely, a [pc] is given by a block label and offset.

    (We could make this more abstract, but this is a simple, easy-to-work with definition.)
 *)

Definition pc := (lbl * nat)%type.

(** Each [pc] has a label, corresponding to its block *)

Definition lbl_of : pc -> lbl       := @fst _ _.

(** Increment a [pc] _within_ a block. *)

Definition incr_pc (p:pc) : pc :=
  let (l, n) := p in (l, S n).

(** (Total) Ordering on [pc]s within the same block *)

Inductive le_pc : pc -> pc -> Prop :=
| let_pc_intro : forall l n1 n2,
    n1 <= n2 -> le_pc (l, n1) (l, n2).

Definition lt_pc (p1 p2:pc) : Prop :=
  le_pc p1 (incr_pc p2).

Definition eq_dec_pc: forall p1 p2: pc, {p1 = p2} + {~(p1 = p2)}.
Proof.
  intros (lbl1, offset1) (lbl2, offset2).
  destruct (eq_dec_lbl lbl1 lbl2) as [lbl_eq | lbl_neq];
    try solve [right; intros H; inversion H;
               exfalso; apply lbl_neq; trivial];
  destruct (Nat.eq_dec offset1 offset2) as [offset_eq | offset_neq];
    try solve [right; intros H; inversion H; apply offset_neq; trivial];
    left; subst; reflexivity.
Defined.

(** The entry point of a block is offset [0]. *)

Definition block_entry (l:lbl) : pc := (l, 0).
Definition entry_of_pc (p:pc)  : pc := block_entry (fst p).

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Interface for syntactically well-formed CFGs *)

(** Given the abstract characterization of program points, we need to
    relate them to the control-flow instructions of the program's CFG.
    We do this via a collection of well-formedness predicates that
    ensure that each program point maps to a single instruction and
    that the instruction defines a unique local identifier.  (Thus
    satisfying the 'single static assignment' part of the SSA
    representation.)
 *)

(**
    In this interface, we establish the basic syntactic properties of
    control-flow-graphs:

    - A CFG [g] is a (partial) function from program points to instructions.
    - Each program point belongs to a basic block.
    - Each basic block is non-empty
    - Each basic block consists of a contiguous sequence of program points,
      ending in a terminator.

    We will impose stronger well-formedness constraints (i.e. the SSA
    conditions) on CFGs later.
*)

Module Type CFG.
  Parameter t : Type.
  Local Notation cfg := t.

(* ----------------------------------------------------------------- *)
(** *** Basic parameters of the model *)

  (** Well-formed control-flow-graphs. *)

  Parameter wf_cfg : cfg -> Prop.

  (** Well-formed program points. *)

  Parameter wf_pc : cfg -> pc -> Prop.

  (** *** *)

  (** The entry block of the control-flow graph. *)

  Parameter entry_block : cfg -> lbl.

  (** Is the program point a block terminator? *)

  Parameter tmn_pc : cfg -> pc -> Prop.

  (** *** Program point properties *)

  (** Program points are associated with unique instructions. *)

  (** Relational specification: *)

  Parameter insn_at_pc : cfg -> pc -> insn -> Prop.

  Axiom insn_at_pc_func : forall g, wf_cfg g ->
    functional (insn_at_pc g).

  (** Executable specification: *)

  Parameter fetch : cfg -> pc -> option insn.

  (** Correspondence of the two specs: *)

  Axiom insn_at_pc_fetch :
    forall g pc i, wf_cfg g ->
              insn_at_pc g pc i <-> fetch g pc = Some i.

  (** Each [pc] defines a unique [uid] *)

  Definition uid_at_pc (g:cfg) (p:pc) (uid:uid) : Prop :=
    exists c, insn_at_pc g p (uid, c).

  Axiom uid_at_pc_inj : forall g, wf_cfg g ->
                             injective (uid_at_pc g).

  Axiom uid_at_pc_func : forall g, wf_cfg g ->
    functional (uid_at_pc g).

  Axiom pc_at_uid_inj : forall g, wf_cfg g ->
                             injective (fun x p => uid_at_pc g p x).

  Axiom eq_pc_uid : forall g pc id1 id2 c1 c2,
    wf_cfg g ->
    insn_at_pc g pc (id1, c1) ->
    insn_at_pc g pc (id2, c2) ->
    id1 = id2.

  (** If [g] is well-formed, each of its program points
      maps to an instruction. *)

  Axiom wf_pc_insn : forall g, wf_cfg g ->
    forall p, wf_pc g p -> exists i, insn_at_pc g p i.

  (** *** Block properties *)

  (** There is an instruction in the entry block. *)

  Axiom wf_entry : forall g, wf_cfg g ->
    wf_pc g (block_entry (entry_block g)).

  (** Every block has a terminator. *)

  Axiom wf_pc_tmn : forall g, wf_cfg g ->
    forall p, wf_pc g p -> exists p', tmn_pc g p' /\ le_pc p p'.

  (** There are no "gaps" in the pc labels. *)

  Axiom wf_pc_le_tmn : forall g, wf_cfg g ->
    forall p', tmn_pc g p' -> forall p, le_pc p p' -> wf_pc g p.

End CFG.


(**
   * Natural Deduction for IEL
**)
Require Export forms.
Require Import List Permutation.
Require Import Coq.Program.Equality.
Require Import Coq.Arith.Max.
From Equations Require Import Equations.
Require Import PslBase.Base.

(** First, we add a type for contexts and proof some basic facts about subsets, define notation for element. **)
Definition theory := form -> Prop.
Notation context := (list form).
Implicit Type Γ Ω : context.
Implicit Type T U: theory.
Implicit Types ϕ ψ: form.
Definition subset T U := forall ϕ, T ϕ -> U ϕ.
Definition equalCtx T U := forall ϕ, T ϕ <-> U ϕ.
Definition unionCtx T U := fun z => T z \/ U z.
Definition elem T ϕ := T ϕ.
Definition consT ϕ T := fun z => z = ϕ \/ T z.
(** Define Notation for Contexts **)
Notation "A ∪ B" := (unionCtx A B) (at level 50).
Notation "A ≡ B" := (equalCtx A B) (at level 50).
Notation "a ∈ B" := (elem B a) (at level 20).
Notation "A ⊆ B" := (subset A B) (at level 10).
Notation "s # Γ" := (consT s Γ) (at level 30).
Inductive DerivationType := minus | normal.

Existing Class DerivationType.

(** ** Natural Deduction
We define deduction for contexts first *)

Inductive nd : forall (D: DerivationType), list form -> form -> Prop :=
| ndA {D} (Γ: list form) s :List.In s Γ -> (nd D Γ s)
| ndE {D} (Γ: list form) s : (nd D Γ Bot) -> (nd D Γ s)

| ndII {D} (Γ: list form) s t : (nd D (s::Γ) t) -> (nd D Γ (s ⊃ t))
| ndIE {D} (Γ: list form) s t : (nd D Γ (s ⊃  t)) -> (nd D Γ s) ->  (nd D Γ  t)
| ndKImp {D} (Γ: list form) s t: (nd D Γ (K(s ⊃ t))) -> (nd D Γ (K s ⊃ K t))
| ndKpos {D} (Γ: list form) s: (nd D Γ s) -> (nd D Γ (K s))
| ndCEL {D} (Γ: list form) s t: nd D Γ (s ∧ t) -> nd D Γ s
| ndCER {D} (Γ: list form) s t: nd D Γ (s ∧ t) -> nd D Γ t
| ndCI  {D} (Γ: list form) s t: nd D Γ s -> nd D Γ t -> nd D Γ (s ∧ t)
| ndDIL {D} (Γ: list form) s t: nd D Γ s -> (nd D Γ (s ∨ t))
| ndDIR {D} (Γ: list form) s t: nd D Γ t -> (nd D Γ (s ∨ t))
| ndDE  {D} (Γ: list form) s t q: (nd D Γ (s ∨ t)) -> (nd D Γ (s ⊃ q)) -> (nd D Γ (t ⊃ q)) -> (nd D Γ q)
| ndIntRefl  (Γ: list form) s: (nd normal Γ (K s)) -> (nd normal Γ (¬ ¬s))
.

Definition ndminus := @nd minus.
Global Hint Constructors nd : core export.

(** We reduce the theory case to existence of a contained sublist *)
Definition ndT (D: DerivationType) T ϕ  :=
  exists L, (forall ψ, ψ el L -> T ψ) /\ @nd D L ϕ.

Arguments nd {_} _ _.
Arguments ndT {_} _ _.
(** Define notations for the derivation *)
Global Notation "Γ ⊢ φ" := (nd Γ φ) (at level 40).
Global Notation "T ⊢T φ" := (ndT T φ) (at level 40).

Global Notation "Γ ⊢+ φ" := (@nd normal Γ φ) (at level 40).
Global Notation "T ⊢T+ φ" := (@ndT normal T φ) (at level 40).

Global Notation "Γ ⊢- φ" := (@nd minus Γ φ) (at level 40).
Global Notation "T ⊢T- φ" := (@ndT minus T φ) (at level 40).

(** ** Weakening
    We show weakening for contexts and theories.
 **)
Section Weakening.
  Context {d : DerivationType}.

  Fact ndtW φ T U:
     T ⊢T φ -> T ⊆ U ->  U ⊢T φ.
  Proof.
    firstorder eauto.
  Qed.

  Fact ndW Γ φ Ω :
    ( Γ ⊢ φ -> Γ <<= Ω ->  Ω ⊢ φ).
  Proof.
    intro H. revert Ω.  induction H;eauto.
  Qed.
  (* For backwards compatability *)
  Definition weak := ndW.

  Lemma consWeak Γ ϕ ψ: Γ ⊢ ϕ -> (ψ::Γ) ⊢ ϕ.
  Proof.
    intro. apply ndW with (Γ := Γ); firstorder eauto.
  Qed.

  Fact derivationExtensional Γ Ω :
    (Γ === Ω) -> (forall φ, Ω ⊢ φ <-> Γ ⊢ φ).
  Proof.
    intros. split; firstorder eauto using ndW.
  Qed.
End Weakening.

(** ** Admissibility for theories
We show the nd rules admissible for theories (ndT), we need weakening for nd to do this *)
Section ndTAdmissible.
    Context {d : DerivationType}.
    Variable (T: theory).
    Fact ndtA s: T s -> T ⊢T s.
    Proof.
      intro. exists [s]; firstorder eauto. rewrite<- H0.  auto.
    Qed.

    Fact ndtE s: ndT T ⊥ ->  T ⊢T s.
    Proof.
      intro.  destruct H as [lB Hb]. exists lB. split; firstorder eauto.
    Qed.

    Fact ndtII s t: (s#T) ⊢T t -> T ⊢T (s ⊃ t).
    Proof.
      intros.
      destruct H as [lT lht].
      exists (rem lT s). split. destruct lht. intros a Ha. specialize (H a). destruct H. apply in_rem_iff in Ha.  firstorder.
      subst a. apply in_rem_iff in Ha; tauto. auto. apply ndII. destruct lht. apply ndW with lT. auto.
      intros a Ha. decide (s = a). subst a; firstorder. right. firstorder eauto.
    Qed.

    Fact ndtIE s t: (T) ⊢T (s ⊃ t) ->  T ⊢T s -> T ⊢T t.
    Proof.
      intros. destruct H as [lH H], H0 as [lH0 H0]. exists (lH++lH0). split.
      - intros ψ Hp. apply in_app_iff in Hp. firstorder  eauto.
      - apply ndIE with s.
        + apply ndW with lH. tauto. auto.
        + apply ndW with lH0; firstorder eauto.
    Qed.

    Fact ndtKImp s t: T ⊢T (K(s ⊃ t)) ->  T ⊢T (K s ⊃ K t).
    Proof.
       firstorder eauto.
    Qed.

    Fact ndtKpos s: T ⊢T s ->  T ⊢T (K s).
    Proof.
       firstorder auto.
    Qed.

    Fact ndtCEL s t: ndT T (s ∧ t) -> ndT T s.
    Proof.
      firstorder eauto.
    Qed.

    Fact ndtCER s t: ndT T (s ∧ t) -> ndT T t.
    Proof.
      firstorder eauto.
    Qed.

    Fact ndtCI s t: ndT T s -> ndT T t -> ndT T (s ∧ t).
    Proof.
      intros Hs Ht. destruct Hs as [ls [Hs1 Hs2]], Ht as [lt [Ht1 Ht2]].
      exists (ls++lt); firstorder eauto.
      - apply in_app_iff in H. destruct H; auto.
      - apply ndCI;   firstorder eauto using ndW.
    Qed.

    Fact ndtDIL s t: ndT T s -> ndT T (s ∨ t).
    Proof.
      firstorder eauto.
    Qed.

    Fact ndtDIR s t: ndT T t -> ndT T (s ∨ t).
    Proof.
      firstorder eauto.
    Qed.

    Fact ndtDE s t q: ndT T (s ∨ t) -> ndT T (s ⊃ q) -> ndT T (t ⊃ q) -> ndT T q.
    Proof.
      intros Hs Ht Hq. destruct Hs as [ls [Hs1 Hs2]], Ht as [lt [Ht1 Ht2]], Hq as [lq [Hq1 Hq2]].
      exists (ls++lt++lq); firstorder eauto.
      -  apply in_app_iff in H; destruct H; auto. apply in_app_iff in H.  destruct H; eauto.
      - apply ndDE with s t;   firstorder eauto using ndW.
    Qed.

    Fact ndtIntRefl s: @ndT normal T (K s) -> @ndT normal T (¬ ¬ s).
    Proof.
      intro. firstorder eauto.
    Qed.

End ndTAdmissible.
(** We can show implication agreement: *)
Lemma ImpAgree (D: DerivationType) (Γ: theory) (a b: form) :
  Γ ⊢T (a ⊃ b) <-> (a#Γ ⊢T b).
Proof.
  split.
  - intro H.  apply ndtIE with a; auto. apply ndtW with Γ; firstorder eauto.
    apply ndtA. firstorder eauto.
  -  intros.  apply ndtII. firstorder eauto.
Qed.

(** List and context derivation transaltion *)
Section Transl.
  Definition ctx2thy (Γ: context) : theory := fun x => In x Γ.

  Lemma ndTEq {D: DerivationType} Γ s: nd Γ s <-> ndT (ctx2thy Γ) s.
  Proof.
    split.
    - intro. exists Γ.  firstorder eauto.
    - intro. destruct H as [lH H]. apply weak with lH; firstorder eauto.
  Qed.
End Transl.

Fixpoint shift (l: list form) (s: form) :=
  match l with
    nil  => s
  | (x::xr) => (x ⊃ (shift xr s)) end.

Definition kIfy (l: list form) := map K l.

(** ** Modal shifting lemma *)
Section shifting.
  Context {d : DerivationType}.

  Lemma ImplDistr (Γ: context) (a b:form) :
    (Γ ⊢ (K(a ⊃ b))) -> (Γ ⊢ ((K a) ⊃ (K b))).
  Proof.
    intros. apply ndKImp. exact H.
  Qed.

  Lemma ImpAss (Γ: context) (a b: form) :
    (Γ ⊢ (a ⊃ b)) <-> (nd (a::Γ) b).
  Proof.
    split.
    - intros.
      apply ndIE with (s := a). apply consWeak.  exact H.
      apply ndA. left. auto.
    - intros. apply ndII. exact H.
  Qed.

  Lemma kIfys2  (l: list form) (s: form):
    forall Γ,  (Γ ⊢ (K (shift (l) (s)))) -> Γ ⊢ (shift (map K l) (K s)).
  Proof.
    induction l.
    + intros. simpl map. simpl shift. simpl shift in H. exact H.
    + intros. simpl map. simpl shift.  apply ndII. apply IHl. apply ImpAss.
      apply ndKImp. exact H.
  Qed.

  Lemma partialShift (l1 l2: context) (s: form):
     (l1++l2) ⊢ s <-> l1 ⊢ (shift l2 s).
  Proof.
    revert l1. revert s.  induction l2; intros.
    - simpl shift. rewrite app_nil_r. tauto.
    - split.
      +  intro. apply ndII.  apply IHl2. apply ndW with (l1++a::l2); auto.
      +  intro.   apply ndW with (a::(l1++l2)).
         simpl shift in H. apply ImpAss in H.  apply IHl2 in H.  auto.
         intros x Hx.  destruct Hx as [Hx | Hx]; try apply in_app_iff in Hx; try subst x;try destruct Hx; eauto.
  Qed.
  (** The next lemma shows that Krupski's rule from the sequent calculus is admissible in IEL *)
  Fact ndKKrupski (l1 l2: context) (s: form):
    (l1++l2++(List.map K l1)) ⊢ s -> (l2++(List.map K l1)) ⊢ (K s).
  Proof.
    intro.
    apply ndW with ((l2 ++ map K l1) ++ (map K l1)); auto.
    apply partialShift, kIfys2, ndKpos.  apply-> partialShift.
    apply ndW with (l1++l2++map K l1);  auto.
  Qed.

  (**
     Now we can prove the modal shifting lemma.
   **)
  Definition unbox (Γ: theory) : theory :=
    fun x => Γ (K x).

  Lemma unbox_rewrite (Γ: theory): forall φ,
      (Γ (K φ)) <-> ((unbox Γ) φ).
  Proof.
    firstorder.
  Qed.
  Import ListNotations.

  Lemma modalShiftingLemma (Γ: theory)  (s: form):
    ndT  (unbox Γ )  s -> ndT Γ  (K s).
  Proof.
    intros H0.
    destruct H0 as [y [H0]].
    exists (List.map K y).  split.
    - intros.  eauto. apply in_map_iff in H1.  destruct H1 as [z Hz]. destruct Hz. rewrite<- H1. apply H0.  auto.
    -
      assert ((map K y) = ([]++(map K y))).
      { rewrite app_nil_l.  auto. }
      rewrite H1. apply partialShift, kIfys2, ndKpos.
      apply-> partialShift. rewrite app_nil_l.  auto.
  Qed.

End shifting.

(** ** Prime theories and contexts
 *)
Section Contexts.
  Context {d : DerivationType}.

  (** We begin by defining what a theory is *)
  Definition dedClosed (T: theory) :=  forall φ, (T ⊢T φ) -> T φ.
  Definition consistent (T: theory) : Prop := ~(T ⊢T ⊥).

  Definition is_prime (T: theory) := forall φ ψ, (T ⊢T (φ ∨ ψ) -> T ⊢T φ \/ T ⊢T ψ).
  Definition is_primeDN (T: theory) := forall φ ψ, ~~(T ⊢T (φ ∨ ψ) -> (T ⊢T φ \/ T ⊢T ψ)).

  (** *** Lindenbaum Lemma
    We will proof the Lindenbaum Lemma, which states that any set L of formulae which does not derive φ
     can be extended to a set
    of formula which
    - is prime
    - is a theory
    - does not derive φ
   Note, that such a set is consistent (otherwise it would derive φ )
   **)

  Definition insert_form (Γ: theory) (φ ψ : form) : theory :=
    fun z => (Γ z \/ (~(ndT (ψ#Γ) φ) /\ ψ = z)).

  Definition insert_num (Γ: theory) (φ: form) (n: nat) :=
    insert_form Γ φ (decode n).
  Equations maxn (Gamma: theory) (φ: form) (n: nat) : theory :=
    maxn Gamma φ 0     := Gamma;
    maxn Gamma φ (S n) := insert_num (maxn Gamma φ n) φ  n.

  Definition max (Gamma: theory) (φ: form) : theory :=
    fun z =>
      exists n, (maxn Gamma φ n) z.

  (** *** Subset properties *)
  Lemma insert_form_subset (Γ: theory) φ ψ: Γ ⊆ (insert_form Γ φ ψ).
  Proof.
    intros x H. left. exact H.
  Qed.

  Lemma insert_phi_subset (Γ: theory) φ i : Γ ⊆ (insert_num Γ φ i).
  Proof.
    unfold insert_num. apply insert_form_subset.
  Qed.

  Lemma maxn_subset (Γ: theory) φ i: Γ ⊆ (maxn Γ φ i).
  Proof.
    induction i.
    simpl. intros a B. assumption.
    intros a H. simp maxn. unfold insert_num. unfold insert_form. left. auto.
  Qed.

  Fact max_subset (Γ: theory) φ: Γ ⊆ (max Γ φ).
  Proof.
    intros x H. exists 0. auto.
  Qed.
End Contexts.

Section Chaining.
  (* We proof, that if Δ = ∪ Δ_i derives a formula φ there already is a level i, s.t. Δ_i derives φ. *)
  Variable (D: DerivationType).
  Lemma max_In_lemma (Γ: theory) φ ψ: (max Γ φ) ψ <-> exists i, (maxn Γ φ i) ψ.
  Proof.
    firstorder.
  Qed.

  Lemma maxn_subset_ij i j (Γ: theory) φ: i <= j -> (maxn Γ φ i) ⊆ (maxn Γ φ j).
  Proof.
    intro. induction H; firstorder.
  Qed.

  Lemma maxnlist (l: list form) (Γ: theory) φ: (forall x, (List.In x l ->  (max Γ φ) x)) -> exists i, forall x, (List.In x l ->  (maxn Γ φ i) x ).
  Proof.
    induction l. (* TODO: Use length induction here *)
    + intros. exists 0. intro. specialize (H x). intro.  exfalso. apply H0.
    + intros.
      assert (exists i, forall x, List.In x l -> maxn Γ φ i x).
      apply IHl. intros x H1. apply (H x). right. assumption.
      (specialize (H a)).
      assert (exists i, maxn Γ φ i a).
      {
        rewrite<- max_In_lemma.
        apply H.
        left. auto.
      }
      destruct H0 as [li lH]. destruct H1 as [ai aH].
      exists (Nat.max li ai).
      intros ψ L.
      destruct L.
    - apply maxn_subset_ij with (i := ai) (j := Nat.max li ai). apply le_max_r.
      rewrite<- H0. apply aH.
    - apply maxn_subset_ij with (i := li) (j := Nat.max li ai). apply le_max_l.
      apply lH. assumption.
  Qed.
  Fact maxn_chain (Γ: theory) φ ψ:
    (ndT (max Γ φ) ψ) <-> exists i, (ndT (maxn Γ φ i) ψ).
  Proof.
    split.
    intro. destruct H as (l & linc & H).
    assert (exists i, forall x', List.In x' l -> (maxn Γ φ i) x').
    {
       eauto using maxnlist.
    }
    destruct H0 as [ni nH].
    exists ni.
    exists l. auto.
    + intro. firstorder eauto.
  Qed.
End Chaining.

Section Lindenbaum.
  Variable (Dt: DerivationType).
  Lemma does_not_derive_i (Γ: theory) φ i:
    ~(ndT Γ φ) -> ~(ndT (maxn Γ φ i) φ).
  Proof.
    induction i.
    - intuition.
    - intros nP. specialize (IHi nP).
      intro.
      apply IHi.
      apply ndtW with (maxn Γ φ (S i)); auto.
      intros a Ha. simp maxn in Ha. destruct Ha.
      + auto.
      + destruct H0. exfalso.  apply H0. apply ndtW with (maxn Γ φ (S i)).
        auto.
        simp maxn. unfold insert_num. intros x Hx.  destruct Hx; eauto.
        firstorder eauto.
        firstorder eauto.
  Qed.

  Fact does_not_derive (Γ: theory) φ:
    ~(ndT Γ φ) -> ~(ndT (max Γ φ) φ).
  Proof.
    intros. intro D.
    apply maxn_chain in D. destruct D.
    pose (does_not_derive_i H H0). auto.
  Qed.

  Lemma subset_derives (A B: theory) φ: A ⊆ B -> ~(B ⊢T φ) -> ~(A ⊢T φ).
  Proof.
    intros H H0. intro H1. apply H0.  apply ndtW with (T := A); auto.
  Qed.
  (** Theory property **)
  Fact maxIsTheory (Γ: theory) φ ψ: ~(ndT Γ φ) -> (ndT (max Γ φ) ψ) -> (max Γ φ ψ).
  Proof.
    intros D M.
    apply max_In_lemma.
    destruct (decode_surj ψ).
    exists (S x).
    simp maxn.
    unfold insert_num. rewrite H. unfold insert_form.
    right.  split. 2: reflexivity. intro.
    assert (max Γ φ ⊢T φ).
    apply ndtIE with (s := ψ). apply ndtII.  apply ndtW with  (ψ # maxn Γ φ x) .  auto. intros a Ha; destruct Ha; firstorder auto. auto.
    apply does_not_derive in D.
    congruence.
  Qed.

  Lemma equalCtxCons A B a: A ≡ B -> a#A ≡ a#B.
  Proof.
    firstorder.
  Qed.

  Lemma max_nd_is_in (Γ: theory) φ γ:  ~(ndT Γ φ) ->
                                       ((max Γ φ) ⊢T γ) <-> ((max Γ φ γ)).
  Proof.
    intros.
    split. intro. apply maxIsTheory; auto.
    intro. apply ndtA. auto.
  Qed.

  Lemma wm (P: Prop) : ~~(P \/ ~P).
    tauto.
  Qed.

  Lemma max_does_not_derive_lemma (Γ: theory) φ ψ:
    ~( Γ ⊢T φ) -> ~((max Γ φ) ψ) -> ~~((max Γ φ) ⊢T (ψ ⊃ φ)).
  Proof.
    intros D M.
    intro.
    (* ψ has a number in the enumeration *)
    destruct (decode_surj ψ) as [npsi Hnpsi].
    specialize wm with  (@maxn Dt Γ φ  (S npsi) ψ). intro. destruct H0.
    intro. destruct H0.
    -    apply M. exists (S npsi).  auto.
    - apply H0.   simp maxn. unfold insert_num. unfold insert_form. right. split.
      2: auto.
      intro. apply ImpAgree in H1.  rewrite Hnpsi in H1.
      apply H.   apply ndtW with (maxn Γ φ npsi). exact H1.
      intros a Ha.   exists npsi.  auto.
  Qed.

  (** *** Primeness properties *)
  Fact maxprime (Γ: theory) φ: ~(ndT Γ φ) -> is_primeDN (max Γ φ).
  Proof.
    intros H ϕ ψ.
    intro.
    specialize wm with ((@max Dt Γ φ) ψ).
    intro. apply H1.  clear H1.  intro.
    destruct H1.
    apply H0.  eauto using ndtA.

    specialize  wm with (((@max Dt Γ φ) ϕ)).
    intro. apply H2. clear H2. intro.
    destruct H2.

    eauto using ndtA.
    apply H0. intro.
    apply max_does_not_derive_lemma in H1.
    apply max_does_not_derive_lemma in H2.
    assert (~~ (max Γ φ ⊢T φ)).
    {
      intro. apply H1.  intro. apply H2. intro.  apply H4. apply ndtDE with ϕ  ψ; auto.
    }
    apply does_not_derive in H. exfalso.  apply H4. auto. auto.  auto.
  Qed.

  Lemma Lindenbaum (Γ: theory) (φ: form):  ~(ndT Γ φ) ->
                                           Γ ⊆ (max Γ φ) /\ ~(ndT (max Γ φ) φ) /\ is_primeDN (max Γ φ) /\ dedClosed (max Γ φ).
  Proof.
    split.
    + apply max_subset.
    + split.
    - apply does_not_derive. exact H.
    - split.
      -- apply maxprime. exact H.
      -- intros x H1. apply maxIsTheory. exact H. exact H1.
  Defined.

End Lindenbaum.

(** **  Truth Conditions and Derivations **)
Section Derivations.
  (* In this section derive for IEL *)
  Definition empty :theory := fun x => False.
  Notation "∅" := empty.
  Lemma tripleNegIEL (Γ: theory) {d: DerivationType} ϕ:
    (Γ ⊢T (¬ϕ)) <-> (Γ ⊢T ¬ ¬ ¬ ϕ).
  Proof.
    split.
    - intro H. apply ndtII.  apply ndtIE with (s := ¬ ϕ). apply ndtA. firstorder.
      apply ndtII. apply ndtIE with (s := ϕ). apply ndtW with  Γ.  exact H.
      firstorder eauto. apply ndtA. firstorder eauto.
    - intro H. apply ndtII. apply ndtIE with (s := ¬ ¬ ϕ).
      apply ndtW with Γ. exact H. firstorder eauto.  apply ndtII. apply ndtIE with (s := ϕ).
      apply ndtA. firstorder eauto.
      apply ndtA. firstorder eauto.
  Qed.

  Lemma IELKBot: (@ndT normal empty (¬ (K ⊥))).
  Proof.
    apply ndtII.
    apply ndtIE with (s := ¬ ¬ ⊥).
    - apply ndtII. apply ndtIE with (s := (¬ ⊥)). apply ndtA; firstorder eauto. apply ndtII. apply ndtA; firstorder eauto.
    - apply ndtIntRefl. apply ndtA. firstorder eauto.
  Qed.

  Lemma IELTruthB ϕ: (@ndT normal empty (¬(K ϕ ∧ ¬ ϕ))).
  Proof.
    apply ndtII.
    apply ndtIE with (s := (¬ ¬ ϕ)).
    + apply ndtII.  apply ndtIE with (s := ¬ ϕ). try apply ndtA; firstorder eauto.
      apply ndtCER with (s := (K ϕ)); apply ndtA; firstorder eauto.
    + apply ndtIntRefl.  apply ndtCEL with (t := ¬ ϕ). apply ndtA. firstorder eauto 7.
  Qed.

  Lemma IELContra {d': DerivationType} (ϕ ψ: form) (A: theory): ndT A (ϕ ⊃ ψ) -> ndT A ((¬ ψ) ⊃ (¬ ϕ)).
  Proof.
    intro H.
    repeat apply ndtII. apply ndtIE with (s := ψ). apply ndtA; firstorder eauto.
    apply ndtIE with (s := ϕ). apply ndtW with  A.   exact H. firstorder eauto. apply ndtA. firstorder eauto.
  Qed.

  Lemma IELTruthC ϕ: (@ndT normal empty ((¬ ϕ) ⊃ (¬ K ϕ))).
  Proof.
    apply ndtII.
    apply ndtIE with (s := ¬ ¬ ¬ ϕ).
    + apply IELContra.
      apply ndtII. apply ndtIntRefl. apply ndtA. firstorder eauto.
    + rewrite <- tripleNegIEL.   apply ndtA. firstorder eauto.
  Qed.
  Lemma linCoq (X Y: Prop): ((~ ~ X) -> (~~Y)) -> (~~ (X -> Y)).
  Proof.
    tauto.
  Qed.

  Lemma ndTautologyNotNotX (X Y: form) {D: DerivationType} :
    (ndT  empty ((((¬ ¬ X) ⊃ (¬ ¬ Y)) ⊃ (¬ ¬ (X ⊃ Y))))) /\ (ndT  empty ((¬ ¬ (X ⊃ Y)) ⊃ ((¬ ¬ X) ⊃ (¬ ¬ Y)))).
  Proof.
    split.
    - repeat apply ndtII.
      apply ndtIE with (s := (X ⊃ Y)). apply ndtA; firstorder eauto.
      apply ndtII. apply ndtE. apply ndtIE with (s := ¬ Y).
      apply ndtIE with (s := ((X ⊃ ⊥) ⊃ ⊥)). apply ndtA; firstorder eauto.
      apply ndtII. apply ndtIE with (s := X); apply ndtA; firstorder eauto.
      apply ndtII. apply ndtIE with (s := (X ⊃ Y)). apply ndtA; firstorder eauto. apply ndtII. apply ndtA; firstorder eauto.
    - repeat apply ndtII.   apply ndtIE with (s := ((X ⊃ Y) ⊃ ⊥)).
      apply ndtA; firstorder eauto.
      apply ndtII. apply ndtIE with (s := (X ⊃ ⊥)).
      apply ndtA; firstorder eauto.
      apply ndtII.
      apply ndtIE with (s := Y). apply ndtA; firstorder eauto.
      apply ndtIE with (s := X); apply ndtA; firstorder eauto.
  Qed.

  Lemma IELTruthD ϕ: (@ndT normal empty (¬ ¬ (K ϕ ⊃ ϕ))).
  Proof.
    pose (@ndTautologyNotNotX (K ϕ) ϕ normal) as H.
    destruct H.
    apply ndtIE with (s := (((K ϕ ⊃ ⊥) ⊃ ⊥) ⊃ (ϕ ⊃ ⊥) ⊃ ⊥)).
    auto.
    apply IELContra.
    apply IELTruthC.
  Qed.
  Lemma t6 ϕ (Γ: theory): @ndT normal Γ ((K (¬ ϕ)) ⊃ ¬ ϕ).
  Proof.
    apply ndtII.
    apply tripleNegIEL. apply ndtIntRefl.
    apply ndtA.
    firstorder eauto.
  Qed.
  Lemma implToCoq (Γ: theory) {d: DerivationType} ϕ ψ: (Γ ⊢T (ϕ ⊃ ψ) -> ((Γ ⊢T ϕ) -> (Γ ⊢T ψ))).
  Proof.
    - intros H H0.
      apply ndtIE with (s := ϕ); firstorder eauto.
  Qed.

  Lemma t6C ϕ (Γ: theory): @ndT normal Γ (K (¬ ϕ)) -> @ndT normal Γ  (¬ ϕ).
  Proof.
    apply implToCoq.
    apply t6.
  Qed.

  Lemma t7 ϕ : ∅ ⊢T+ ((¬ (K ϕ)) ⊃ (K (¬ ϕ))) /\ ∅ ⊢T+ ((K (¬ ϕ)) ⊃ ¬ (K ϕ)).
  Proof.
    split.
    - apply ndtII.
      apply ndtIE with (s := ¬ ϕ).
      apply ndtII. apply ndtKpos. apply ndtA; firstorder eauto.
      rewrite<- ImpAgree.
      apply IELContra.
      apply ndtII.
      apply ndtKpos.
      apply ndtA; firstorder eauto.
    -  apply ndtII.
       apply ndtIE with (s := ¬ ϕ).
       apply ndtW with ∅.
       apply IELTruthC.
       firstorder eauto.
       rewrite<- ImpAgree.
       apply t6.
  Qed.

  Lemma t8 ϕ: ∅ ⊢T+ ((¬ K ϕ) <--> (¬ ϕ)).
  Proof.
    apply ndtCI.
    apply IELContra.
    apply ndtII.
    apply ndtKpos.
    apply ndtA; firstorder eauto.
    apply ndtII.
    apply ndtIE with (s := (K (¬ϕ))).
    apply ndtW with empty.
    destruct (t7 ϕ). auto. firstorder eauto.
    apply ndtKpos.  apply ndtA; firstorder eauto.
  Qed.

  Lemma t9 ϕ: ∅ ⊢T+ ¬ ((¬ K ϕ) ∧ ¬ (K (¬ ϕ))).
  Proof.
    apply ndtII.
    apply ndtIE with (s := ((¬ ϕ) ∧ (¬ ¬ ϕ))).
    apply ndtII. apply ndtIE with (s := (¬ ϕ)).
    apply ndtCER with (s := ¬ ϕ). apply ndtA; firstorder eauto.
    apply ndtCEL with (t := ¬ ¬ ϕ). apply ndtA; firstorder eauto.
    apply ndtCI.
    - apply t6C. apply ndtIE with (s := ¬ (K ϕ)).
      +  apply ndtW with ∅.
         apply t7.
         firstorder eauto.
      +
      apply ndtCEL with (t := (K (ϕ ⊃ ⊥) ⊃ ⊥)). apply ndtA; firstorder eauto.
    - apply t6C. apply ndtIE with (s := ¬ (K (¬ ϕ))).  apply ndtW with  ∅.
      apply t7.
      firstorder eauto.
      apply ndtCER with (s := (K ϕ ⊃ ⊥)).
      apply ndtA; firstorder eauto.
  Qed.
End Derivations.

(** ** Equivalence between IEL and IELm *)
Section IELMtoIEL.

  Lemma ielToIELM Γ s: (@nd normal Γ s) -> (@nd minus ((¬ (K ⊥))::Γ) s).
  Proof.
    intros.
    induction H; firstorder eauto.
    apply ndII. apply weak with ((K ⊥ ⊃ ⊥) :: (s :: Γ)). auto. auto.
    apply ndII. apply ndIE with (K ⊥). apply ndA; auto. apply ndIE with (K s). apply ndKImp. apply ndKpos. apply ndA. auto.
    apply ndW with ((K ⊥ ⊃ ⊥) :: Γ); firstorder eauto.
  Qed.

  Lemma ielmToIEL Γ s: (@nd minus Γ s) -> (@nd normal Γ s).
  Proof.
    intros.
    induction H; firstorder eauto.
  Qed.
  Lemma ielmToIELKb Γ s: (@nd minus ((¬ (K ⊥))::Γ) s) -> forall Γ', Γ <<= Γ' -> (@nd normal Γ' s).
  Proof.
    intros.  apply ndIE with (¬ K ⊥). apply ndII. apply ielmToIEL. apply ndW with  ( (K ⊥ ⊃ ⊥)::Γ).   auto. intro; firstorder eauto. apply ndTEq.
    apply ndtW with empty. apply IELKBot.  firstorder eauto.
  Qed.

  Lemma ielmReducesIEL Γ s: (@nd minus ((¬ (K ⊥))::Γ) s) <-> (@nd normal Γ s).
  Proof.
    split; eauto using ielmToIELKb, ielToIELM.
  Qed.

  Lemma ielmReducesIEL_theories (T: theory) s:  ((¬ (K ⊥))#T) ⊢T- s <-> T ⊢T+ s.
  Proof.
    split.
    - intro. destruct H. destruct H.  exists (rem x ((K ⊥ ⊃ ⊥))). split.
      + intros. destruct (H ψ);  apply in_rem_iff in H1. tauto. destruct H1. congruence.  auto.
      +  apply  ielmReducesIEL. apply ndW with x. auto. intros a Ha.  specialize (H a Ha).
         decide (a = (¬ K ⊥)).
         *  subst a; auto.
         *  right.   apply in_rem_iff; tauto.
    -  intro. repeat destruct H.   apply  ielmReducesIEL in H0. exists ((K ⊥ ⊃ ⊥) :: x). split.
       + firstorder eauto.
       + auto.
  Qed.
End IELMtoIEL.


Require Export Foundations.Generalities.uu0.

Unset Automatic Introduction.

(** ** To ustream files of the library *)

Notation hfppru := hfpg' .

Notation hfpprl := hfpg .

Notation fromunit := termfun .

(** To hfiber. *)

Definition tohfiber { X Y : UU } ( f : X -> Y ) ( x : X ) : hfiber f ( f x ) := hfiberpair f x ( idpath _ ) .

(** To hfp *)

Definition hfptriple { X X' Y:UU} (f:X -> Y) (f':X' -> Y) ( x : X ) ( x' : X' ) ( h : paths ( f' x' ) ( f x ) ) : hfp f f' := tpair ( fun xx' : dirprod X X'  => paths ( f' ( pr2 xx' ) ) ( f ( pr1 xx' ) ) )  ( dirprodpair x x' ) h .

(** Functoriality of hfp. *)

Lemma hfplhomot { X Y Z : UU } { fl1 fl2 : X -> Y } ( h : homot fl1 fl2 ) ( gr : Z -> Y ) : weq ( hfp fl1 gr ) ( hfp fl2 gr ) .
Proof . intros . refine ( weqgradth _ _ _ _ ) .

{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 e (h (pr1 xz))) . }

{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 e ( pathsinv0 (h (pr1 xz)))) . }

{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) .  destruct ( h ( pr1 xz ) ) . destruct e . apply idpath . }

{  intro xze .  destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct (h (pr1 xz)) . destruct e . apply idpath . }

Defined .

Lemma hfprhomot { X Y Z : UU } ( fl : X -> Y ) { gr1 gr2 : Z -> Y } ( h : homot gr1 gr2 ) : weq ( hfp fl gr1 ) ( hfp fl gr2 ) .
Proof . intros . refine ( weqgradth _ _ _ _ ) .

{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 ( pathsinv0 (h (pr2 xz))) e) . }

{ intro xze . destruct xze as [ xz e ] . split with xz .  exact (pathscomp0 (h (pr2 xz)) e) . }

{ intro xze . destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) .  destruct ( h ( pr2 xz ) ) . destruct e . apply idpath . }

{  intro xze .  destruct xze as [ xz e ] . apply ( maponpaths ( fun ee => tpair _ xz ee ) ) . destruct (h (pr2 xz)) . destruct e . apply idpath . }

Defined .

Lemma hfpfunct { X X' Y Z Zt Xt' : UU } ( f : X -> Y ) ( g : Z -> X ) ( f' : X' -> Y ) ( g' : Z -> X' ) ( gt : Zt -> X ) ( ft' : Xt' -> Y ) ( gt' : Zt -> Xt' ) ( h_front : commsqstr g' f' g f ) ( h_down : commsqstr gt' ft' gt f ) ( x : hfp gt g ) : hfp ft' f' .
Proof . intros .  split with ( dirprodpair ( gt' ( pr1 ( pr1 x ) ) ) ( g' ( pr2 ( pr1 x ) ) ) ) . destruct x as [ x e ] . simpl .  destruct x as [ zt z ] .
 simpl .  simpl in e .  destruct ( pathsinv0 ( h_front z ) ) . destruct ( pathsinv0 ( h_down zt ) ) . exact ( maponpaths f e ) . Defined.

Lemma hfpfunct_h_back { X X' Y Z Zt Xt' : UU } ( f : X -> Y ) ( g : Z -> X ) ( f' : X' -> Y ) ( g' : Z -> X' ) ( gt : Zt -> X ) ( ft' : Xt' -> Y ) ( gt' : Zt -> Xt' ) ( h_front : commsqstr g' f' g f ) ( h_down : commsqstr gt' ft' gt f ) : commsqstr ( hfpfunct f g f' g' gt ft' gt' h_front h_down ) ( hfpprl ft' f' ) ( hfpprl gt g ) gt'  .
Proof. intros .  intro z . apply idpath . Defined.

Lemma hfpfunct_h_up { X X' Y Z Zt Xt' : UU } ( f : X -> Y ) ( g : Z -> X ) ( f' : X' -> Y ) ( g' : Z -> X' ) ( gt : Zt -> X ) ( ft' : Xt' -> Y ) ( gt' : Zt -> Xt' ) ( h_front : commsqstr g' f' g f ) ( h_down : commsqstr gt' ft' gt f ) : commsqstr ( hfpfunct f g f' g' gt ft' gt' h_front h_down )  ( hfppru ft' f' ) ( hfppru gt g ) g' .
Proof. intros .  intro z . apply idpath . Defined.

(** Double pull-backs  ( cf. two_pullbacks_isequiv in hott-limits ) . *)

Definition doublehfp_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( xyh' : hfp f'l ( hfpprl fl gr ) ) : hfp ( funcomp f'l fl ) gr .
Proof. intros . destruct xyh' as [ [ x' [ [ x y ] h ] ] h' ] . set ( hflh' :=  pathscomp0 h ( maponpaths fl h' ) ) . exact ( hfptriple ( funcomp f'l fl ) gr x' y hflh' ) . Defined.

Definition doublehfp_to { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr )  ( x'yh' : hfp ( funcomp f'l fl ) gr ) : hfp f'l ( hfpprl fl gr ) .
Proof. intros . destruct x'yh' as [ [ x' y ] h' ] . exact ( hfptriple f'l ( hfpprl fl gr ) x' ( hfptriple fl gr ( f'l x' ) y h' ) ( idpath _ ) ) . Defined.

Definition doublehfp_to_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr )  : homot ( funcomp ( doublehfp_to f'l fl gr ) ( doublehfp_from f'l fl gr ) ) ( idfun ( hfp ( funcomp f'l fl ) gr ) ).
Proof. intros . intro xyh . destruct xyh as [ [ x y ] h ] .  unfold doublehfp_to . unfold doublehfp_from. unfold funcomp . unfold hfppru. unfold hfpprl . unfold idfun .  simpl .  simpl in h . rewrite ( @pathscomp0rid _ _ (fl (f'l x)) h ) .  apply idpath . Defined .

Lemma doublehfp_from_to_l1 { Tll Tlr Tur } ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( x0 : Tll ) ( z : hfiber ( hfpprl fl gr ) x0 ) : hfiber ( hfpprl fl gr ) x0 .
Proof . intros .  destruct z as [ [ [ x y ] h ] h0 ] .  exact ( tohfiber ( hfpprl fl gr ) ( hfptriple fl gr x0 y ( pathscomp0 h ( maponpaths fl h0 ) ) ) ) . Defined.

Lemma doublehfp_from_to_l2 { Tll Tlr Tur } ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) ( x0 : Tll ) : homot ( doublehfp_from_to_l1 fl gr x0 ) ( idfun _ ) .
Proof. intros . intro z .  destruct z as [ [ [ x y ] h ] h0 ] . destruct h0 . unfold idfun . simpl .  unfold hfpprl .    simpl . rewrite ( @pathscomp0rid _ ( gr y ) ( fl x ) h ) . apply idpath . Defined .

Definition doublehfp_from_to { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr )  : homot ( funcomp  ( doublehfp_from f'l fl gr ) ( doublehfp_to f'l fl gr ) ) ( idfun ( hfp f'l ( hfpprl fl gr ) ) ).
Proof. intros .  intro x'yh' . destruct x'yh' as [ [ x' xyh ] h' ] .  simpl in h'. unfold hfpprl in h' .   simpl in h'.  unfold idfun . unfold funcomp. unfold doublehfp_to. unfold doublehfp_from. unfold hfpprl . unfold hfppru .   simpl .
  set ( x0 := f'l x' ) .  set ( e := doublehfp_from_to_l2 fl gr x0 ( hfiberpair ( hfpprl fl gr ) xyh h' ) ) .  set ( phi := fun xyhh' : hfiber ( hfpprl fl gr ) x0 => hfptriple f'l ( hfpprl fl gr ) x' ( pr1 xyhh') ( pr2 xyhh' ) ) . destruct xyh as [ [ x y ] h ] .   exact ( maponpaths phi e ) .   Defined.

Lemma isweq_doublehfp_from { Tll' Tll Tlr Tur } ( f'l : Tll' -> Tll ) ( fl : Tll -> Tlr ) ( gr : Tur -> Tlr ) : isweq ( doublehfp_from f'l fl gr ) .
Proof . intros . apply gradth with ( doublehfp_to f'l fl gr ) .  exact ( doublehfp_from_to f'l fl gr ) . exact ( doublehfp_to_from f'l fl gr ) . Defined.

(** Note: change these in uu0.v *)

Definition hfibersgtof'  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x : X ) ( ze : hfiber g x ) : hfiber f' ( f x )  .
Proof. intros . split with ( g' ( pr1 ze ) ) .    apply ( pathscomp0  ( h ( pr1 ze ) )  ( maponpaths f ( pr2 ze ) )  ) . Defined .

Definition hfibersg'tof  { X X' Y Z : UU } ( f : X -> Y ) ( f' : X' -> Y ) ( g : Z -> X ) ( g' : Z -> X' ) ( h : commsqstr g' f' g f ) ( x' : X' ) ( ze : hfiber g' x' ) : hfiber f ( f' x' )  .
Proof. intros . split with ( g ( pr1 ze ) ) .    apply ( pathscomp0 ( pathsinv0 ( h ( pr1 ze ) ) ) ( maponpaths f' ( pr2 ze ) ) ) . Defined .

(** ** Pre-towers and towers of types

A tower of types can be viewed either as an infinite sequence of functions ... -> T_{n+1} -> T_n -> ... -> T_0 or as a coinductive object as in [tower] below.
We call such infinite sequences of functions pre-towers and coinductive opbjects towers.
In its coinductive version a tower is essentially a rooted tree of infinite (countable) depth with the collection of branches leaving each node parametrized by a  arbitrary type.

*)

(** *** Pre-towers of types - the sequence of functions definition. *)

Definition pretower := total2 ( fun T : nat -> Type => forall n : nat , T ( S n ) -> T n ) .

Definition pretowerpair ( T : nat -> Type ) ( p : forall n : nat , T ( S n ) -> T n ) : pretower := tpair ( fun T : nat -> Type => forall n : nat , T ( S n ) -> T n ) T p .

Definition preTn ( pT : pretower ) ( n : nat ) : Type := pr1 pT n .

Coercion preTn : pretower >-> Funclass .

Definition pretowerpn ( pT : pretower ) ( n : nat ) : pT ( S n ) -> pT n := pr2 pT n .

(** Pre-tower functions. *)

Definition pretowerfun ( pT pT' : pretower ) : Type := total2 ( fun fn : forall n : nat , pT n -> pT' n => forall n : nat , homot ( funcomp ( fn ( S n ) ) ( pretowerpn pT' n ) ) ( funcomp ( pretowerpn pT n ) ( fn n ) ) ) .

Definition pretowerfunconstr ( pT pT' : pretower ) ( fn : forall n : nat , pT n -> pT' n ) ( hn : forall n : nat , homot ( funcomp ( fn ( S n ) ) ( pretowerpn pT' n ) ) ( funcomp ( pretowerpn pT n ) ( fn n ) ) ) : pretowerfun pT pT' := tpair _ fn hn .

Definition prefn { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( n : nat ) : pT n -> pT' n := pr1 f n .

Coercion prefn : pretowerfun >-> Funclass .

Definition prehn { pT pT' : pretower }  ( f : pretowerfun pT pT' ) ( n : nat ) : homot ( funcomp ( prefn f ( S n ) ) ( pretowerpn pT' n ) ) ( funcomp ( pretowerpn pT n ) ( prefn f n ) ) := pr2 f n .

Definition pretowerweq ( pT pT' : pretower ) : Type := total2 ( fun f : pretowerfun pT pT' => forall n : nat , isweq ( prefn f n ) ) .

Definition pretoweridfun ( T : pretower ) : pretowerfun T T := pretowerfunconstr T T ( fun n => idfun _ ) ( fun n => fun z => idpath _ ) .

Definition pretowerfuncomp { T T' T'' : pretower } ( f : pretowerfun T T' ) ( g : pretowerfun T' T'' ) : pretowerfun T T'' := pretowerfunconstr T T'' ( fun n => funcomp ( f n ) ( g n ) ) ( fun n => fun z => pathscomp0 ( prehn g n ( f ( S n ) z ) ) ( maponpaths ( g n ) ( prehn f n z ) ) ) .

(** Pre-tower shifts *)

Definition pretoweroneshift ( pT : pretower )  : pretower := pretowerpair ( fun n => pT ( S n ) ) ( fun n => pretowerpn pT ( S n ) ) .

Definition pretowerfunoneshift { pT pT' : pretower } ( f : pretowerfun pT pT' ) : pretowerfun ( pretoweroneshift pT ) ( pretoweroneshift pT' ) := pretowerfunconstr   ( pretoweroneshift pT ) ( pretoweroneshift pT' ) ( fun n => f ( S n ) ) ( fun n => prehn f ( S n ) ) .

(** Pre-tower pull-backs *)

Definition pretowerpb_a ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) ( n : nat ) : total2 ( fun pretowerpbsn : Type => pretowerpbsn -> pT n ) .
Proof . intros . induction n .

split with X . exact f .

split with ( hfp ( pr2 IHn ) ( pretowerpn pT n ) ) . exact ( hfppru ( pr2 IHn ) ( pretowerpn pT n ) ) .  Defined.

Definition pretowerpb ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) : pretower := pretowerpair ( fun n => pr1 ( pretowerpb_a pT f n ) ) ( fun n => hfpprl ( pr2 ( pretowerpb_a pT f n ) ) ( pretowerpn pT n ) ) .

Definition pretowerpbpr ( pT : pretower ) { X : Type } ( f : X -> pT 0 ) : pretowerfun ( pretowerpb pT f ) pT := pretowerfunconstr ( pretowerpb pT f ) pT ( fun n => pr2 ( pretowerpb_a pT f n ) ) ( fun n => commhfp ( pr2 ( pretowerpb_a pT f n ) ) ( pretowerpn pT n ) ) .

Definition pretowerfunct_a { pT' pT : pretower } { X X' : Type } ( g' : X' -> pT' 0 ) ( f' : pretowerfun pT' pT ) ( g : X' -> X ) ( f : X -> pT 0 ) ( h : commsqstr g f g' ( f' 0 ) ) ( n : nat ) : total2 ( fun fto : pretowerpb pT' g' n -> pretowerpb pT f n => commsqstr  fto ( pretowerpbpr pT f n ) ( pretowerpbpr pT' g' n ) ( f' n ) ) .
Proof. intros. induction n as [ | n IHn ] .

refine ( tpair _ _ _ ) .  { exact g . } { exact h . }

destruct IHn as [ fto hn ] . refine ( tpair _ _ _ ) .

{ exact ( hfpfunct ( f' n ) ( pretowerpn pT' n ) ( pretowerpn pT n ) ( f' ( S n ) ) ( pretowerpbpr pT' g' n ) ( pretowerpbpr pT f n ) fto ( prehn f' n ) hn ) . }

{ exact ( fun z => idpath _ ) . } Defined.

Definition pretowerpbfunct { pT' pT : pretower } { X X' : Type } ( g' : X' -> pT' 0 ) ( f' : pretowerfun pT' pT ) ( g : X' -> X ) ( f : X -> pT 0 ) ( h : commsqstr g f g' ( f' 0 ) ) : pretowerfun ( pretowerpb pT' g' ) ( pretowerpb pT f ) .
Proof. intros . split with ( fun n => pr1 ( pretowerfunct_a g' f' g f h n ) ) . intro n . intro xze . destruct xze as [ [ x z ] e ] . apply idpath . exact ( hfpfunct_h_back  ( f' n ) ( pretowerpn pT' n ) ( pretowerpn pT n ) ( f' ( S n ) ) ( pretowerpbpr pT' g' n ) ( pretowerpbpr pT f n ) ( pr1 ( pretowerfunct_a g' f' g f h n ) ) ( prehn f' n ) ( pr2 ( pretowerfunct_a g' f' g f h n ) ) n ) .

Definition doublepretowerpb_from_a ( pT : pretower ) { X X' : Type } ( g : X' -> X ) ( f : X -> pT 0 ) ( n : nat ) : total2 ( fun fto : pretowerpb pT ( funcomp g f ) n -> pretowerpb ( pretowerpb pT f ) g n => homot ( pretowerpbpr pT ( funcomp g f ) n ) ( funcomp ( funcomp fto ( pretowerpbpr ( pretowerpb pT f ) g n ) ) ( pretowerpbpr pT f n ) ) ) .
Proof. intros .  induction n as [ | n IHn ] .

{ split with ( fun x => x ) . intro . apply idpath . }

{ set ( fn := pretowerpbpr pT f n ) . set ( gn := pretowerpbpr ( pretowerpb pT f ) g n ) . set ( pn := pretowerpn pT n ) . destruct IHn as [ fto en ] . refine ( tpair _ _ _ ) .

  { intro xze .  set ( xze' := hfplhomot en ( pretowerpn pT n ) xze : hfp ( funcomp ( funcomp fto gn ) fn ) pn  ) .  unfold  pretowerpb . unfold pretowerpb .  simpl . change ( hfp gn ( hfpprl fn pn ) ) . apply doublehfp_to .
 apply ( hfppru fto ( hfpprl ( funcomp gn fn ) pn ) ) .  apply doublehfp_to . apply xze' . }

  { intro xze .  destruct xze as [ [ x z ] e ] . apply idpath . }}

Defined .

Definition doublepretowerpb_from ( pT : pretower ) { X X' : Type } ( g : X' -> X ) ( f : X -> pT 0 ) : pretowerfun ( pretowerpb pT ( funcomp g f ) ) ( pretowerpb ( pretowerpb pT f ) g ) .
Proof. intros . refine ( pretowerfunconstr _ _ _ _ ) .

{ intro n .  exact ( pr1 ( pretowerpb_trans_a pT g f n ) ) . }

{ intro n .  intro xze . destruct xze as [ [ x z ] e ] . simpl .  destruct ( pretowerpb_trans_a pT g f n ) . apply idpath . }

Defined.

(** Pre-tower fibers *)

Definition pretfib { pT : pretower } ( t : pT 0 ) : pretower := pretoweroneshift ( pretowerpb pT ( fromunit t ) ) .

Definition pretfibj { pT : pretower } ( t : pT 0 ) : pretowerfun ( pretfib t ) ( pretoweroneshift pT ) := pretowerfunoneshift ( pretowerpbpr pT ( fromunit t ) ) .

(* To be removed:

Definition pretfib_Tn_jn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : total2 ( fun pretfibn : Type => pretfibn -> pT ( S n ) ) .
Proof . intros . induction n .

split with (hfiber ( pretowerpn pT O ) t ) .  exact pr1 .

split with ( hfp ( pr2 IHn ) ( pretowerpn pT ( S n ) ) ) . exact ( hfppru ( pr2 IHn ) ( pretowerpn pT ( S n ) ) ) . Defined.

Definition pretfib_Tn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : Type := pr1 ( pretfib_Tn_jn pT t n ) .

Definition pretfib_jn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : pretfib_Tn pT t n -> pT ( S n ) := pr2 (  pretfib_Tn_jn pT t n ) .

Definition pretfib_pn ( pT : pretower ) ( t : pT 0 ) ( n : nat ) : pretfib_Tn pT t ( S n ) -> pretfib_Tn pT t n .
Proof. intros pT t n .  exact ( hfpprl ( pr2 ( pretfib_Tn_jn pT t n ) ) ( pretowerpn pT ( S n ) ) ) . Defined.

Definition pretfib { pT : pretower } ( t : pT 0 ) : pretower := pretowerpair ( pretfib_Tn pT t ) ( pretfib_pn pT t ) .

Lemma pr0pretfib ( pT : pretower ) ( t : pT 0 ) : paths ( pretfib t  0 ) ( hfiber ( pretowerpn pT O ) t ) .
Proof. intros. apply idpath .  Defined.

Definition pretowerfuntfib_a { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( t : pT 0 ) ( n : nat ) : total2 ( fun funtfibn : ( pretfib t n ) -> ( pretfib ( f 0 t ) n ) => commsqstr ( f ( S n ) ) ( pretfibj ( f 0 t ) n ) ( pretfibj t n ) funtfibn ) .
Proof. intros pT pT' f t n . induction n as [ | n IHn ] .

split with ( hfibersgtof' ( f 0 ) ( pretowerpn pT' 0 ) ( pretowerpn pT 0 ) ( f 1 ) ( prehn f 0 ) t ) . intro . About commsqstr .  apply idpath . ???

split with ( hfpfunct ( f ( S n ) ) ( pretowerpn pT ( S n ) ) ( pretowerpn pT' ( S n ) ) ( f ( S ( S n ) ) )  ( pretfibj pT t n ) ( pretfibj pT' ( f 0 t ) n ) ( pr1 IHn ) ( prehn f ( S n ) ) ( pr2 IHn ) ) .  intro. apply idpath .  Defined.

*)

Definition pretowerfuntfib { pT pT' : pretower } ( f : pretowerfun pT pT' ) ( t : pT 0 ) : pretowerfun ( pretfib t ) ( pretfib ( f 0 t ) ) .
Proof. intros.  apply pretowerfunoneshift.  apply ( pretowerpb_trans pT ( fromunit t ) ???? .

Definition pretfibtopretoweroneshift ( pT : pretower ) ( t0 : pT 0 ) : pretowerfun ( pretfib t0 ) ( pretoweroneshift pT ) := pretowerfunconstr ( pretfib t0 ) ( pretoweroneshift pT ) ( pretfibj pT t0 ) ( fun n => fun z => ( pr2 z ) ) .

Definition pretfibofpretoweroneshift_a ( pT : pretower ) ( t1 : pT 1 ) ( n : nat ) ( t : @pretfib ( pretoweroneshift pT ) t1 n ) : @pretfib ( @pretfib pT ( pretowerpn pT 0 t1 ) ) ( tohfiber ( pretowerpn pT 0 ) t1 ) n .
Proof. intros .  induction n .  ???

Definition pretfibofpretoweroneshift ( pT : pretower ) ( t1 : pT 1 ) : pretowerfun ( @pretfib ( pretoweroneshift pT ) t1 ) ( @pretfib ( @pretfib pT ( pretowerpn pT 0 t1 ) ) ( tohfiber ( pretowerpn pT 0 ) t1 ) ) .
Proof.   intros . ???

Definition prenshift ( n : nat ) ( pT : pretower ) : pretower .
Proof. intros . induction n as [| n IHn] . exact pT . exact ( pretoweroneshift IHn ). Defined.

(** *** Towers of types - the coinductive definition. *)

CoInductive tower := towerconstr : forall T0 : Type, ( T0 -> tower ) -> tower .

Definition pr0 ( T : tower ) : Type .
Proof. intro . destruct T as [ T' S' ] . exact T' . Defined.

Definition tfib { T : tower } ( t : pr0 T ) : tower .
Proof. intro. destruct T as [ T' S' ] . exact S' . Defined.

Definition oneshift ( T : tower ) : tower := towerconstr ( total2 ( fun t : pr0 T => pr0 ( tfib t ) ) ) ( fun tf => tfib ( pr2 tf ) ) .

Definition nshift ( n : nat ) ( T : tower ) : tower .
Proof. intros . induction n as [| n IHn] . exact T . exact (oneshift IHn). Defined.

CoInductive towerfun : forall ( T T' : tower ) , Type := towerfunconstr : forall ( T T' : tower ) ( f0 : pr0 T -> pr0 T' ) ( ff : forall t0 : pr0 T , towerfun ( tfib t0 ) ( tfib ( f0 t0 ) ) ) , towerfun T T' .

Definition towerfunpr0 { T T' : tower } ( f : towerfun T T' ) : pr0 T -> pr0 T' .
Proof. intros T1 T2 f G . destruct f as [ T T' f0 ff ] .  exact ( f0 G ) . Defined.

Definition towerfuntfib { T T' : tower } ( f : towerfun T T' ) ( t : pr0 T ) : towerfun ( tfib t ) ( tfib ( towerfunpr0 f t ) ) .
Proof. intros. destruct f as [ T T' f0 ff ] . exact ( ff t ).  Defined.

CoFixpoint toweridfun ( T : tower ) : towerfun T T := towerfunconstr T T ( fun x => x ) ( fun t0 => toweridfun ( tfib t0 ) ) .

CoFixpoint towerfuncomp { T T' T'' : tower } ( f : towerfun T T' ) ( g : towerfun T' T'' ) : towerfun T T'' := towerfunconstr T T'' ( fun x => towerfunpr0 g ( towerfunpr0 f x ) ) ( fun x : pr0 T => @towerfuncomp ( tfib x ) ( tfib ( towerfunpr0 f x ) ) ( tfib ( towerfunpr0 g ( towerfunpr0 f x ) ) ) ( towerfuntfib f x ) ( towerfuntfib g ( towerfunpr0 f x ) ) )  .

(** *** Equivalence between towers and pre-towers *)

(** Towers from pre-towers *)

CoFixpoint towerfrompretower ( pT : pretower )  : tower := towerconstr ( prepr0 pT ) ( fun t => towerfrompretower ( @pretfib pT t ) ) .

CoFixpoint towerfrompretowerfun { pT pT' : pretower } ( f : pretowerfun pT pT' ) : towerfun ( towerfrompretower pT ) ( towerfrompretower pT' ) := towerfunconstr ( towerfrompretower pT ) ( towerfrompretower pT' )  ( f 0 ) ( fun t0 => @towerfrompretowerfun ( @pretfib pT t0 ) ( @pretfib pT' ( f 0 t0 ) ) ( pretowerfuntfib f t0 ) ) .
Definition tfib_t_from_pt ( pT: pretower ) ( t : pT O ) : paths ( towerfrompretower ( @pretfib pT t ) ) ( @tfib ( towerfrompretower pT ) t ) .
Proof. intros .   apply idpath . Defined .

Lemma oneshift_t_from_pt_to ( pT : pretower ) : towerfun ( towerfrompretower ( pretoweroneshift pT ) ) ( oneshift ( towerfrompretower pT ) ) .
Proof. intro . cofix. split with ( tococonusf ( pretowerpn pT O ) ) .  intro t1 .

set (tinhfiber := pr2 ( tococonusf ( pretowerpn pT O ) t1 )  : hfiber ( pretowerpn pT 0 ) ( pretowerpn pT 0 t1 ) ) . change (@tfib ( oneshift ( towerfrompretower pT ) ) (tococonusf (pretowerpn pT 0) t1 ) ) with (@tfib ( towerfrompretower ( @pretfib pT ( pretowerpn pT 0 t1 ) ) )  tinhfiber ) .

apply ( fun f => @towerfuntfib ( towerfrompretower ( pretoweroneshift pT ) ) ( towerfrompretower (  @pretfib pT ( pretowerpn pT 0 t1 ) ) ) f t1 ) .   . simpl .

  Defined.

(** Pre-towers from towers *)

Definition Tn ( T : tower ) ( n : nat ) : Type := pr0 (nshift n T).

Coercion Tn : tower >-> Funclass .

Lemma TSn ( T :tower ) ( n : nat ) : paths ( T ( S n ) ) ( total2 ( fun t : T n => pr0 ( tfib t ) ) ) .
Proof. intros . apply idpath . Defined.

Definition pn ( T : tower ) ( n : nat ) : T ( S n ) -> T n := @pr1 _ ( fun t : pr0 ( nshift n T ) => pr0 ( tfib t ) ) .

Definition pretowerfromtower ( T : tower ) : pretower := pretowerpair ( fun n => T n ) ( fun n => pn T n ) .

(** Pre-towers from towers from pre-towers *)

Definition TnpretopreTn ( pT : pretower ) ( n : nat ) : Tn ( towerfrompretower pT ) n  -> preTn pT n .
Proof. intros pT n .  induction n .

intro x . exact x .

intro x . unfold towerfrompretower in x . unfold Tn in x .  simpl in x .

Definition weqTnpre ( pT : pretower ) ( n : nat ) : weq ( towerfrompretower pT n ) ( preTn pT n ) .
Proof. intros .

assert

Lemma pttpt_to_id_fun ( pT : pretower ) : pretowerfun ( pretowerfromtower ( towerfrompretower pT ) ) pT .
Proof. intro.

Definition fiberfloor { n : nat } { T : tower } ( tn : T n ) := pr0 ( tfib tn ) .

(* Useful formulas:

towerfloor (1+n) T := total2 ( fun G : towerfoloor n T => fiberfloor G )

@tfib (1+n) T ( tpair _ G G' ) := @tfib (tfib G) G'

*)

Definition fiberfloortotowerfloor { n : nat } { T : tower } ( tn : T n ) ( t' : fiberfloor tn ) : T ( S n ) := tpair _ tn t' .

(** *** The type of functions berween towers *)

Definition towerfunfiberfloor { T T' : tower } ( f : towerfun T T' ) { G : pr0 T } : @fiberfloor 0 _ G -> @fiberfloor 0 _ ( towerfunpr0 f G ) := towerfunpr0 ( towerfuntfib f G ) .

Definition towerfunnshift { T T' : tower } ( n : nat ) ( f : towerfun T T' ) : towerfun ( nshift n T ) ( nshift n T' ) .
Proof.  intros . induction n as [ | n IHn ] .  exact f .  apply towerfunconstr with ( fun tf => tpair _ ( towerfunpr0 IHn (pr1 tf) ) ( towerfunfiberfloor IHn (pr2 tf) ) ) .  intro t0 . apply ( towerfuntfib ( towerfuntfib IHn ( pr1 t0 ) ) ( pr2 t0 ) ) . Defined.

Definition towerfunonfloors { n : nat } { T T' : tower } ( f : towerfun T T' ) :  T n -> T' n := towerfunpr0 ( towerfunnshift n f ) .

Definition towerfunontowersovers  { n : nat } { T T' : tower } ( f : towerfun T T' ) ( G : T n ) : towerfun ( tfib G ) ( tfib ( towerfunonfloors f G ) ) := towerfuntfib ( towerfunnshift n f ) G .

(** An example of a function between towers *)

CoFixpoint towerstrmap ( T : tower ) ( t0 : pr0 T ) : towerfun ( tfib t0 ) T := towerfunconstr _ _ ( fun x => t0 ) ( fun t1 => towerstrmap ( tfib t0 ) t1 ) .

(** *** The type of homotopies between functions of towers *)

(* Some constructions related to tower shifts *)

Definition mnshiftfun ( m n : nat ) ( T : tower ) : towerfun ( nshift m ( nshift n T ) ) ( nshift ( m + n ) T ) .
Proof. intros . induction m .

apply toweridfun .

set ( onfloors := ( fun G' => tpair _ (towerfunpr0 IHm (pr1 G')) (towerfunfiberfloor IHm  (pr2 G' ) ) )  :  (nshift n T) (S m) -> T (S (m + n))) .

split with onfloors . intro G .  apply ( towerfuntfib ( towerfuntfib IHm (pr1 G) ) (pr2 G) ) . Defined.

Definition mnfloorfun { m n : nat } { T : tower } ( G : ( nshift n T ) m  ) : T ( m + n )  := towerfunpr0 ( mnshiftfun m n T ) G .

Definition tfibtotop { n : nat } { T : tower } ( G : T n  ) : towerfun ( tfib G ) ( nshift  ( S n ) T ).
Proof. intros.

split with ( fun G' : pr0 ( tfib G ) => tpair ( fun G : T n  => pr0 ( tfib G ) ) G G' ) .

intro G' . apply toweridfun . Defined.

Definition fiberfloortofloor { n m : nat } { T : tower } ( G : T n  ) ( G' : ( tfib G ) m  ) : T ( m + ( S n ) )  .
Proof. intros. apply ( mnfloorfun ( towerfunonfloors ( tfibtotop G ) G' ) ) . Defined.

(* Extending a tower with a unit type *)

Definition towerunitext ( T : tower ) : tower := towerconstr unit ( fun x : unit => T ) .

(* Extended tower over a node G : T n *)

Definition tfibplus { n : nat } { T : tower } ( G : T n ) := towerconstr unit ( fun x => tfib G ) .

Definition fromtfibplus { n : nat } { T : tower } ( G : T n ) : towerfun ( tfibplus G ) ( nshift n T ) .
Proof .  intros .  split with ( fun x => G ) . intro . apply ( toweridfun (tfib G) ) .  Defined.

(* The type of carriers of B-systems - towers together with a one step ramification at each floor except for the ground floor. *)

Definition bsyscar := total2 ( fun T : tower => forall ( n : nat ) ( GT : T ( S n )  ) , Type ) .
Definition bsyscarpair ( T : tower ) ( btilde : forall ( n : nat ) ( GT : T ( S n )  ) , Type ) : bsyscar := tpair _ T btilde .

Definition bsyscartotower ( B : bsyscar ) := pr1 B .

Coercion bsyscartotower : bsyscar >-> tower.

Definition Btilde { n : nat } { B : bsyscar } ( GT : B ( S n ) ) : Type := pr2 B n GT .

Definition bsyscarover { n : nat } { B : bsyscar } ( G : B n ) : bsyscar := bsyscarpair ( tfibplus G ) ( fun m : nat => fun DT : ( tfibplus G ) ( S m )  => @Btilde ( ( m + n ) ) B ( towerfunpr0 ( mnshiftfun ( S m ) n B ) ( towerfunonfloors ( fromtfibplus G ) DT ) ) ) .

(* The type of functions between bsystemcarrier's *)

Definition bsyscarfun ( B B' : bsyscar ) := total2 ( fun f : towerfun B B' => forall ( n : nat ) ( GT : B ( S n ) ) , Btilde GT -> Btilde ( @towerfunonfloors (S n) _ _ f GT ) ) .

Definition bsyscarfuntotowerfun ( B B' : bsyscar ) : bsyscarfun B B' -> towerfun B B' := pr1 .
Coercion bsyscarfuntotowerfun : bsyscarfun >-> towerfun .

Definition Bnfun { n : nat } { B B' : bsyscar } ( f : bsyscarfun B B' ) ( G : B n ) : B' n := @towerfunonfloors n _ _ f G .

Definition Btildefun { n : nat } { B B' : bsyscar } ( f : bsyscarfun B B' ) { GT : B (S n ) } ( t : Btilde GT ) : Btilde ( Bnfun f GT ) := pr2 f n GT t .

(* Structures on bsystemcarriers which together form the data of a B-system. *)

(* Operation Tops : ( Gamma, x:T |- ) => ( Gamma , Delta |- ) => ( Gamma, x:T, Delta |- ) *)

Definition Tops ( B : bsyscar ) := forall ( n : nat ) ( G : B n ) ( GT : pr0 ( tfib G ) ) , towerfun ( tfib G ) ( tfib GT ) .

(* Operation Ttildeops : ( Gamma, x:T |- ) => ( Gamma , Delta |- s : S ) => ( Gamma, x:T, Delta |- s : S ) *)

Definition Ttildeops ( B : bsyscar ) ( Top : Tops B ) := forall ( n m : nat ) ( G : towerfloor n B ) ( GT : tfib G ) ( GDS : towerfloor ( S m ) ( tfib G ) ) ( s : BT ( fiberfloortofloor ( pr1 GT ) GDS ) ) , BT ( fiberfloortofloor GT ( towerfunonfloors ( Top _ GT ) GDS ) ) .

(* note - B for bsyscar, G : towerfloor n B , T : tfib G *)

(* Operation Sops : ( Gamma |- s : S ) => ( Gamma , x:S, Delta |- ) => ( Gamma, Delta[s/x] |- ) *)

Definition Sops ( B : bsyscar ) := forall ( n : nat ) ( G : towerfloor ( S n ) B ) ( s : BT G ) , towerfun ( @tfib (nshift (S n) B ) G ) ( @tfib (nshift n B ) ( pr1 G ) ) .

(* Operation Stildeops : ( Gamma |- s : S ) => ( Gamma , x:S, Delta |- r : R ) => ( Gamma, Delta[s/x] |- r[s/x]:R[s/x]) *)

Definition Stildeops ( B : bsyscar ) ( Sop : Sops B ) := forall ( n m : nat ) ( GS : pr0 ( nshift ( S n ) B ) ) ( s : BT GS ) ( GSDR : towerfloor ( S m ) ( tfib GS ) ) ( r : BT ( fiberfloortofloor GS GSDR ) ) , BT ( fiberfloortofloor ( pr1 GS ) ( towerfunonfloors ( Sop _ _ s ) GSDR ) ) .

(* Operation deltaops : ( Gamma, x:T |- ) => ( Gamma, x : T |- x : T ) *)

Definition deltaops ( B : bsyscar ) ( Top : Tops B ) := forall ( n : nat ) ( GT : towerfloor ( S n ) B ) , BT ( fiberfloortotowerfloor GT ( towerfunpr0 ( Top n GT ) ( pr2 GT )  ) ) .

(* End of the file bsystems.v *)