------------------------------------------------------------------------
-- An observation about weak bisimilarity
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module Delay-monad.Bisimilarity.Observation where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level.Closure equality-with-J

------------------------------------------------------------------------
-- The D type

mutual

  -- A mixed inductive-coinductive type.

  data D (i : Size) : Type where
    -- Output a boolean and continue. Note that this constructor is
    -- inductive.
    put : Bool → D i → D i

    -- Wait. The intention is that finite delay should not be
    -- "observable" (as captured by weak bisimilarity).
    later : D′ i → D i

  record D′ (i : Size) : Type where
    coinductive
    field
      force : {j : Size< i} → D j

open D′ public

private
  variable
    b b′  : Bool
    n     : ℕ
    i     : Size
    x y z : D ∞
    x′ y′ : D′ ∞

-- Making put inductive is a bit strange, because one can construct a
-- coinductive variant of it by using later.

put′ : Bool → D′ i → D i
put′ b x = later λ { .force → put b (x .force) }

------------------------------------------------------------------------
-- Weak bisimilarity

-- The output relation: x [ n ]≡ b means that x can output at least n
-- times, and the n-th output is b.

data _[_]≡_ : D ∞ → ℕ → Bool → Type where
  put-zero : put b x [ zero ]≡ b
  put-suc  : x [ n ]≡ b → put b′ x [ suc n ]≡ b
  later    : x′ .force [ n ]≡ b → later x′ [ n ]≡ b

-- The output relation is propositional.

[]≡-propositional : Is-proposition (x [ n ]≡ b)
[]≡-propositional {b = true}  put-zero put-zero = refl
[]≡-propositional {b = false} put-zero put-zero = refl
[]≡-propositional (put-suc p) (put-suc q) =
  cong put-suc ([]≡-propositional p q)
[]≡-propositional (later p) (later q) =
  cong later ([]≡-propositional p q)

-- Weak bisimilarity. Two computations are weakly bisimilar if the
-- output relation cannot distinguish between them.

_≈_ : D ∞ → D ∞ → Type
x ≈ y = ∀ {n b} → x [ n ]≡ b ⇔ y [ n ]≡ b

-- Weak bisimilarity is propositional (assuming extensionality).

≈-propositional :
  Extensionality lzero lzero →
  Is-proposition (x ≈ y)
≈-propositional ext =
  implicit-Π-closure ext 1 λ _ →
  implicit-Π-closure ext 1 λ _ →
  ⇔-closure ext 1 []≡-propositional []≡-propositional

-- The put constructor and the function put′ are closely related.

put≈put′ : put b (x′ .force) ≈ put′ b x′
put≈put′ ._⇔_.to   q         = later q
put≈put′ ._⇔_.from (later q) = q

-- Weak bisimilarity is an equivalence relation.

reflexive-≈ : x ≈ x
reflexive-≈ = F.id

symmetric-≈ : x ≈ y → y ≈ x
symmetric-≈ x≈y = F.inverse x≈y

transitive-≈ : x ≈ y → y ≈ z → x ≈ z
transitive-≈ x≈y y≈z = y≈z F.∘ x≈y

-- The later constructor can be removed to the left and to the right.

laterˡ⁻¹ : later x′ ≈ y → x′ .force ≈ y
laterˡ⁻¹ p ._⇔_.to   q = _⇔_.to p (later q)
laterˡ⁻¹ p ._⇔_.from q with _⇔_.from p q
…                      | later q′ = q′

laterʳ⁻¹ : x ≈ later y′ → x ≈ y′ .force
laterʳ⁻¹ = symmetric-≈ ∘ laterˡ⁻¹ ∘ symmetric-≈

later⁻¹ : later x′ ≈ later y′ → x′ .force ≈ y′ .force
later⁻¹ = laterˡ⁻¹ ∘ laterʳ⁻¹

-- The put constructor can be removed if it is removed on both sides
-- at the same time.

put⁻¹ : put b x ≈ put b′ y → x ≈ y
put⁻¹ p ._⇔_.to   q with _⇔_.to p (put-suc q)
…                   | put-suc q′ = q′
put⁻¹ p ._⇔_.from q with _⇔_.from p (put-suc q)
…                   | put-suc q′ = q′

------------------------------------------------------------------------
-- Not weak bisimilarity

module Not-weak-bisimilarity where

  mutual

    infix 4 [_]_≈_ [_]_≈′_

    -- After having seen the definition of weak bisimilarity in
    -- Delay-monad.Bisimilarity one might believe that weak
    -- bisimilarity for D can be defined in the following way:

    data [_]_≈_ (i : Size) : D ∞ → D ∞ → Type where
      put    : [ i ] x ≈ y → [ i ] put b x ≈ put b y
      later  : [ i ] x′ .force ≈′ y′ .force → [ i ] later x′ ≈ later y′
      laterˡ : [ i ] x′ .force ≈ y → [ i ] later x′ ≈ y
      laterʳ : [ i ] x ≈ y′ .force → [ i ] x ≈ later y′

    record [_]_≈′_ (i : Size) (x y : D ∞) : Type where
      coinductive
      field
        force : {j : Size< i} → [ j ] x ≈ y

  open [_]_≈′_ public

  -- The relation [ i ]_≈_ is reflexive and symmetric.

  reflexive-[]≈ : [ i ] x ≈ x
  reflexive-[]≈ {x = put _ _} = put reflexive-[]≈
  reflexive-[]≈ {x = later _} = later λ { .force → reflexive-[]≈ }

  symmetric-[]≈ : [ i ] x ≈ y → [ i ] y ≈ x
  symmetric-[]≈ (put p)    = put (symmetric-[]≈ p)
  symmetric-[]≈ (later p)  = later λ { .force →
                               symmetric-[]≈ (p .force) }
  symmetric-[]≈ (laterˡ p) = laterʳ (symmetric-[]≈ p)
  symmetric-[]≈ (laterʳ p) = laterˡ (symmetric-[]≈ p)

  -- However, the relation [ ∞ ]_≈_ is not transitive.

  ¬-transitive-≈ :
    ¬ (∀ {x y z} → [ ∞ ] x ≈ y → [ ∞ ] y ≈ z → [ ∞ ] x ≈ z)
  ¬-transitive-≈ trans = x≉z x≈z
    where
    x̲ : D i
    x̲ = later λ { .force → put true (put true x̲) }

    y̲ : D i
    y̲ = later λ { .force → put true y̲ }

    z̲ : D i
    z̲ = put true (later λ { .force → put true z̲ })

    x≈y : [ i ] x̲ ≈ y̲
    x≈y = later λ { .force → put (laterʳ (put x≈y)) }

    y≈z : [ i ] y̲ ≈ z̲
    y≈z = laterˡ (put (later λ { .force → put y≈z }))

    x≉z : ¬ [ ∞ ] x̲ ≈ z̲
    x≉z (laterˡ (put (laterʳ (put p)))) = x≉z p

    x≈z : [ ∞ ] x̲ ≈ z̲
    x≈z = trans x≈y y≈z

  -- Thus the two relations _≈_ and [ ∞ ]_≈_ are not pointwise
  -- logically equivalent.

  ¬≈⇔[]≈ : ¬ (∀ {x y} → x ≈ y ⇔ [ ∞ ] x ≈ y)
  ¬≈⇔[]≈ =
    (∀ {x y} → x ≈ y ⇔ [ ∞ ] x ≈ y)                        ↝⟨ (λ hyp x≈y y≈z → _⇔_.to hyp (transitive-≈ (_⇔_.from hyp x≈y) (_⇔_.from hyp y≈z))) ⟩
    (∀ {x y z} → [ ∞ ] x ≈ y → [ ∞ ] y ≈ z → [ ∞ ] x ≈ z)  ↝⟨ ¬-transitive-≈ ⟩□
    ⊥                                                      □

  -- The relation [ ∞ ]_≈_ is contained in _≈_.

  []≈→≈ : [ ∞ ] x ≈ y → x ≈ y
  []≈→≈ = λ p → record { to = ≈→→ p; from = ≈→→ (symmetric-[]≈ p) }
    where
    ≈→→ : [ ∞ ] x ≈ y → x [ n ]≡ b → y [ n ]≡ b
    ≈→→ (put p)    put-zero    = put-zero
    ≈→→ (put p)    (put-suc q) = put-suc (≈→→ p q)
    ≈→→ (later p)  (later q)   = later (≈→→ (p .force) q)
    ≈→→ (laterˡ p) (later q)   = ≈→→ p q
    ≈→→ (laterʳ p) q           = later (≈→→ p q)

  -- The relation _≈_ is not contained in [ ∞ ]_≈_.

  ¬≈→[]≈ : ¬ (∀ {x y} → x ≈ y → [ ∞ ] x ≈ y)
  ¬≈→[]≈ =
    (∀ {x y} → x ≈ y → [ ∞ ] x ≈ y)  ↝⟨ (λ hyp → record { to = hyp; from = []≈→≈ }) ⟩
    (∀ {x y} → x ≈ y ⇔ [ ∞ ] x ≈ y)  ↝⟨ ¬≈⇔[]≈ ⟩□
    ⊥                                □

------------------------------------------------------------------------
-- An alternative definition of weak bisimilarity

mutual

  infix 4 [_]_≈_ [_]_≈′_

  -- The problem with Not-weak-bisimilarity.[_]_≈_ is that its put
  -- constructor is inductive. The put constructor of D is inductive,
  -- but as noted above (put′, put≈put′) this is a bit strange, and it
  -- might make more sense to make put coinductive.
  --
  -- The following definition of weak bisimilarity uses a coinductive
  -- put constructor.

  data [_]_≈_ (i : Size) : D ∞ → D ∞ → Type where
    put    : [ i ] x ≈′ y → [ i ] put b x ≈ put b y
    later  : [ i ] x′ .force ≈′ y′ .force → [ i ] later x′ ≈ later y′
    laterˡ : [ i ] x′ .force ≈ y → [ i ] later x′ ≈ y
    laterʳ : [ i ] x ≈ y′ .force → [ i ] x ≈ later y′

  record [_]_≈′_ (i : Size) (x y : D ∞) : Type where
    coinductive
    field
      force : {j : Size< i} → [ j ] x ≈ y

open [_]_≈′_ public

-- The relation [ ∞ ]_≈_ is not propositional.

¬-≈[]-propositional : ¬ (∀ {x y} → Is-proposition ([ ∞ ] x ≈ y))
¬-≈[]-propositional =
  (∀ {x y} → Is-proposition ([ ∞ ] x ≈ y))  ↝⟨ (λ prop → prop _ _) ⟩
  proof₁ ≡ proof₂                           ↝⟨ (λ ()) ⟩□
  ⊥                                         □
  where
  never : D i
  never = later λ { .force → never }

  proof₁ : ∀ {i} → [ i ] never ≈ never
  proof₁ = later λ { .force → proof₁ }

  proof₂ : ∀ {i} → [ i ] never ≈ never
  proof₂ = laterˡ proof₁

-- The relation [ i ]_≈_ is reflexive and symmetric.

reflexive-[]≈ : [ i ] x ≈ x
reflexive-[]≈ {x = put _ _} = put   λ { .force → reflexive-[]≈ }
reflexive-[]≈ {x = later _} = later λ { .force → reflexive-[]≈ }

symmetric-[]≈ : [ i ] x ≈ y → [ i ] y ≈ x
symmetric-[]≈ (put p)    = put   λ { .force → symmetric-[]≈ (p .force) }
symmetric-[]≈ (later p)  = later λ { .force → symmetric-[]≈ (p .force) }
symmetric-[]≈ (laterˡ p) = laterʳ (symmetric-[]≈ p)
symmetric-[]≈ (laterʳ p) = laterˡ (symmetric-[]≈ p)

-- The two relations _≈_ and [ ∞ ]_≈_ are pointwise logically
-- equivalent.

≈⇔[]≈ : x ≈ y ⇔ [ ∞ ] x ≈ y
≈⇔[]≈ = record
  { to   = to _ _
  ; from = λ p → record { to = from p; from = from (symmetric-[]≈ p) }
  }
  where
  from : [ ∞ ] x ≈ y → x [ n ]≡ b → y [ n ]≡ b
  from (put p)    put-zero    = put-zero
  from (put p)    (put-suc q) = put-suc (from (p .force) q)
  from (later p)  (later q)   = later (from (p .force) q)
  from (laterˡ p) (later q)   = from p q
  from (laterʳ p) q           = later (from p q)

  mutual

    to : ∀ x y → x ≈ y → [ i ] x ≈ y
    to (put b x) y         p = symmetric-[]≈ (to′ (symmetric-≈ p)
                                                  (_⇔_.to p put-zero))
    to x         (put b y) p = to′ p (_⇔_.from p put-zero)
    to (later x) (later y) p = later λ { .force → to _ _ (later⁻¹ p) }

    to′ : x ≈ put b y → x [ zero ]≡ b → [ i ] x ≈ put b y
    to′ p put-zero  = put λ { .force → to _ _ (put⁻¹ p) }
    to′ p (later q) = laterˡ (to′ (laterˡ⁻¹ p) q)

-- The relation [ ∞ ]_≈_ is transitive.

transitive-[]≈ : [ ∞ ] x ≈ y → [ ∞ ] y ≈ z → [ ∞ ] x ≈ z
transitive-[]≈ p q =
  _⇔_.to ≈⇔[]≈ (transitive-≈ (_⇔_.from ≈⇔[]≈ p) (_⇔_.from ≈⇔[]≈ q))


------------------------------------------------------------------------
-- Examples
------------------------------------------------------------------------

module StructurallyRecursiveDescentParsing.Examples where

open import Data.List
open import Data.Vec using ([]; _∷_)
open import Data.Nat
open import Data.Bool
open import Data.Char using (Char)
import Data.Char.Properties as C
import Data.String as S
open S using (String)
open import Codata.Musical.Notation
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open import StructurallyRecursiveDescentParsing.Index
open import StructurallyRecursiveDescentParsing.Grammar
open import StructurallyRecursiveDescentParsing.DepthFirst
open import StructurallyRecursiveDescentParsing.Lib
open Token C.decSetoid

-- Some functions used to simplify the examples a little.

infix 5 _∈?_/_ _∈?_

_∈?_/_ : ∀ {NT i R} →
         String → Parser NT Char i R → Grammar NT Char → List R
s ∈? p / g = parseComplete (⟦ p ⟧ g) (S.toList s)

_∈?_ : ∀ {i R} → String → Parser EmptyNT Char i R → List R
s ∈? p = s ∈? p / emptyGrammar

module Ex₁ where

  mutual

    -- e ∷= 0 + e | 0

    data Nonterminal : NonTerminalType where
      e : Nonterminal i Char

    private
      i = _

    grammar : Grammar Nonterminal Char
    grammar e = tok '0' ⊛> tok '+' ⊛> ! e
              ∣ tok '0'

  ex₁ : "0+0" ∈? ! e / grammar ≡ [ '0' ]
  ex₁ = P.refl

module Ex₂ where

  mutual

    -- e ∷= f + e | f
    -- f ∷= 0 | 0 * f | ( e )

    data Nonterminal : NonTerminalType where
      expr   : Nonterminal i₁ Char
      factor : Nonterminal i₂ Char

    private
      i₁ = _
      i₂ = _

    grammar : Grammar Nonterminal Char
    grammar expr   = ! factor ⊛> tok '+' ⊛> ! expr
                   ∣ ! factor
    grammar factor = tok '0'
                   ∣ tok '0' ⊛> tok '*' ⊛> ! factor
                   ∣ tok '(' ⊛> ! expr <⊛ tok ')'

  ex₁ : "(0*)" ∈? ! expr / grammar ≡ []
  ex₁ = P.refl

  ex₂ : "0*(0+0)" ∈? ! expr / grammar ≡ [ '0' ]
  ex₂ = P.refl

{-
module Ex₃ where

  mutual

    -- This is not allowed:

    -- e ∷= f + e | f
    -- f ∷= 0 | f * 0 | ( e )

    data Nonterminal : NonTerminalType where
      expr   : Nonterminal i₁ Char
      factor : Nonterminal i₂ Char

    private
      i₁ = _
      i₂ = _

  grammar : Grammar Nonterminal Char
  grammar expr   = ! factor ⊛> tok '+' ⊛> ! expr
                 ∣ ! factor
  grammar factor = tok '0'
                 ∣ ! factor ⊛> tok '*' ⊛> tok '0'
                 ∣ tok '(' ⊛> ! expr <⊛ tok ')'
-}

module Ex₄ where

  mutual

    -- The language aⁿbⁿcⁿ, which is not context free.

    -- The non-terminal top returns the number of 'a' characters
    -- parsed.

    data NT : NonTerminalType where
      top :            NT i₁ ℕ  -- top     ∷= aⁿbⁿcⁿ
      as  :        ℕ → NT i₂ ℕ  -- as n    ∷= aˡ⁺¹bⁿ⁺ˡ⁺¹cⁿ⁺ˡ⁺¹
      bcs : Char → ℕ → NT i₃ ℕ  -- bcs x n ∷= xⁿ⁺¹

    private
      i₁ = _
      i₂ = _
      i₃ = _

    grammar : Grammar NT Char
    grammar top             = return 0 ∣ ! (as zero)
    grammar (as n)          = suc <$ tok 'a' ⊛
                              ( ! (as (suc n))
                              ∣ _+_ <$> ! (bcs 'b' n) ⊛ ! (bcs 'c' n)
                              )
    grammar (bcs c zero)    = tok c ⊛> return 0
    grammar (bcs c (suc n)) = tok c ⊛> ! (bcs c n)

  ex₁ : "aaabbbccc" ∈? ! top / grammar ≡ [ 3 ]
  ex₁ = P.refl

  ex₂ : "aaabbccc" ∈? ! top / grammar ≡ []
  ex₂ = P.refl

module Ex₄′ where

  mutual

    -- A monadic variant of Ex₄.

    aⁿbⁿcⁿ = return 0
           ∣ tok 'a' +            !>>= λ as → ♯
             (let n = length as in
              exactly n (tok 'b') ⊛>
              exactly n (tok 'c') ⊛>
              return n)

    ex₁ : "aaabbbccc" ∈? aⁿbⁿcⁿ ≡ [ 3 ]
    ex₁ = P.refl

  ex₂ : "aaabbccc" ∈? aⁿbⁿcⁿ ≡ []
  ex₂ = P.refl

module Ex₅ where

  mutual

    -- A grammar making use of a parameterised parser from the
    -- library.

    data NT : NonTerminalType where
      a  : NT i₁ Char
      as : NT i₂ ℕ

    private
      i₁ = _
      i₂ = _

    grammar : Grammar NT Char
    grammar a  = tok 'a'
    grammar as = length <$> ! a ⋆

  ex₁ : "aaaaa" ∈? ! as / grammar ≡ [ 5 ]
  ex₁ = P.refl

module Ex₆ where

  mutual

    -- A grammar which uses the chain≥ combinator.

    data NT : NonTerminalType where
      op   : NT i₁ (ℕ → ℕ → ℕ)
      expr : (a : Assoc) → NT i₂ ℕ

    private
      i₁ = _
      i₂ = _

    grammar : Grammar NT Char
    grammar op       = _+_ <$ tok '+'
                     ∣ _*_ <$ tok '*'
                     ∣ _∸_ <$ tok '∸'
    grammar (expr a) = chain≥ 0 a number (! op)

  ex₁ : "12345" ∈? number / grammar ≡ [ 12345 ]
  ex₁ = P.refl

  ex₂ : "1+5*2∸3" ∈? ! (expr left) / grammar ≡ [ 9 ]
  ex₂ = P.refl

  ex₃ : "1+5*2∸3" ∈? ! (expr right) / grammar ≡ [ 1 ]
  ex₃ = P.refl

module Ex₇ where

  mutual

    -- A proper expression example.

    data NT : NonTerminalType where
      expr   : NT i₁ ℕ
      term   : NT i₂ ℕ
      factor : NT i₃ ℕ
      addOp  : NT i₄ (ℕ → ℕ → ℕ)
      mulOp  : NT i₅ (ℕ → ℕ → ℕ)

    private
      i₁ = _
      i₂ = _
      i₃ = _
      i₄ = _
      i₅ = _

    grammar : Grammar NT Char
    grammar expr   = chain≥ 0 left (! term)   (! addOp)
    grammar term   = chain≥ 0 left (! factor) (! mulOp)
    grammar factor = tok '(' ⊛> ! expr <⊛ tok ')'
                   ∣ number
    grammar addOp  = _+_ <$ tok '+'
                   ∣ _∸_ <$ tok '∸'
    grammar mulOp  = _*_ <$ tok '*'

  ex₁ : "1+5*2∸3" ∈? ! expr / grammar ≡ [ 8 ]
  ex₁ = P.refl

  ex₂ : "1+5*(2∸3)" ∈? ! expr / grammar ≡ [ 1 ]
  ex₂ = P.refl

module Ex₈ where

  mutual

    -- An example illustrating the use of one grammar within another.

    data NT : NonTerminalType where
      lib   : ∀ {i R} (nt : Ex₇.NT i R) → NT i R
      exprs : NT i (List ℕ)

    private
      i = _

    expr = lib Ex₇.expr

    grammar : Grammar NT Char
    grammar (lib nt) = mapNT lib (Ex₇.grammar nt)
    grammar exprs    = ! expr sepBy tok ','

  ex₁ : "1,2∸1" ∈? ! exprs / grammar ≡ [ 1 ∷ 1 ∷ [] ]
  ex₁ = P.refl

module Ex₉ where

  mutual

    -- An example illustrating the use of one grammar within another
    -- when the inner grammar contains non-terminals parameterised on
    -- parsers, and the outer grammar instantiates one of these
    -- parsers with an outer non-terminal.

    infix 55 _★ _∔

    data LibraryNT (NT : NonTerminalType) (Tok : Set) :
                   NonTerminalType where
      _★ : ∀ {c R} → Parser NT Tok (false ◇ c) R →
           LibraryNT NT Tok (i₁ c) (List R)
      _∔ : ∀ {c R} → Parser NT Tok (false ◇ c) R →
           LibraryNT NT Tok (i₂ c) (List R)

    private
      i₁ i₂ : _ → _
      i₁ = _
      i₂ = _

    library : ∀ {NT Tok} → (∀ {i R} → LibraryNT NT Tok i R → NT i R) →
              ∀ {i R} → LibraryNT NT Tok i R → Parser NT Tok i R
    library lift (p ★) = return [] ∣ ! (lift (p ∔))
    library lift (p ∔) = p              >>= λ x  →
                         ! (lift (p ★)) >>= λ xs →
                         return (x ∷ xs)

  mutual

    data NT : NonTerminalType where
      lib : ∀ {i R} → LibraryNT NT Char i R → NT i R
      a   : NT i₃ Char
      as  : NT i₄ (List Char)

    private
      i₃ = _
      i₄ = _

    grammar : Grammar NT Char
    grammar (lib nt) = library lib nt
    grammar a        = tok 'a'
    grammar as       = ! (lib (! a ★))

  ex₁ : "aa" ∈? ! as / grammar ≡ [ 'a' ∷ 'a' ∷ [] ]
  ex₁ = P.refl


-- {-# OPTIONS --safe #-}
module Language where

open import Map
open import Relation.Binary.PropositionalEquality
open import Data.String using (String)
open import Data.Nat
open import Data.Bool
open import Data.Maybe using (Maybe; just; nothing)
open import Agda.Builtin.Unit
open import Data.Empty
open import Relation.Nullary using (¬_)
open import Data.Product using (_×_)
open import Data.List

-- I separated this because of function calls
data VarId : Set where
  Var : (x : String) → VarId

-- This is the language of expressions
data Aexp {A : Set} : Set where
  _+`_ : ∀(x1 x2 : Aexp {A}) → Aexp
  _-`_ : ∀(x1 x2 : Aexp {A}) → Aexp
  _*`_ : ∀(x1 x2 : Aexp {A}) → Aexp
  Avar : ∀(x : String) → Aexp
  Anum : ∀(x : A) → Aexp
  -- Type A should be comparable to 0
  -- _/_ : ∀(x1 x2 : A) → (x2 ≡ 0) → Aexp

-- Special - for ℕ
_~-~_ : (a b : ℕ) → ℕ
zero ~-~ b = 0
suc a ~-~ b = a ~-~ b

-- Evaluation of Arithexp
aeval : (st : String → ℕ) → (exp : Aexp {ℕ}) → ℕ
aeval st (e +` e₁) = aeval st e + aeval st e₁
aeval st (e -` e₁) = aeval st e ~-~ aeval st e₁
aeval st (e *` e₁) = aeval st e * aeval st e₁
aeval st (Avar x) = st x
aeval st (Anum x) = x

-- This is the language of boolean expressions
data Bexp {A : Set} : Set where
  TRUE : Bexp
  FALSE : Bexp
  _<`_ : ∀ (x1 x2 : Aexp {A}) → Bexp
  _>`_ : ∀ (x1 x2 : Aexp {A}) → Bexp
  _≤`_ : ∀ (x1 x2 : Aexp {A}) → Bexp
  _≥`_ : ∀ (x1 x2 : Aexp {A}) → Bexp
  _≡`_ : ∀ (x1 x2 : Aexp {A}) → Bexp
  ¬`_ : ∀ (b : Bexp {A}) → Bexp
  _&&`_ : ∀ (b1 b2 : Bexp {A}) → Bexp
  _||`_ : ∀ (b1 b2 : Bexp {A}) → Bexp

-- Bool evaluation for ℕ
beval : (st : String → ℕ) → (b : Bexp {ℕ}) → Bool
beval st TRUE = true
beval st FALSE = false
beval st (x1 <` x2) = let ql = aeval st x1 in
                       let qr = aeval st x2 in
                       ((not ((ql ≤ᵇ qr) ∧ (qr ≤ᵇ ql))) ∧ (ql ≤ᵇ qr))
beval st (x1 >` x2) = let ql = aeval st x1 in
                       let qr = aeval st x2 in
                       ((not ((ql ≤ᵇ qr) ∧ (qr ≤ᵇ ql))) ∧ (qr ≤ᵇ ql))
beval st (x1 ≤` x2) = let l = aeval st x1 in
                       let r = aeval st x2 in
                       l ≤ᵇ r
beval st (x1 ≥` x2) = let l = aeval st x1 in
                       let r = aeval st x2 in
                       r ≤ᵇ l
beval st (x1 ≡` x2) = let l = aeval st x1 in
                       let r = aeval st x2 in
                       (l ≤ᵇ r) ∧ (r ≤ᵇ l)
beval st (¬` b) = not (beval st b)
beval st (b &&` b₁) = beval st b ∧ beval st b₁
beval st (b ||` b₁) = beval st b ∨ beval st b₁

data ATuple : Set where
  Arg : (v : String) → ATuple
  _,`_ : (f : ATuple) → (n : ATuple) → ATuple

data RTuple : Set where
  Ret : (v : String) → RTuple
  _,`_ : (f : RTuple) → (n : RTuple) → RTuple

-- Make a list of RTuple
rtuple2list : RTuple → List (String)
rtuple2list (Ret v) = v ∷ []
rtuple2list (r ,` r₁) = rtuple2list r ++ rtuple2list r₁

-- Name of functions are in different namespace
data FuncCall {A : Set} : Set where
  -- Calling a function
  <_>:=_<_> : (ret : RTuple) → (f : String) →
              (args : ATuple) → FuncCall
  -- XXX: Note that the below allows writing code like
  -- this: F()||F()//F()
  _||`_ : (l r : FuncCall {A}) → FuncCall
  -- _//`_ : (l r : FuncCall {A}) → FuncCall

-- This is the command language that we have
data Cmd {A : Set} : Set where
  SKIP : Cmd
  _:=_ : (l : VarId) → (r : Aexp {A}) → Cmd
  _;_ : (c1 c2 : Cmd {A}) → Cmd
  IF_THEN_ELSE_END : (b : Bexp {A}) → (t : Cmd {A}) →
                   (c : Cmd {A}) → Cmd
  WHILE_DO_END : (b : Bexp {A}) → (bo : Cmd {A}) → Cmd

  -- This makes calling the function a command
  EXEC : FuncCall {A} → Cmd

-- This is defining a function
-- This should give state of type (f → Maybe (Ret strings, args string, Cmd))
-- This should be an eval function, not a relation
-- This will be called from funccall and go from st => st'
data FuncDef {A : Set} : Set where
  -- Define a function/thread
  DEF_<_>⇒<_>:_END : (f : String) → (ATuple)
                   → (RTuple) → (c : Cmd {A}) → FuncDef

-- Toplevel
-- This should start from MAIN
-- This should be an topeval function KP => st
data Top {A : Set} : Set where
  MAIN:_END :  (c : Cmd {A}) → Top
  _;_ : FuncDef {A} → (a : Top {A}) → Top

infix 22 _:=_
infixl 21 _;_
infixl 20 _||`_
-- infixl 20 _//`_
infixl 23 _-`_
infixl 23 _+`_
infixl 24 _*`_
infixl 25 _,`_                  -- Highest precedence and left assoc

-- Example of a program with multiple functions
Main : Top
Main = DEF "Factorial" < Arg "K" >⇒< Ret "fact" ,` Ret "K" >:
            Var "n" := Avar "K" ;
            Var "fact" := Anum 1 ;
            WHILE (Avar "n" >` Anum 0) DO
              Var "fact" := Avar "fact" *` Avar "n" ;
              Var "n" := Avar "n" -` Anum 1
            END ;
            Var "res" := Anum 0 ;
            IF ((Avar "K" ≡` Anum 4) &&` (Avar "fact" ≡` Anum 24)) THEN
              Var "res" := Anum 1
            ELSE
              Var "res" := Anum 0
            END
       END ;
       MAIN:
        Var "K" := Anum 4 ;
        -- The below 2 have to be declared before being used
        Var "fact" := Anum 0 ;
        -- We should also have a tuple with each function/thread for
        -- pre-post.
        EXEC < Ret "fact" ,` Ret "K" >:= "Factorial" < Arg "K" >
       END

-- Making the tuple type needed to hold the program
data ProgTuple {A : Set} : Set where
  _,_,_ : (a : ATuple) → (r : RTuple) → (c : Cmd {A}) → ProgTuple

-- Getting stuff from the Progtuple
getProgCmd : {A : Set} → (p : Maybe (ProgTuple {A})) → Cmd {A}
getProgCmd (just (a , r , c)) = c
getProgCmd nothing = SKIP       -- Dangerous

getProgArgs : {A : Set} → (p : Maybe (ProgTuple {A})) → ATuple
getProgArgs (just (a , r , c)) = a
getProgArgs nothing = Arg "VOID"

getProgRets : {A : Set} → (p : Maybe (ProgTuple {A})) → RTuple
getProgRets (just (a , r , c)) = r
getProgRets nothing = Ret "VOID"

-- Semantics from here

-- All stacks should come from point of function call
-- Here Γ is the caller' stack
data _,_-[_]->ᴬ_ {A : Set} (Γ : (String → ( A))) :
                (String → ( A)) → (ATuple)
                → (String →  A) → Set where
  hd : ∀ (v : String) → ∀ (st : (String →  A)) →
         -- Γ v ≡ just vv →  -- Make sure that Arg is in the caller' stack
         -----------------------------------------------------------
         Γ , st -[ Arg v ]->ᴬ (Store st v (Γ v))

  tl : (l r : ATuple) → (st st' st'' : (String →  A)) →
        (Γ , st -[ l ]->ᴬ st') → (Γ , st' -[ r ]->ᴬ st'') →
        -----------------------------------------------------------
        Γ , st -[ (l ,` r) ]->ᴬ st''

-- Here Γ is the callee' stack
data _,_-[_]->ᴿ_ {A : Set}
                 (Γ : (String →  A))  :
                 (String →  A) → RTuple → (String →  A)
                 → Set where
  hd : ∀ (v : String) → ∀ (v1 v2 : A) → ∀ (st : (String →  A)) →
       -- → Γ v ≡ just v1 → st v ≡ just v2 →
       -- (_⊕_ : A → A → A) → ∀ (a b c : A) → (a ⊕ b ≡ b ⊕ a)
       -- → ((a ⊕ b) ⊕ c ≡ a ⊕ (b ⊕ c)) →
       -----------------------------------------------------------
       Γ , st -[ Ret v  ]->ᴿ (Store st v (Γ v))
       -- Γ , st -[ Ret v  ]->ᴿ (Store st v (Γ v ⊕ st v))

  tl : ∀ (l r : RTuple) → (st st' st'' : (String →  A)) →
       (Γ , st -[ l ]->ᴿ st') → (Γ , st' -[ r ]->ᴿ st'') →
       -----------------------------------------------------------
       Γ , st -[ (l ,` r) ]->ᴿ st''

mutual

-- These are the relations for ℕ
 data _,_=[_]=>_ (Γ : String → Maybe (ProgTuple {ℕ})) :
                 (String →  ℕ) →
                 Cmd {ℕ} → (String →  ℕ) →
                 Set where
  CSKIP : ∀ (st : (String →  ℕ)) →
          -----------------------
          Γ , st =[ SKIP ]=> st

  CASSIGN : ∀ (st : (String →  ℕ)) → ∀ (x : String) →
            ∀ (e : Aexp {ℕ}) →
          -----------------------------------------------------------
          Γ , st =[ Var x := e ]=> (Store st x (aeval st e))

  CSEQ : ∀ (st st' st'' : (String →  ℕ)) → ∀ (c1 c2 : Cmd {ℕ}) →
         Γ , st =[ c1 ]=> st' →
         Γ , st' =[ c2 ]=> st'' →
         -----------------------------------------------------------
         Γ , st =[ (c1 ; c2)]=> st''

  CIFT : ∀ (st st' : (String →  ℕ)) → (b : Bexp {ℕ}) →
         (t e : Cmd {ℕ}) →
         beval st b ≡ true →
         Γ , st =[ t ]=> st' →
         -----------------------------------------------------------
         Γ , st =[ (IF b THEN t ELSE e END)]=> st'

  CIFE : ∀ (st st' : (String →  ℕ)) →
         (b : Bexp {ℕ}) → (t e : Cmd {ℕ}) →
         beval st b ≡ false →
         Γ , st =[ e ]=> st' →
         -----------------------------------------------------------
         Γ , st =[ (IF b THEN t ELSE e END)]=> st'

  CLF : (st : (String →  ℕ)) →
        (b : Bexp {ℕ}) → (c : Cmd {ℕ}) →
         beval st b ≡ false →
         -----------------------------------------------------------
         Γ , st =[ (WHILE b DO c END) ]=> st

  CLT :  (st st' st'' : (String →  ℕ)) →
         (b : Bexp {ℕ}) → (c : Cmd {ℕ}) →
         beval st b ≡ true →
         Γ , st =[ c ]=> st' →
         Γ , st' =[ (WHILE b DO c END) ]=> st'' →
         -----------------------------------------------------------
         Γ , st =[ (WHILE b DO c END) ]=> st''

  -- XXX: Done.
  CEX : ∀ (f : FuncCall {ℕ}) → ∀ (st st' : (String → ℕ))
        → Γ , st =[ f ]=>ᶠ st'
        -----------------------------------------------------------
        → Γ , st =[ EXEC f ]=> st'

-- TODO: The function calls and definition with ℕ
 data _,_=[_]=>ᶠ_ (Γ : String → (Maybe (ProgTuple {ℕ}))) :
                (String → ℕ) → FuncCall {ℕ} → (String → ℕ)
                → Set where

  Base : ∀ (fname : String) →        -- name of the function
         ∀ (stm : String → ℕ) -- caller stack,
         → (stf' stf'' : String → ℕ) -- These are the pre-call and
                                     -- post-call callee stack,
                                     -- respectively.
         → (stm' : String → ℕ)       -- The resultant caller stack

         -- res of putting values on callee stack
         → stm , (K 0) -[ getProgArgs (Γ fname) ]->ᴬ stf'

         -- result of running the function
         → Γ , stf' =[ getProgCmd (Γ fname) ]=> stf''

         -- copying ret values back on caller' stack
         → stf'' , stm -[ getProgRets (Γ fname) ]->ᴿ stm'

         -----------------------------------------------------------
         → Γ , stm =[ < getProgRets (Γ fname) >:=
             fname < getProgArgs (Γ fname) > ]=>ᶠ stm'
         -- XXX: The above needs to be extended to return a list of
         -- fname with stm'. This will allow merge to be called in ||
         -- and //

-- Doing the evaluation of top
evalProg : {A : Set} → (p : Top {A}) →
           (st : String → Maybe (ProgTuple {A})) →
           (String → Maybe (ProgTuple {A}))
evalProg MAIN: c END st = (StoreP st "MAIN" (Arg "void" , Ret "void" , c))
evalProg (DEF f < x >⇒< x1 >: c END ; p) st =
              StoreP (evalProg p st) f (x , x1 , c)

-- Example of relation on ℕ
ex1 : ∀ (Γ : (String → Maybe ProgTuple)) → ∀ (st : (String →  ℕ))
      → Γ , st =[ SKIP ]=> st
ex1 Γ st = CSKIP st

-- Hoare logic starts here!
{-# NO_POSITIVITY_CHECK #-}

-- XXX: Maybe later define another language for it?
-- Logical expressions with ℕ as relations (used for Hoare Propositions)
data _|=_ (st : String →  ℕ) : Bexp {ℕ} → Set where
  LT : ∀ (l r : Aexp {ℕ}) → (aeval st l) Data.Nat.< (aeval st r)
       → st |= (l <` r)
  LE : ∀ (l r : Aexp {ℕ}) → (aeval st l) Data.Nat.≤ (aeval st r)
       → st |= (l ≤` r)
  GT : ∀ (l r : Aexp {ℕ}) → (aeval st l) Data.Nat.> (aeval st r)
       → st |= (l >` r)
  GE : ∀ (l r : Aexp {ℕ}) → (aeval st l) Data.Nat.≥ (aeval st r)
       → st |= (l ≥` r)
  EQ : ∀ (l r : Aexp {ℕ}) → (aeval st l) ≡ (aeval st r)
       → st |= (l ≡` r)
  TT : st |= TRUE
  AND : ∀ (b1 b2 : Bexp {ℕ}) → (st |= b1) → (st |= b2)
        → st |= (b1 &&` b2)
  ORL : ∀ (b1 b2 : Bexp {ℕ}) → (st |= b1) → (st |= (b1 ||` b2))
  ORR : ∀ (b1 b2 : Bexp {ℕ}) → (st |= b2) → (st |= (b1 ||` b2))
  -- XXX: Had to disable POSITIVITY_CHECK
  NOT : ∀ (b : Bexp {ℕ}) → ((st |= b) → ⊥) → st |= (¬` b)

-- Assert with ℙrops
Assertℙ : ∀ (b : Bexp {ℕ}) → (String → ℕ) → Set
Assertℙ b st = st |= b

-- Defn of substitution rule with ℙrop
Subsℙ : ∀ (b : Bexp {ℕ})       -- b is my assertion
       → (X : String)
       → (e : Aexp {ℕ}) → (String → ℕ)
       → Set
Subsℙ b X e st = (Store st X (aeval st e)) |= b

getStates : ∀ (stf stm : String → ℕ) → ATuple → (String → ℕ)
getStates stf stm (Arg v) = Store stf v (stm v)
getStates stf stm (l ,` r) = getStates (getStates stf stm l) stm r

getStatesR : ∀ (stm stf : String → ℕ) → RTuple → (String → ℕ)
getStatesR stm stf (Ret v) = Store stm v (stf v)
getStatesR stm stf (rets ,` rets₁) = getStatesR (getStatesR stm stf rets) stf rets₁

-- Subs for the input arguments before calling a function
SubsArgs : ∀ (Q : Bexp {ℕ}) → (args : ATuple) → (stf stm : (String → ℕ))
           → Set
SubsArgs Q args stf stm = (getStates stf stm args) |= Q

-- Subs for the output rets after calling function
SubsRets : ∀ (R : Bexp {ℕ}) → (rets : RTuple) → (stm stf : (String → ℕ))
           → Set
SubsRets R rets stm stf = (getStatesR stm stf rets) |= R

-- Lemma for getStates
getstates-eq-lemma : ∀ (st stm st' : (String → ℕ)) → (args : ATuple)
                     → stm , st -[ args ]->ᴬ st'
                     → (getStates st stm args) ≡ st'
getstates-eq-lemma st stm .(Store st v (stm v)) (Arg v) (hd .v .st) = refl
getstates-eq-lemma st stm st' (args ,` args₁) (tl .args .args₁ .st st'' .st' cmd cmd₁) with
  getstates-eq-lemma st stm st'' args cmd
... | refl = getstates-eq-lemma st'' stm st' args₁ cmd₁

-- Lemma for getStatesR
getstatesr-eq-lemma : ∀ (stm stf stm' : (String → ℕ)) → (rets : RTuple)
                      → (stf , stm -[ rets ]->ᴿ stm')
                      → (getStatesR stm stf rets) ≡ stm'
getstatesr-eq-lemma stm stf .(Store stm v (stf v)) .(Ret v) (hd v v1 v2 .stm) = refl
getstatesr-eq-lemma stm stf stm' .(l ,` r) (tl l r .stm st' .stm' cmd cmd₁) with
  getstatesr-eq-lemma stm stf st' l cmd
... | refl = getstatesr-eq-lemma st' stf stm' r cmd₁

-- Now the soundness proof for SubsArgs
SubsArgs-theorem : ∀ (stf stm stf' : (String → ℕ)) → (Q : Bexp {ℕ})
                   → (args : ATuple) → (P : SubsArgs Q args stf stm)
                   → (cmd : stm , stf -[ args ]->ᴬ stf')
                   → (stf' |= Q)
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(l <` r) .(Arg v) (LT l r x) (hd v .stf) = LT l r x
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(l ≤` r) .(Arg v) (LE l r x) (hd v .stf) = LE l r x
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(l >` r) .(Arg v) (GT l r x) (hd v .stf) = GT l r x
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(l ≥` r) .(Arg v) (GE l r x) (hd v .stf) = GE l r x
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(l ≡` r) .(Arg v) (EQ l r x) (hd v .stf) = EQ l r x
SubsArgs-theorem stf stm .(Store stf v (stm v)) .TRUE .(Arg v) TT (hd v .stf) = TT
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(b1 &&` b2) .(Arg v) (AND b1 b2 P P₁) (hd v .stf) = AND b1 b2 P P₁
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(b1 ||` b2) .(Arg v) (ORL b1 b2 P) (hd v .stf) = ORL b1 b2 P
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(b1 ||` b2) .(Arg v) (ORR b1 b2 P) (hd v .stf) = ORR b1 b2 P
SubsArgs-theorem stf stm .(Store stf v (stm v)) .(¬` b) .(Arg v) (NOT b x) (hd v .stf) = NOT b x
SubsArgs-theorem stf stm stf' .(l₁ <` r₁) .(l ,` r) (LT l₁ r₁ x) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = LT l₁ r₁ x
SubsArgs-theorem stf stm stf' .(l₁ ≤` r₁) .(l ,` r) (LE l₁ r₁ x) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = LE l₁ r₁ x
SubsArgs-theorem stf stm stf' .(l₁ >` r₁) .(l ,` r) (GT l₁ r₁ x) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = GT l₁ r₁ x
SubsArgs-theorem stf stm stf' .(l₁ ≥` r₁) .(l ,` r) (GE l₁ r₁ x) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = GE l₁ r₁ x
SubsArgs-theorem stf stm stf' .(l₁ ≡` r₁) .(l ,` r) (EQ l₁ r₁ x) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = EQ l₁ r₁ x
SubsArgs-theorem stf stm stf' .TRUE .(l ,` r) TT (tl l r .stf st' .stf' cmd cmd₁) = TT
SubsArgs-theorem stf stm stf' .(b1 &&` b2) .(l ,` r) (AND b1 b2 P P₁) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = AND b1 b2 P P₁
SubsArgs-theorem stf stm stf' .(b1 ||` b2) .(l ,` r) (ORL b1 b2 P) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = ORL b1 b2 P
SubsArgs-theorem stf stm stf' .(b1 ||` b2) .(l ,` r) (ORR b1 b2 P) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = ORR b1 b2 P
SubsArgs-theorem stf stm stf' .(¬` b) .(l ,` r) (NOT b x) (tl l r .stf st' .stf' cmd cmd₁) rewrite
 getstates-eq-lemma stf stm st' l cmd | getstates-eq-lemma st' stm stf' r cmd₁ = NOT b x

-- The inductive case for concurrent function calls either (// or ||)
-- This thorem is saying that if the product (conjunction) of two
-- pre-conditions holds on the caller' stack then the pre-condition
-- holds for each of the Funccall in the concurrent execution.

-- TODO: The below theorem can be extended to N instead of just two
-- inductively with ease. Leaving it to two for now as proof of concept.
conc-pre-theorem : ∀ (stm stf1 stf1' stf2 stf2' : (String → ℕ))
                   → ∀ (a1 a2 : ATuple)
                   → (c1 : stm , stf1 -[ a1 ]->ᴬ stf1')
                   → (c2 : stm , stf2 -[ a2 ]->ᴬ stf2')
                   → ∀ (Q1 Q2 : Bexp {ℕ})
                   → (SubsArgs Q1 a1 stf1 stm) × (SubsArgs Q2 a2 stf2 stm)
                   → (stf1' |= Q1) × (stf2' |= Q2)
conc-pre-theorem stm stf1 stf1' stf2 stf2' a1 a2 c1 c2 Q1 Q2 (fst Data.Product., snd)
  = (SubsArgs-theorem stf1 stm stf1' Q1 a1 fst c1) Data.Product.,
    (SubsArgs-theorem stf2 stm stf2' Q2 a2 snd c2)

-- DONE: We do the same as Subsargs for ret but with stacks swapped
SubsRets-theorem : ∀ (stm stf stm' : (String → ℕ)) → (Q : Bexp {ℕ})
                   → (rets : RTuple) → (P : SubsRets Q rets stm stf)
                   → (cmd : stf , stm -[ rets ]->ᴿ stm')
                   → (stm' |= Q)
SubsRets-theorem stm stf .(Store stm v (stf v)) .(l <` r) .(Ret v) (LT l r x) (hd v v1 v2 .stm) = LT l r x
SubsRets-theorem stm stf .(Store stm v (stf v)) .(l ≤` r) .(Ret v) (LE l r x) (hd v v1 v2 .stm) = LE l r x
SubsRets-theorem stm stf .(Store stm v (stf v)) .(l >` r) .(Ret v) (GT l r x) (hd v v1 v2 .stm) = GT l r x
SubsRets-theorem stm stf .(Store stm v (stf v)) .(l ≥` r) .(Ret v) (GE l r x) (hd v v1 v2 .stm) = GE l r x
SubsRets-theorem stm stf .(Store stm v (stf v)) .(l ≡` r) .(Ret v) (EQ l r x) (hd v v1 v2 .stm) = EQ l r x
SubsRets-theorem stm stf .(Store stm v (stf v)) .TRUE .(Ret v) TT (hd v v1 v2 .stm) = TT
SubsRets-theorem stm stf .(Store stm v (stf v)) .(b1 &&` b2) .(Ret v) (AND b1 b2 P P₁) (hd v v1 v2 .stm) =
 AND b1 b2 P P₁
SubsRets-theorem stm stf .(Store stm v (stf v)) .(b1 ||` b2) .(Ret v) (ORL b1 b2 P) (hd v v1 v2 .stm) = ORL b1 b2 P
SubsRets-theorem stm stf .(Store stm v (stf v)) .(b1 ||` b2) .(Ret v) (ORR b1 b2 P) (hd v v1 v2 .stm) = ORR b1 b2 P
SubsRets-theorem stm stf .(Store stm v (stf v)) .(¬` b) .(Ret v) (NOT b x) (hd v v1 v2 .stm) = NOT b x
SubsRets-theorem stm stf stm' .(l₁ <` r₁) .(l ,` r) (LT l₁ r₁ x) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = LT l₁ r₁ x
SubsRets-theorem stm stf stm' .(l₁ ≤` r₁) .(l ,` r) (LE l₁ r₁ x) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = LE l₁ r₁ x
SubsRets-theorem stm stf stm' .(l₁ >` r₁) .(l ,` r) (GT l₁ r₁ x) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = GT l₁ r₁ x
SubsRets-theorem stm stf stm' .(l₁ ≥` r₁) .(l ,` r) (GE l₁ r₁ x) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = GE l₁ r₁ x
SubsRets-theorem stm stf stm' .(l₁ ≡` r₁) .(l ,` r) (EQ l₁ r₁ x) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = EQ l₁ r₁ x
SubsRets-theorem stm stf stm' .TRUE .(l ,` r) TT (tl l r .stm st' .stm' cmd cmd₁) = TT
SubsRets-theorem stm stf stm' .(b1 &&` b2) .(l ,` r) (AND b1 b2 P P₁) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = AND b1 b2 P P₁
SubsRets-theorem stm stf stm' .(b1 ||` b2) .(l ,` r) (ORL b1 b2 P) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = ORL b1 b2 P
SubsRets-theorem stm stf stm' .(b1 ||` b2) .(l ,` r) (ORR b1 b2 P) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = ORR b1 b2 P
SubsRets-theorem stm stf stm' .(¬` b) .(l ,` r) (NOT b x) (tl l r .stm st' .stm' cmd cmd₁) rewrite
 getstatesr-eq-lemma stm stf st' l cmd | getstatesr-eq-lemma st' stf stm' r cmd₁ = NOT b x

-- FIXME: The post condition is being proved only for 2 concurrent
-- calls, but can be easily extended to N using an inductive
-- data-structure.
conc-post-lemma : ∀ (stf1 stf2 stm1 stm1' stm2 stm2' : (String → ℕ)) → (Q1 Q2 : Bexp {ℕ})
                  → (r1 r2 : RTuple)
                  → (c1 : stf1 , stm1 -[ r1 ]->ᴿ stm1')
                  → (c2 : stf2 , stm2 -[ r2 ]->ᴿ stm2')
                  → (SubsRets Q1 r1 stm1 stf1) × (SubsRets Q2 r2 stm2 stf2)
                  → (stm1' |= Q1 × stm2' |= Q2)
conc-post-lemma stf1 stf2 stm1 stm1' stm2 stm2' Q1 Q2 r1 r2 c1 c2 (fst Data.Product., snd) =
  (SubsRets-theorem stm1 stf1 stm1' Q1 r1 fst c1) Data.Product., SubsRets-theorem stm2 stf2 stm2' Q2 r2 snd c2

-- TODO: We need to show that stm2 |= Q2 ≡ stm |= Q2. This requires us
-- to show that merge does not change the values of stm2, which
-- guarantee stm2 |= Q2. This is from the rule of constancy

-- TODO: Rule of constancy can be proven, by first using t_update_neq
-- from Map and then proving the lookup on aeval.

merge-cong : ∀ (v1 v2 : String) → (v1 ≡ v2) → (Ret v1 ≡ Ret v2)
merge-cong v1 .v1 refl = refl

postulate merge-lemma : ∀ (stm1 stm2 stm : (String → ℕ)) → (Q2 : Bexp {ℕ})
              → (r1 r2 : RTuple) → (merge : stm1 , stm2 -[ r1 ]->ᴿ stm)
              → stm2 |= Q2 → ¬ (r2 ≡ r1) → stm |= Q2
-- merge-lemma stm1 stm2 .(Store stm2 v (stm1 v)) Q2 .(Ret v) (Ret v₂) (hd v v1 v2 .stm2) p q rewrite t-update-neq stm2 v v₂ (stm1 v) λ x → ⊥-elim (q (merge-cong v₂ v x)) = {!!}
-- merge-lemma stm1 stm2 .(Store stm2 v (stm1 v)) Q2 .(Ret v) (r2 ,` r3) (hd v v1 v2 .stm2) p q = {!!}
-- merge-lemma stm1 stm2 stm Q2 .(l ,` r) r2 (tl l r .stm2 st' .stm merge merge₁) p q = {!!}

-- Now the theorem that Q1 &&` Q2 hold on the merged stm stack XXX:
-- Again this is being done only for two concurrent functions, but can
-- be extended to N via an inductive data type.
conc-post-theorem : ∀ (stm1 stm2 stm : (String → ℕ)) → (Q1 Q2 : Bexp {ℕ})
                    -- stm is the merged stack
                    → (r1 r2 : RTuple) → (merge : stm1 , stm2 -[ r1 ]->ᴿ stm)
                    → (stm1 |= Q1 × stm2 |= Q2)
                    → (P : SubsRets Q1 r1 stm2 stm1)
                    → ¬ (r2 ≡ r1)
                    → (stm |= (Q1 &&` Q2))
conc-post-theorem stm1 stm2 stm Q1 Q2 r1 r2 merge (_ Data.Product., snd) P nr =
  AND Q1 Q2 (SubsRets-theorem stm2 stm1 stm Q1 r1 P merge) (merge-lemma stm1 stm2 stm Q2 r1 r2 merge snd nr)

-- TODO: This is the theorem for post-condition for two concurrent
-- function calls. This is harder than the pre-condition.

-- 1.) In this case caller stack goes from stm -> stm' and stm -> stm''
-- for the two functions called concurrently.

-- 2.) stm'' and stm' need to be combined into a single stm''' after the
-- execution of the two functions concurrently? But how? This will be
-- done in FuncCall relational semantics data type above.

-- 3.) Once we have point 2 done then we can prove the correctness same
-- as conc-pre-theorem but for post-condition of || or //.

-- XXX: Use the above lemma to show the side condition state of R' X ≡
-- stf I and so on for all outputs.

-- Subs theorem states that Hoare' subs rule is valid (or sound)
subs-theoremℙ : ∀ (Γ : String → Maybe (ProgTuple {ℕ}))
          → ∀ (st st' : (String → ℕ)) → (X : String) → (e : Aexp {ℕ})
          → (Q : Bexp {ℕ}) → (P : (Subsℙ Q X e st))
          → (C : Γ , st =[ Var X := e ]=> st')
          → (Assertℙ Q st')
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(l <` r) (LT l r x) (CASSIGN .st .X .e) = LT l r x
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(l ≤` r) (LE l r x) (CASSIGN .st .X .e) = LE l r x
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(l >` r) (GT l r x) (CASSIGN .st .X .e) = GT l r x
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(l ≥` r) (GE l r x) (CASSIGN .st .X .e) = GE l r x
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(l ≡` r) (EQ l r x) (CASSIGN .st .X .e) = EQ l r x
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .TRUE TT (CASSIGN .st .X .e) = TT
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(b1 &&` b2) (AND b1 b2 p p₁) (CASSIGN .st .X .e) = AND b1 b2 p p₁
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(b1 ||` b2) (ORL b1 b2 p) (CASSIGN .st .X .e) = ORL b1 b2 p
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(b1 ||` b2) (ORR b1 b2 p) (CASSIGN .st .X .e) = ORR b1 b2 p
subs-theoremℙ Γ st .(Store st X (aeval st e)) X e .(¬` b) (NOT b p) (CASSIGN .st .X .e) = NOT b p

-- Consequence hoare rule theorem the general case soundness theorem.
-- This works for both P₁ ⇒ P ∧ Q ⇒ Q₁. Model the implication using (¬`
-- P₁) ||` P and (¬` Q) ||` Q₁
cons-theorem : ∀ (st : (String → ℕ)) → ∀ (P Q : Bexp {ℕ}) → Assertℙ P st
             → st |= ((¬` P) ||` Q) → Assertℙ Q st
cons-theorem st P Q a (ORL .(¬` P) .Q (NOT .P x)) = ⊥-elim (x a)
cons-theorem st P Q a (ORR .(¬` P) .Q b) = b

-- The SKIP Hoare rule soundness theorem
skip-theorem : ∀ (Γ : String → Maybe (ProgTuple {ℕ})) →
               ∀ (st st' : (String → ℕ)) → ∀ (P : Bexp {ℕ})
               → Assertℙ P st → Γ , st =[ SKIP ]=> st'
               → Assertℙ P st'
skip-theorem Γ st .st p sk (CSKIP .st) = sk

-- The Sequence Hoare rule soundness theorem.

-- Definition of a sound sequence rule
data _,≪_≫_≪_≫ (Γ : String → Maybe (ProgTuple {ℕ})) : Bexp {ℕ}
                  → Cmd {ℕ} → Bexp {ℕ} → Set where
  HSEQ : ∀ (st st' :  (String → ℕ))
         → (c1 c2 : Cmd {ℕ})
         → (P Q : Bexp {ℕ})
         → st |= P
         → Γ , st =[ c1 ; c2 ]=> st'
         → st' |= Q
         →
         -----------------------------------------------------------
         Γ ,≪ P ≫ (c1 ; c2) ≪ Q ≫

-- The sequence rule soundness theorem
-- this is a different way of looking at it
seq-theorem : ∀ (Γ : String → Maybe (ProgTuple {ℕ}))
              → ∀ (st st' st'' : (String → ℕ))
              → (c1 c2 : Cmd {ℕ})
              → (P Q R : Bexp {ℕ})
              → (Γ , st =[ c1 ]=> st')
              → (Γ , st' =[ c2 ]=> st'')
              → st |= P
              → st' |= Q
              → st'' |= R
              → Γ ,≪ P ≫ c1 ; c2 ≪ R ≫
seq-theorem Γ st st' st'' c1 c2 P Q R sc1 sc2 p _ r
  = HSEQ st st'' c1 c2 P R p (CSEQ st st' st'' c1 c2 sc1 sc2) r

-- Help lemma
contradiction-lemma : ∀ (b : Bexp {ℕ}) → ∀ (st : (String → ℕ))
                      → (beval st b ≡ true)
                      → (beval st b ≡ false) → ⊥
contradiction-lemma b st p rewrite p = λ ()

-- Deterministic lemma for argument passing
deterministic-ret-lemma : ∀ (stf stm stm' stm'' : (String → ℕ)) → (rets : RTuple)
                          → (stm , stf -[ rets ]->ᴿ stm') → (stm , stf   -[ rets ]->ᴿ stm'')
                          → (stm' ≡ stm'')
deterministic-ret-lemma stf stm .(Store stf v (stm v)) .(Store stf v (stm v)) .(Ret v) (hd v v1 v2 .stf) (hd .v v3 v4 .stf) = refl
deterministic-ret-lemma stf stm stm' stm'' .(l ,` r) (tl l r .stf st' .stm' p1 p3) (tl .l .r .stf st'' .stm'' p2 p4) with deterministic-ret-lemma stf stm st' st'' l p1 p2
... | refl with deterministic-ret-lemma st' stm stm' stm'' r p3 p4
... | refl = refl

-- Deterministic lemma for argument passing
deterministic-arg-lemma : ∀ (stm stf stf' stf'' : (String → ℕ)) → (args : ATuple)
                          → (stm , stf -[ args ]->ᴬ stf') → (stm , stf -[ args ]->ᴬ stf'')
                          → (stf' ≡ stf'')
deterministic-arg-lemma stm stf .(Store stf v (stm v)) .(Store stf v (stm v)) .(Arg v) (hd v .stf) (hd .v .stf) = refl
deterministic-arg-lemma stm stf stf' stf'' .(l ,` r) (tl l r .stf st' .stf' p1 p3) (tl .l .r .stf st'' .stf'' p2 p4) with deterministic-arg-lemma stm stf st' st'' l p1 p2
... | refl with deterministic-arg-lemma stm st' stf' stf'' r p3 p4
... | refl = refl

mutual
-- The deterministic execution for function calls
 deterministic-func-theorem : ∀ (Γ : (String → Maybe (ProgTuple {ℕ})))
                              → ∀ (stm stm1 stm2 : (String → ℕ))
                              → ∀ (f : FuncCall {ℕ} )
                              → Γ , stm =[ f ]=>ᶠ stm2
                              → Γ , stm =[ f ]=>ᶠ stm1
                              → stm2 ≡ stm1
 deterministic-func-theorem Γ stm stm1 stm2 .(< getProgRets (Γ fname) >:= fname < getProgArgs (Γ fname) >) (Base fname .stm stf' stf'' .stm2 x x₁ x₂) (Base .fname .stm stf''' stf'''' .stm1 x₃ x₄ x₅) with deterministic-arg-lemma stm (K 0) stf' stf''' (getProgArgs (Γ fname)) x x₃
 ... | refl with deterministic-exec-theorem Γ stf' stf'' stf'''' (getProgCmd (Γ fname)) x₁ x₄
 ... | refl with deterministic-ret-lemma stm stf'' stm1 stm2 (getProgRets (Γ fname)) x₅ x₂
 ... | refl = refl

-- Lemma for deterministic execution of commands
 deterministic-exec-theorem : ∀ (Γ : String → Maybe (ProgTuple {ℕ}))
                           → ∀ (st st' st'' : String → ℕ)
                           → ∀ (c : Cmd {ℕ})
                           → Γ , st =[ c ]=> st'
                           → Γ , st =[ c ]=> st''
                           → st' ≡ st''
 deterministic-exec-theorem Γ st .st .st .SKIP (CSKIP .st) (CSKIP .st) = refl
 deterministic-exec-theorem Γ st .(Store st x (aeval st e)) .(Store st x (aeval st e)) .(Var x := e) (CASSIGN .st x e) (CASSIGN .st .x .e) = refl
 deterministic-exec-theorem Γ st st' st'' .(c1 ; c2) (CSEQ .st st''' .st' c1 c2 e1 e3) (CSEQ .st st'''' .st'' .c1 .c2 e2 e4) with deterministic-exec-theorem Γ st st''' st'''' c1 e1 e2
 ... | refl  with deterministic-exec-theorem Γ st''' st'' st' c2 e4 e3
 ... | refl = refl
 deterministic-exec-theorem Γ st st' st'' .(IF b THEN t ELSE e END) (CIFT .st .st' b t e x e1) (CIFT .st .st'' .b .t .e x₁ e2) with deterministic-exec-theorem Γ st st'' st' t e2 e1
 ... | refl = refl
 deterministic-exec-theorem Γ st st' st'' .(IF b THEN t ELSE e END) (CIFT .st .st' b t e x e1) (CIFE .st .st'' .b .t .e x₁ e2) = ⊥-elim (contradiction-lemma b st x x₁)
 deterministic-exec-theorem Γ st st' st'' .(IF b THEN t ELSE e END) (CIFE .st .st' b t e x e1) (CIFT .st .st'' .b .t .e x₁ e2) = ⊥-elim (contradiction-lemma b st x₁ x)
 deterministic-exec-theorem Γ st st' st'' .(IF b THEN t ELSE e END) (CIFE .st .st' b t e x e1) (CIFE .st .st'' .b .t .e x₁ e2) with deterministic-exec-theorem Γ st st'' st' e e2 e1
 ... | refl = refl
 deterministic-exec-theorem Γ st .st .st .(WHILE b DO c END) (CLF .st b c x) (CLF .st .b .c x₁) = refl
 deterministic-exec-theorem Γ st .st st'' .(WHILE b DO c END) (CLF .st b c x) (CLT .st st' .st'' .b .c x₁ e2 e3) = ⊥-elim (contradiction-lemma b st x₁ x)
 deterministic-exec-theorem Γ st st' .st .(WHILE b DO c END) (CLT .st st''' .st' b c x e1 e3) (CLF .st .b .c x₁) = ⊥-elim (contradiction-lemma b st x x₁)
 deterministic-exec-theorem Γ st st' st'' .(WHILE b DO c END) (CLT .st st''' .st' b c x e1 e3) (CLT .st st'''' .st'' .b .c x₁ e2 e4) with deterministic-exec-theorem Γ st st'''' st''' c e2 e1
 ... | refl with deterministic-exec-theorem Γ st''' st'' st' (WHILE b DO c END) e4 e3
 ... | refl = refl
 deterministic-exec-theorem Γ st st' st'' (EXEC < ret >:= f < args >) (CEX .(< ret >:= f < args >) .st .st' x) (CEX .(< ret >:= f < args >) .st .st'' x₁) with deterministic-func-theorem Γ st  st' st'' < ret >:= f < args > x₁ x
 ... | refl = refl

-- Proving seq rule soundness via standard technique
seq-theorem1 : ∀ (Γ : String → Maybe (ProgTuple {ℕ}))
              → ∀ (st1 st2 st3 st4 : (String → ℕ))
              → (c1 c2 : Cmd {ℕ})
              → (P Q R : Bexp {ℕ})
              → (Γ , st1 =[ c1 ]=> st2)
              → (Γ , st2 =[ c2 ]=> st3)
              → st1 |= P
              → st2 |= Q
              → st3 |= R
              → Γ , st1 =[ c1 ; c2 ]=> st4
              → st4 |= R
seq-theorem1 Γ st1 st2 st3 st4 c1 c2 P Q R ec1 ec2 st1p st2q st3r (CSEQ .st1 st' .st4 .c1 .c2 ec12 ec13) with deterministic-exec-theorem Γ st1 st2 st' c1 ec1 ec12
... | refl with deterministic-exec-theorem Γ st2 st3 st4 c2 ec2 ec13
... | refl = st3r

-- TODO: Add If-else and while soundness rules if you want here

-- This is the derivable one (completely syntactic, not semantic)

-- In my case I will follow the same technique as SF, but instead of
-- taking propositions I will take the state and the boolean expression
-- for each proposition. This will make the syntactic derivation of
-- Hoare rules possible.


open import Data.Product using ( _×_ ; _,_ )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import FRP.LTL.RSet.Core using ( RSet )
open import FRP.LTL.Time.Bound using
  ( Time∞ ; fin ; _≼_ ; _≺_ ; ≼-refl ; _≼-trans_ ; _≼-asym_ ; _≼-total_ ; _≺-transˡ_
  ; ≺-impl-≼ ; ≡-impl-≼ ; ≡-impl-≽ ; ≺-impl-⋡ ; src )
open import FRP.LTL.Time.Interval using
  ( Interval ; [_⟩ ; _⊑_ ; _~_ ; _,_ ; lb ; ub ; lb≼ ; ≺ub ; Int ; _⌢_∵_
  ; ⊑-impl-≼ ; ⊑-impl-≽ ; lb≺ub ; ⊑-refl ; _⊑-trans_ ; ⌢-inj₁ ; ⌢-inj₂ ; sing )
open import FRP.LTL.Util using ( ≡-relevant ; ⊥-elim )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Relation.Unary using ( _∈_ )

module FRP.LTL.ISet.Core where

infixr 4 _,_

-- Monotone interval types

-- An MSet is a pair (A , split , subsum) where
-- A : Interval → Set
-- if σ : A [ s≼t≼u ⟩ then (split s≼t t≼u σ) : (A [ s≼t ⟩ × A [ t≼u ⟩)
-- if i ⊑ j and σ : A j then subsum i⊑j σ : A i

-- Note that subsum and split are interderivable, but
-- we provide both for efficiency.

-- In previous versions of MSet, we also included comp (an inverse of split)
-- and id (a unit for comp) but &&& and loop have been rewritten to avoid needing comp.

data MSet : Set₁ where
  _,_ : (A : Interval → Set) →
    ((∀ i j i~j → A (i ⌢ j ∵ i~j) → (A i × A j)) × (∀ i j → (i ⊑ j) → A j → A i)) →
    MSet

-- The underlying "unboxed" elements of an MSet

U⟦_⟧ : MSet → Interval → Set
U⟦ A , _ ⟧ = A

-- A "boxed" element of an MSet. This is used rather than the unboxed
-- representation because it's invertable, and so plays much better
-- with the type inference algorithm.

data B⟦_⟧ (A : MSet) (i : Interval) : Set where
  [_] : U⟦ A ⟧ i → B⟦ A ⟧ i

unbox : ∀ {A i} → B⟦ A ⟧ i → U⟦ A ⟧ i
unbox [ a ] = a

splitB⟦_⟧ : ∀ A i j i~j → B⟦ A ⟧ (i ⌢ j ∵ i~j) → (B⟦ A ⟧ i × B⟦ A ⟧ j)
splitB⟦ A , split , subsum ⟧ i j i~j [ σ ] with split i j i~j σ
... | (σ₁ , σ₂) = ([ σ₁ ] , [ σ₂ ])

subsumB⟦_⟧ : ∀ A i j → (i ⊑ j) → B⟦ A ⟧ j → B⟦ A ⟧ i
subsumB⟦ A , split , subsum ⟧ i j i⊑j [ σ ] = [ subsum i j i⊑j σ ]

-- Interval types

data ISet : Set₁ where
  [_] : MSet → ISet
  _⇛_ : MSet → ISet → ISet

-- Non-monotone semantics of ISets

I⟦_⟧ : ISet → Interval → Set
I⟦ [ A ] ⟧ i = B⟦ A ⟧ i
I⟦ A ⇛ B ⟧ i = B⟦ A ⟧ i → I⟦ B ⟧ i

-- Monotone semantics of ISets

M⟦_⟧ : ISet → Interval → Set
M⟦ [ A ] ⟧ i = B⟦ A ⟧ i
M⟦ A ⇛ B ⟧ i = ∀ j → (j ⊑ i) → I⟦ A ⇛ B ⟧ j

-- User-level semantics

⟦_⟧ : ISet → Set
⟦ A ⟧ = ∀ {i} → I⟦ A ⟧ i

-- Translation of ISet into MSet

splitM⟦_⟧ : ∀ A i j i~j → M⟦ A ⟧ (i ⌢ j ∵ i~j) → (M⟦ A ⟧ i × M⟦ A ⟧ j)
splitM⟦ [ A ] ⟧ i j i~j σ = splitB⟦ A ⟧ i j i~j σ
splitM⟦ A ⇛ B ⟧ i j i~j f = (f₁ , f₂) where

  f₁ : ∀ k → (k ⊑ i) → B⟦ A ⟧ k → I⟦ B ⟧ k
  f₁ k k⊑i = f k (⊑-impl-≽ k⊑i , ⊑-impl-≼ k⊑i ≼-trans ≡-impl-≼ i~j ≼-trans ≺-impl-≼ (lb≺ub j))

  f₂ : ∀ k → (k ⊑ j) → B⟦ A ⟧ k → I⟦ B ⟧ k
  f₂ k k⊑j = f k (≺-impl-≼ (lb≺ub i) ≼-trans ≡-impl-≼ i~j ≼-trans ⊑-impl-≽ k⊑j , ⊑-impl-≼ k⊑j)

subsumM⟦_⟧ : ∀ A i j → (i ⊑ j) → M⟦ A ⟧ j → M⟦ A ⟧ i
subsumM⟦ [ A ] ⟧ i j i⊑j σ = subsumB⟦ A ⟧ i j i⊑j σ
subsumM⟦ A ⇛ B ⟧ i j i⊑j f = λ h h⊑i → f h (h⊑i ⊑-trans i⊑j)

mset : ISet → MSet
mset A =  ( M⟦ A ⟧ , splitM⟦ A ⟧ , subsumM⟦ A ⟧ )

-- Translations back and forth between M⟦ A ⟧ and I⟦ A ⟧

m→i : ∀ {A i} → M⟦ A ⟧ i → I⟦ A ⟧ i
m→i {[ A ]} {i} σ = σ
m→i {A ⇛ B} {i} f = f i ⊑-refl

i→m : ∀ {A i} → (∀ j → (j ⊑ i) → I⟦ A ⟧ j) → M⟦ A ⟧ i
i→m {[ A ]} {i} σ = σ i ⊑-refl
i→m {A ⇛ B} {i} f = f

-- Embedding of RSet into ISet

⌈_⌉ : RSet → ISet
⌈ A ⌉ = [ (λ i → ∀ t → .(t ∈ Int i) → A t) , split , subsum ] where

  split : ∀ i j i~j → (∀ t → .(t ∈ Int (i ⌢ j ∵ i~j)) → A t) →
    ((∀ t → .(t ∈ Int i) → A t) × (∀ t → .(t ∈ Int j) → A t))
  split i j i~j σ =
    ( (λ t t∈i → σ t (lb≼ t∈i , ≺ub t∈i ≺-transˡ ≡-impl-≼ i~j ≼-trans ≺-impl-≼ (lb≺ub j)))
    , (λ t t∈j → σ t (≺-impl-≼ (lb≺ub i) ≼-trans ≡-impl-≼ i~j ≼-trans lb≼ t∈j , ≺ub t∈j)) )

  subsum : ∀ i j → (i ⊑ j) → (∀ t → .(t ∈ Int j) → A t) → (∀ t → .(t ∈ Int i) → A t)
  subsum i j i⊑j σ t t∈i = σ t (⊑-impl-≽ i⊑j ≼-trans lb≼ t∈i , ≺ub t∈i ≺-transˡ ⊑-impl-≼ i⊑j)

-- Embedding of ISet into RSet

⌊_⌋ : ISet → RSet
⌊ A ⌋ t = M⟦ A ⟧ (sing t)

-- Embedding of Set into ISet

data Always (A : Set) (i : Interval) : Set where
  const : A → Always A i
  var : ∀ j → .(i ⊑ j) → (∀ t → .(t ∈ Int j) → A) → Always A i

⟨_⟩ : Set → ISet
⟨ A ⟩ =  [ Always A , split , subsum ] where

  split : ∀ i j i~j → Always A (i ⌢ j ∵ i~j) → (Always A i × Always A j)
  split i j i~j (const a) = (const a , const a)
  split i j i~j (var k i⌢j⊑k f) =
    ( var k (⌢-inj₁ i j i~j ⊑-trans i⌢j⊑k) f
    , var k (⌢-inj₂ i j i~j ⊑-trans i⌢j⊑k) f )

  subsum : ∀ i j → (i ⊑ j) → Always A j → Always A i
  subsum i j i⊑j (const a)     = const a
  subsum i j i⊑j (var k j⊑k f) = var k (i⊑j ⊑-trans j⊑k) f


-- The (pre)category of (small) categories
{-# OPTIONS --safe #-}

module Cubical.Categories.Instances.Categories where

open import Cubical.Categories.Category.Base
open import Cubical.Categories.Category.Precategory
open import Cubical.Categories.Functor.Base
open import Cubical.Categories.Functor.Properties
open import Cubical.Foundations.Prelude

module _ (ℓ ℓ' : Level) where
  open Precategory

  CatPrecategory : Precategory (ℓ-suc (ℓ-max ℓ ℓ')) (ℓ-max ℓ ℓ')
  CatPrecategory .ob = Category ℓ ℓ'
  CatPrecategory .Hom[_,_] = Functor
  CatPrecategory .id = 𝟙⟨ _ ⟩
  CatPrecategory ._⋆_ G H = H ∘F G
  CatPrecategory .⋆IdL _ = F-lUnit
  CatPrecategory .⋆IdR _ = F-rUnit
  CatPrecategory .⋆Assoc _ _ _ = F-assoc

-- TODO: what is required for Functor C D to be a set?


{-# OPTIONS --without-K --rewriting --allow-unsolved-metas #-}

open import HoTT renaming (pt to pt⊙)
open import homotopy.DisjointlyPointedSet
open import lib.types.Nat
open import lib.types.Vec

module simplicial.Base where

-- HELPERS
combinations : ℕ → List ℕ -> List (List ℕ)
combinations 0 _ = nil :: nil
combinations _ nil = nil
combinations (S n) (x :: xs) = (map (λ ys → x :: ys) (combinations (n) xs)) ++ (combinations (S n) xs)

standardSimplex : ℕ → List ℕ
standardSimplex O = nil
standardSimplex (S x) = (S x) :: (standardSimplex x)

-- UGLY HELPER FUNCTIONS -- TO BE REPLACED WITH STANDARD FUNCTIONS LATER ON
bfilter : {A : Type₀} → ((a : A) → Bool) → List A → List A
bfilter f nil = nil
bfilter f (a :: l) with f a
... | inl _ = a :: (bfilter f l)
... | inr _ = bfilter f l

ℕin : ℕ → List ℕ → Bool
ℕin x nil = inr unit
ℕin x (y :: ys) with ℕ-has-dec-eq x y
... | inl x₁ = inl unit
... | inr x₁ = inr unit

_lsubset_ : List ℕ → List ℕ → Bool
nil lsubset ys = inl unit
(x :: xs) lsubset ys with ℕin x ys
... | inl _ = xs lsubset ys
... | inr _ = inr unit

-- TYPES FOR SIMPLICES
-- 'Simplices' saves a collection of simplices, grouped by their dimension.
-- Note that we do not specify the dimensions of individual simplices, since
-- otherwise we could not simply save all simplices in a single vector
Simplex = List ℕ
Simplices : ℕ → Type₀
Simplices dim = (Vec (List Simplex) dim)

is-closed : {dim : ℕ} → (Simplices dim) → Type₀

record SC (dim : ℕ) : Type₀ where
  constructor complex
  field
    simplices : Simplices dim
    closed : is-closed simplices

simplices : {dim : ℕ} → SC dim → Simplices dim
simplices (complex simplices _) = simplices

faces : Simplex → List Simplex
faces s = concat (map (λ l → combinations l s) (standardSimplex (ℕ-pred (length s))))

-- removes grouping of simplices by dimension and puts all simplices in single list
compress : {dim : ℕ} → Simplices dim → List Simplex
compress {dim} []         = nil
compress {dim} (xs ∷ xss) = xs ++ compress xss

bodies : {dim : ℕ} → (SC dim) → Simplex → List Simplex
bodies (complex ss _) s = bfilter (λ o → (s lsubset o)) (compress ss)

-- inverse of compress function
unfold : {dim : ℕ}  → List Simplex → Simplices dim
unfold {dim} ss = unfold' {dim} ss (emptyss dim)
  where
  emptyss : (dim : ℕ) → Simplices dim
  emptyss 0 = []
  emptyss (S n) = nil ∷ (emptyss n)
  unfold' : {dim : ℕ}  → List Simplex → Simplices dim → Simplices dim
  unfold' {dim} nil sc = sc
  unfold' {dim} (x :: ss) sc = insert (faces x) sc
      where
      insert : {dim : ℕ} → List Simplex → Simplices dim → Simplices dim
      insert nil sc = sc
      insert (s :: ss) sc = insertS s sc
          where
          insertS : {dim : ℕ} → Simplex → Simplices dim → Simplices dim
          insertS s sc = updateAt ((length s) , {!!}) (λ l → s :: l) sc

is-closed {dim} ss = All (λ s → All (λ f → f ∈ ssc) (faces s)) ssc
  where ssc = compress ss

-- takes facet description of SC and generates their face closure
SCgenerator : (dim : ℕ) → List Simplex → SC dim
SC.simplices (SCgenerator dim ss) = unfold $ concat(concat (map(λ simplex → map (λ l → combinations l simplex) (standardSimplex (length simplex))) ss))
SC.closed (SCgenerator dim ss) = {!!}

-- EXAMPLES

sc-unit : SC 2
SC.simplices sc-unit = ((1 :: nil) :: (2 :: nil) :: nil) ∷ ((1 :: 2 :: nil) :: nil) ∷ []
SC.closed sc-unit = nil :: (nil :: (((here idp) :: ((there (here idp)) :: nil)) :: nil))

sc-circle : SC 2
SC.simplices sc-circle =
  ((1 :: nil) :: (2 :: nil) :: (3 :: nil) :: nil) ∷
  ((1 :: 2 :: nil) :: (1 :: 3 :: nil) :: (2 :: 3 :: nil) :: nil) ∷ []
SC.closed sc-circle = nil :: (nil :: (nil :: (((here idp) :: ((there (here idp)) :: nil)) :: (((here idp) :: ((there (there (here idp))) :: nil)) :: ((there (here idp) :: (there (there (here idp)) :: nil)) :: nil)))))

-- sc-circle-equiv-cw-circle : CWSphere 1 ≃ CWSphere 1
-- sc-circle-equiv-cw-circle = {!!}

sc-sphere : SC 3
sc-sphere = SCgenerator 3 ((1 :: 2 :: 3 :: nil) :: (1 :: 3 :: 4 :: nil) :: (2 :: 3 :: 4 :: nil) :: (1 :: 3 :: 4 :: nil) :: nil)

sc-unit-gen : SC 2
sc-unit-gen = SCgenerator 2 ((1 :: 2 :: nil) :: nil)

-- sc-unit≃sc-unit-gen : sc-unit ≃ sc-unit-gen
-- sc-unit≃sc-unit-gen = ?


{-

This file contains:

- 3×3 lemma for pushouts
  Written by: Loïc Pujet, April 2019

-}

{-# OPTIONS --cubical --safe #-}

module Cubical.HITs.Pushout.Properties where

open import Cubical.Core.Glue

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Prod.Base
open import Cubical.Data.Unit

open import Cubical.HITs.Pushout.Base

{-

  3×3 lemma for pushouts

Let Aᵢⱼ denote a type, fᵢⱼ a map and Hᵢⱼ a homotopy. Given a diagram of the following shape:

A00 ←—f01—— A02 ——f03—→ A04
 ↑           ↑           ↑
f10   H11   f12   H13   f14
 |           |           |
A20 ←—f21—— A22 ——f23—→ A24
 |           |           |
f30   H31   f32   H33   f34
 ↓           ↓           ↓
A40 ←—f41—— A42 ——f43—→ A44

one can build its colimit from pushouts in two ways:
- either build pushouts A□0, A□2, A□4 of the lines and then build the pushout A□○ of the resulting
  diagram A□0 ←—f□1—— A□2 ——f□3—→ A□4 ;
- or build pushouts of the columns and build the pushout A○□ of the resulting diagram A0□ ← A2□ → A4□.

Then the lemma states there is an equivalence A□○ ≃ A○□.

-}

module 3x3-span
  (A00 A02 A04 A20 A22 A24 A40 A42 A44 : Type₀)

  (f10 : A20 → A00)
  (f12 : A22 → A02)
  (f14 : A24 → A04)

  (f30 : A20 → A40)
  (f32 : A22 → A42)
  (f34 : A24 → A44)

  (f01 : A02 → A00)
  (f21 : A22 → A20)
  (f41 : A42 → A40)

  (f03 : A02 → A04)
  (f23 : A22 → A24)
  (f43 : A42 → A44)

  (H11 : ∀ x → f01 (f12 x) ≡ f10 (f21 x))
  (H13 : ∀ x → f03 (f12 x) ≡ f14 (f23 x))
  (H31 : ∀ x → f41 (f32 x) ≡ f30 (f21 x))
  (H33 : ∀ x → f43 (f32 x) ≡ f34 (f23 x))
  where

  -- pushouts of the lines
  A□0 : Type₀
  A□0 = Pushout f10 f30

  A□2 : Type₀
  A□2 = Pushout f12 f32

  A□4 : Type₀
  A□4 = Pushout f14 f34

  -- maps between pushouts
  f□1 : A□2 → A□0
  f□1 (inl x) = inl (f01 x)
  f□1 (inr x) = inr (f41 x)
  f□1 (push a j) = ((λ i → inl (H11 a i))
                   ∙∙ push (f21 a)
                   ∙∙ (λ i → inr (H31 a (~ i)))) j

  f□3 : A□2 → A□4
  f□3 (inl x) = inl (f03 x)
  f□3 (inr x) = inr (f43 x)
  f□3 (push a j) = ((λ i → inl (H13 a i))
                   ∙∙ push (f23 a)
                   ∙∙ (λ i → inr (H33 a (~ i)))) j

  -- total pushout
  A□○ : Type₀
  A□○ = Pushout f□1 f□3

  -- pushouts of the columns
  A0□ : Type₀
  A0□ = Pushout f01 f03

  A2□ : Type₀
  A2□ = Pushout f21 f23

  A4□ : Type₀
  A4□ = Pushout f41 f43

  -- maps between pushouts
  f1□ : A2□ → A0□
  f1□ (inl x) = inl (f10 x)
  f1□ (inr x) = inr (f14 x)
  f1□ (push a j) = ((λ i → inl (H11 a (~ i)))
                   ∙∙ push (f12 a)
                   ∙∙ (λ i → inr (H13 a i))) j

  f3□ : A2□ → A4□
  f3□ (inl x) = inl (f30 x)
  f3□ (inr x) = inr (f34 x)
  f3□ (push a j) = ((λ i → inl (H31 a (~ i)))
                   ∙∙ push (f32 a)
                   ∙∙ (λ i → inr (H33 a i))) j

  -- total pushout
  A○□ : Type₀
  A○□ = Pushout f1□ f3□

  -- forward map of the equivalence A□○ ≃ A○□
  forward-l : A□0 → A○□
  forward-l (inl x) = inl (inl x)
  forward-l (inr x) = inr (inl x)
  forward-l (push a i) = push (inl a) i

  forward-r : A□4 → A○□
  forward-r (inl x) = inl (inr x)
  forward-r (inr x) = inr (inr x)
  forward-r (push a i) = push (inr a) i

  forward-filler : A22 → I → I → I → A○□
  forward-filler a i j = hfill (λ t → λ { (i = i0) → inl (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) j (~ t))
                                 ; (i = i1) → inr (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) j (~ t))
                                 ; (j = i0) → forward-l (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) i t)
                                 ; (j = i1) → forward-r (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) i t) })
                        (inS (push (push a j) i))

  A□○→A○□ : A□○ → A○□
  A□○→A○□ (inl x) = forward-l x
  A□○→A○□ (inr x) = forward-r x
  A□○→A○□ (push (inl x) i) = inl (push x i)
  A□○→A○□ (push (inr x) i) = inr (push x i)
  A□○→A○□ (push (push a i) j) = forward-filler a i j i1

  -- backward map
  backward-l : A0□ → A□○
  backward-l (inl x) = inl (inl x)
  backward-l (inr x) = inr (inl x)
  backward-l (push a i) = push (inl a) i

  backward-r : A4□ → A□○
  backward-r (inl x) = inl (inr x)
  backward-r (inr x) = inr (inr x)
  backward-r (push a i) = push (inr a) i

  backward-filler : A22 → I → I → I → A□○
  backward-filler a i j = hfill (λ t → λ { (i = i0) → inl (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) j (~ t))
                                 ; (i = i1) → inr (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) j (~ t))
                                 ; (j = i0) → backward-l (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) i t)
                                 ; (j = i1) → backward-r (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) i t) })
                        (inS (push (push a j) i))

  A○□→A□○ : A○□ → A□○
  A○□→A□○ (inl x) = backward-l x
  A○□→A□○ (inr x) = backward-r x
  A○□→A□○ (push (inl x) i) = inl (push x i)
  A○□→A□○ (push (inr x) i) = inr (push x i)
  A○□→A□○ (push (push a i) j) = backward-filler a i j i1

  -- first homotopy
  homotopy1-l : ∀ x → A□○→A○□ (backward-l x) ≡ inl x
  homotopy1-l (inl x) = refl
  homotopy1-l (inr x) = refl
  homotopy1-l (push a i) = refl

  homotopy1-r : ∀ x → A□○→A○□ (backward-r x) ≡ inr x
  homotopy1-r (inl x) = refl
  homotopy1-r (inr x) = refl
  homotopy1-r (push a i) = refl

  A○□→A□○→A○□ : ∀ x → A□○→A○□ (A○□→A□○ x) ≡ x
  A○□→A□○→A○□ (inl x) = homotopy1-l x
  A○□→A□○→A○□ (inr x) = homotopy1-r x
  A○□→A□○→A○□ (push (inl x) i) k = push (inl x) i
  A○□→A□○→A○□ (push (inr x) i) k = push (inr x) i
  A○□→A□○→A○□ (push (push a i) j) k =
    hcomp (λ t → λ { (i = i0) → forward-l (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) j (~ t))
                   ; (i = i1) → forward-r (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) j (~ t))
                   ; (j = i0) → homotopy1-l (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) i t) k
                   ; (j = i1) → homotopy1-r (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) i t) k
                   ; (k = i0) → A□○→A○□ (backward-filler a i j t)
                   ; (k = i1) → forward-filler a j i (~ t) })
          (forward-filler a j i i1)

  -- second homotopy
  homotopy2-l : ∀ x → A○□→A□○ (forward-l x) ≡ inl x
  homotopy2-l (inl x) = refl
  homotopy2-l (inr x) = refl
  homotopy2-l (push a i) = refl

  homotopy2-r : ∀ x → A○□→A□○ (forward-r x) ≡ inr x
  homotopy2-r (inl x) = refl
  homotopy2-r (inr x) = refl
  homotopy2-r (push a i) = refl

  A□○→A○□→A□○ : ∀ x → A○□→A□○ (A□○→A○□ x) ≡ x
  A□○→A○□→A□○ (inl x) = homotopy2-l x
  A□○→A○□→A□○ (inr x) = homotopy2-r x
  A□○→A○□→A□○ (push (inl x) i) k = push (inl x) i
  A□○→A○□→A□○ (push (inr x) i) k = push (inr x) i
  A□○→A○□→A□○ (push (push a i) j) k =
    hcomp (λ t → λ { (i = i0) → backward-l (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) j (~ t))
                   ; (i = i1) → backward-r (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) j (~ t))
                   ; (j = i0) → homotopy2-l (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) i t) k
                   ; (j = i1) → homotopy2-r (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) i t) k
                   ; (k = i0) → A○□→A□○ (forward-filler a i j t)
                   ; (k = i1) → backward-filler a j i (~ t) })
          (backward-filler a j i i1)

  -- equivalence
  Pushout3x3 : A□○ ≡ A○□
  Pushout3x3 = isoToPath (iso A□○→A○□ A○□→A□○ A○□→A□○→A○□ A□○→A○□→A□○)

Pushout3x3 : ∀ A00 A02 A04 A20 A22 A24 A40 A42 A44 f10 f12 f14 f30 f32 f34 f01 f21 f41 f03 f23 f43 H11 H13 H31 H33 →
  3x3-span.A□○ A00 A02 A04 A20 A22 A24 A40 A42 A44 f10 f12 f14 f30 f32 f34 f01 f21 f41 f03 f23 f43 H11 H13 H31 H33
  ≡ 3x3-span.A○□ A00 A02 A04 A20 A22 A24 A40 A42 A44 f10 f12 f14 f30 f32 f34 f01 f21 f41 f03 f23 f43 H11 H13 H31 H33
Pushout3x3 = 3x3-span.Pushout3x3


data D : Set where
  d : D

foo : D
foo = {!!}
-- C-c C-r gives me a weird-looking '0'


------------------------------------------------------------------------
-- Example: Right recursive expression grammar
------------------------------------------------------------------------

module TotalRecognisers.Simple.Expression where

open import Codata.Musical.Notation
open import Data.Bool
open import Data.Char as Char using (Char)
open import Data.String as String using (String)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable

import TotalRecognisers.Simple as P

private
  open module PC = P Char Char._≟_ hiding (_·_)
  open PC.P using (_·_)

------------------------------------------------------------------------
-- Recognisers for bits and binary numbers

-- Bits.

bit = tok '0' ∣ tok '1'

-- Numbers.

number = bit · ♯ (empty ∣ number)

------------------------------------------------------------------------
-- An expression grammar

-- t ∷= f '+' t ∣ f
-- f ∷= a '*' f ∣ a
-- a ∷= '(' t ')' ∣ n

mutual

  term   = factor · ♯ (tok '+' · ♯ term)
         ∣ factor

  factor = atom · ♯ (tok '*' · ♯ factor)
         ∣ atom

  atom   = tok '(' · ♯ term · ♯ tok ')'
         ∣ number

------------------------------------------------------------------------
-- Unit tests

module Tests where

  test : ∀ {n} → P n → String → Bool
  test p s = ⌊ String.toList s ∈? p ⌋

  ex₁ : test term "0*(0+0)" ≡ true
  ex₁ = refl

  ex₂ : test term "0*(0+0" ≡ false
  ex₂ = refl


------------------------------------------------------------------------------
-- Well-founded induction on the lexicographic order on natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Data.Nat.Induction.NonAcc.LexicographicI where

open import FOTC.Base
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------

Lexi-wfind :
  (A : D → D → Set) →
  (∀ {m₁ n₁} → N m₁ → N n₁ →
     (∀ {m₂ n₂} → N m₂ → N n₂ → Lexi m₂ n₂ m₁ n₁ → A m₂ n₂) → A m₁ n₁) →
  ∀ {m n} → N m → N n → A m n
Lexi-wfind A h Nm Nn = h Nm Nn (helper₂ Nm Nn)
  where
  helper₁ : ∀ {m n o} → N m → N n → N o → m < o → o < succ₁ n  → m < n
  helper₁ {m} {n} {o} Nm Nn No m<o o<Sn =
    Sx≤y→x<y Nm Nn (≤-trans (nsucc Nm) No Nn
                            (x<y→Sx≤y Nm No m<o)
                            (Sx≤Sy→x≤y {o} {n} (x<y→Sx≤y No (nsucc Nn) o<Sn)))

  helper₂ : ∀ {m₁ n₁ m₂ n₂} → N m₁ → N n₁ → N m₂ → N n₂ →
            Lexi m₂ n₂ m₁ n₁ → A m₂ n₂

  helper₂ Nm₁ Nn₂ nzero nzero 00<00 =
    h nzero nzero (λ Nm' Nn' m'n'<00 → ⊥-elim (xy<00→⊥ Nm' Nn' m'n'<00))

  helper₂ nzero nzero (nsucc Nm₂) nzero Sm₂0<00 = ⊥-elim (Sxy<0y'→⊥ Sm₂0<00)

  helper₂ (nsucc Nm₁) nzero (nsucc Nm₂) nzero Sm₂0<Sm₁0 =
    h (nsucc Nm₂) nzero (λ Nm' Nn' m'n'<Sm₂0 →
      helper₂ Nm₁ nzero Nm' Nn'
              (inj₁ (helper₁ Nm' Nm₁ (nsucc Nm₂)
                             (xy<x'0→x<x' Nn' m'n'<Sm₂0)
                             (xy<x'0→x<x' nzero Sm₂0<Sm₁0))))

  helper₂ nzero (nsucc Nn₁) (nsucc Nm₂) nzero Sm₂0<0Sn₁ =
    ⊥-elim (Sxy<0y'→⊥ Sm₂0<0Sn₁)

  helper₂ (nsucc Nm₁) (nsucc Nn₁) (nsucc Nm₂) nzero Sm₂0<Sm₁Sn₁ =
    h (nsucc Nm₂) nzero (λ Nm' Nn' m'n'<Sm₂0 →
      helper₂ (nsucc Nm₁) Nn₁ Nm' Nn'
        (inj₁ (case (λ Sm₂<Sm₁ → x<y→x<Sy Nm' Nm₁
                                          (helper₁ Nm' Nm₁ (nsucc Nm₂)
                                                  (xy<x'0→x<x' Nn' m'n'<Sm₂0)
                                                  Sm₂<Sm₁))
                    (λ Sm₂≡Sm₁∧0<Sn₁ → x<y→y≡z→x<z (xy<x'0→x<x' Nn' m'n'<Sm₂0)
                                                   (∧-proj₁ Sm₂≡Sm₁∧0<Sn₁))
                    Sm₂0<Sm₁Sn₁)))

  helper₂ nzero nzero nzero (nsucc Nn₂) 0Sn₂<00 = ⊥-elim (0Sx<00→⊥ 0Sn₂<00)

  helper₂ (nsucc {m₁} Nm₁) nzero nzero (nsucc Nn₂) 0Sn₂<Sm₁0 =
    h nzero (nsucc Nn₂) (λ Nm' Nn' m'n'<0Nn₂ →
      helper₂ Nm₁ (nsucc Nn₂) Nm' Nn'
              (case (λ m'<0 → ⊥-elim (x<0→⊥ Nm' m'<0))
                    (λ m'≡0∧n'<Sn₂ →
                      case (λ 0<m₁ → inj₁ (x≡y→y<z→x<z (∧-proj₁ m'≡0∧n'<Sn₂) 0<m₁))
                           (λ 0≡m₁ → inj₂ ((trans (∧-proj₁ m'≡0∧n'<Sn₂) 0≡m₁)
                                          , (∧-proj₂ m'≡0∧n'<Sn₂)))
                           (x<Sy→x<y∨x≡y nzero Nm₁ 0<Sm₁))
                    m'n'<0Nn₂))

    where
    0<Sm₁ : zero < succ₁ m₁
    0<Sm₁ = xy<x'0→x<x' (nsucc Nn₂) 0Sn₂<Sm₁0

  helper₂ nzero (nsucc Nn₁) nzero (nsucc Nn₂) 0Sn₂<0Sn₁ =
    case (λ 0<0 → ⊥-elim (0<0→⊥ 0<0))
         (λ 0≡0∧Sn₂<Sn₁ →
           h nzero (nsucc Nn₂) (λ Nm' Nn' m'n'<0Sn₂ →
             case (λ m'<0 → ⊥-elim (x<0→⊥ Nm' m'<0))
                  (λ m'≡0∧n'<Sn₂ →
                    helper₂ nzero Nn₁ Nm' Nn'
                      (inj₂ (∧-proj₁ m'≡0∧n'<Sn₂
                            , helper₁ Nn' Nn₁ (nsucc Nn₂)
                                          (∧-proj₂ m'≡0∧n'<Sn₂)
                                          (∧-proj₂ 0≡0∧Sn₂<Sn₁))))
                  m'n'<0Sn₂))
         0Sn₂<0Sn₁

  helper₂ (nsucc Nm₁) (nsucc Nn₁) nzero (nsucc Nn₂) 0Sn₂<Sm₁Sn₁ =
    h nzero (nsucc Nn₂) (λ Nm' Nn' m'n'<0Sn₂ →
      helper₂ (nsucc Nm₁) Nn₁ Nm' Nn'
        (case (λ m'<0 → ⊥-elim (x<0→⊥ Nm' m'<0))
              (λ m'≡0∧n'<Sn₂ →
                case (λ 0<Sm₁ → inj₁ (x≡y→y<z→x<z (∧-proj₁ m'≡0∧n'<Sn₂) 0<Sm₁))
                     (λ 0≡Sn₂∧Sn₂<Sn₁ → ⊥-elim (0≢S (∧-proj₁ 0≡Sn₂∧Sn₂<Sn₁)))
                     0Sn₂<Sm₁Sn₁)
              m'n'<0Sn₂))

  helper₂ nzero nzero (nsucc Nm₂) (nsucc Nn₂) Sm₂Sn₂<00 =
    ⊥-elim (xy<00→⊥ (nsucc Nm₂) (nsucc Nn₂) Sm₂Sn₂<00)

  helper₂ (nsucc {m₁} Nm₁) nzero (nsucc {m₂} Nm₂) (nsucc Nn₂) Sm₂Sn₂<Sm₁0 =
    h (nsucc Nm₂) (nsucc Nn₂) (λ Nm' Nn' m'n'<Sm₂Sn₂ →
      helper₂ Nm₁ (nsucc Nn₂) Nm' Nn'
        (case (λ m'<Sm₂ → inj₁ (helper₁ Nm' Nm₁ (nsucc Nm₂) m'<Sm₂ Sm₂<Sm₁))
              (λ m'≡Sm₂∧n'<Sn₂ →
                case (λ m'<m₁ → inj₁ m'<m₁)
                     (λ m'≡m₁ → inj₂ (m'≡m₁ , ∧-proj₂ m'≡Sm₂∧n'<Sn₂))
                     (x<Sy→x<y∨x≡y Nm' Nm₁
                                   (x≡y→y<z→x<z (∧-proj₁ m'≡Sm₂∧n'<Sn₂) Sm₂<Sm₁)))
              m'n'<Sm₂Sn₂))

    where
    Sm₂<Sm₁ : succ₁ m₂ < succ₁ m₁
    Sm₂<Sm₁ = xy<x'0→x<x' (nsucc Nn₂) Sm₂Sn₂<Sm₁0

  helper₂ nzero (nsucc Nn₁) (nsucc Nm₂) (nsucc Nn₂) Sm₂Sn₂<0Sn₁
    = ⊥-elim (Sxy<0y'→⊥ Sm₂Sn₂<0Sn₁)

  helper₂ (nsucc Nm₁) (nsucc Nn₁) (nsucc Nm₂) (nsucc Nn₂) Sm₂Sn₂<Sm₁Sn₁ =
    h (nsucc Nm₂) (nsucc Nn₂) (λ Nm' Nn' m'n'<Sm₂Sn₂ →
      helper₂ (nsucc Nm₁) Nn₁ Nm' Nn'
        (case (λ Sm₂<Sm₁ →
                 case (λ m'<Sm₂ → inj₁ (x<y→x<Sy Nm' Nm₁ (helper₁ Nm' Nm₁ (nsucc Nm₂) m'<Sm₂ Sm₂<Sm₁)))
                      (λ m'≡Sm₂∧n'<Sn₂ → inj₁ (x≡y→y<z→x<z (∧-proj₁ m'≡Sm₂∧n'<Sn₂) Sm₂<Sm₁))
                      m'n'<Sm₂Sn₂)

              (λ Sm₂≡Sm₁∧Sn₂<Sn₁ →
                case (λ m'<Sm₂ → inj₁ (x<y→y≡z→x<z m'<Sm₂ (∧-proj₁ Sm₂≡Sm₁∧Sn₂<Sn₁)))
                     (λ m'≡Sm₂∧n'<Sn₂ → inj₂
                       (trans (∧-proj₁ m'≡Sm₂∧n'<Sn₂) (∧-proj₁ Sm₂≡Sm₁∧Sn₂<Sn₁)
                       , helper₁ Nn' Nn₁ (nsucc Nn₂) (∧-proj₂ m'≡Sm₂∧n'<Sn₂) (∧-proj₂ Sm₂≡Sm₁∧Sn₂<Sn₁)))
                     m'n'<Sm₂Sn₂)
              Sm₂Sn₂<Sm₁Sn₁))


{-# OPTIONS --without-K #-}

open import HoTT
open import cohomology.FunctionOver
open import homotopy.elims.CofPushoutSection

module cohomology.MayerVietoris {i} where

{- Mayer-Vietoris Sequence: Given a span X ←f– Z –g→ Y, the cofiber space
   of the natural map [reglue : X ∨ Y → X ⊔_Z Y] (defined below) is equivalent
   to the suspension of Z. -}

{- Relevant functions -}
module MayerVietorisFunctions (ps : ⊙Span {i} {i} {i}) where

  open ⊙Span ps

  module Reglue = ⊙WedgeRec (⊙left ps) (⊙right ps)

  reglue : X ∨ Y → fst (⊙Pushout ps)
  reglue = Reglue.f

  ⊙reglue : fst (X ⊙∨ Y ⊙→ ⊙Pushout ps)
  ⊙reglue = Reglue.⊙f

  module MVDiff = SuspensionRec (fst Z) {C = Suspension (X ∨ Y)}
    (north _)
    (north _)
    (λ z → merid _ (winl (fst f z)) ∙ ! (merid _ (winr (fst g z))))

  mv-diff : Suspension (fst Z) → Suspension (X ∨ Y)
  mv-diff = MVDiff.f

  ⊙mv-diff : fst (⊙Susp Z ⊙→ ⊙Susp (X ⊙∨ Y))
  ⊙mv-diff = (mv-diff , idp)

{- We use path induction (via [⊙pushout-J]) to assume that the
   basepoint preservation paths of the span maps are [idp]. The module
   [MayerVietorisBase] contains the proof of the theorem for this case. -}
module MayerVietorisBase
  {A B : Type i} (Z : Ptd i) (f : fst Z → A) (g : fst Z → B) where

  X = ⊙[ A , f (snd Z) ]
  Y = ⊙[ B , g (snd Z) ]
  ps = ⊙span X Y Z (f , idp) (g , idp)
  F : fst (Z ⊙→ X)
  F = (f , idp)
  G : fst (Z ⊙→ Y)
  G = (g , idp)

  open MayerVietorisFunctions ps

  {- Definition of the maps
       into : Cofiber reglue → ΣZ
       out  : ΣZ → Cofiber reglue
   -}

  private
    into-glue-square :
      Square idp idp (ap (ext-glue ∘ reglue) wglue) (merid _ (snd Z))
    into-glue-square =
      connection ⊡v∙
      ! (ap-∘ ext-glue reglue wglue
         ∙ ap (ap ext-glue) (Reglue.glue-β ∙ !-! (glue (snd Z)))
         ∙ ExtGlue.glue-β (snd Z))

    module IntoGlue = WedgeElim {P = λ xy → north _ == ext-glue (reglue xy)}
      (λ _ → idp)
      (λ _ → merid _ (snd Z))
      (↓-cst=app-from-square into-glue-square)

    into-glue = IntoGlue.f

  module Into = CofiberRec reglue (north _) ext-glue into-glue

  private
    out-glue-and-square : (z : fst Z)
      → Σ (cfbase reglue == cfbase reglue)
          (λ p → Square (cfglue _ (winl (f z))) p
                   (ap (cfcod _) (glue z)) (cfglue _ (winr (g z))))
    out-glue-and-square z = fill-square-top _ _ _

    out-glue = fst ∘ out-glue-and-square
    out-square = snd ∘ out-glue-and-square

  module Out = SuspensionRec (fst Z) {C = Cofiber reglue}
    (cfbase _)
    (cfbase _)
    out-glue

  into = Into.f
  out = Out.f

  {- [out] is a right inverse for [into] -}

  private
    into-out-sq : (z : fst Z) →
      Square idp (ap into (ap out (merid _ z))) (merid _ z) (merid _ (snd Z))
    into-out-sq z =
      (ap (ap into) (Out.glue-β z) ∙v⊡
        (! (Into.glue-β (winl (f z)))) ∙h⊡
          ap-square into (out-square z)
        ⊡h∙ (Into.glue-β (winr (g z))))
      ⊡v∙ (∘-ap into (cfcod _) (glue z) ∙ ExtGlue.glue-β z)

  into-out : ∀ σ → into (out σ) == σ
  into-out = Suspension-elim (fst Z)
    idp
    (merid _ (snd Z))
    (λ z → ↓-∘=idf-from-square into out (into-out-sq z))

  {- [out] is a left inverse for [into] -}

  {- [out] is left inverse on codomain part of cofiber space,
   - i.e. [out (into (cfcod _ γ)) == cfcod _ γ] -}

  private
    out-into-cod-square : (z : fst Z) →
      Square (cfglue reglue (winl (f z)))
             (ap (out ∘ ext-glue {s = ⊙span-out ps}) (glue z))
             (ap (cfcod _) (glue z)) (cfglue _ (winr (g z)))
    out-into-cod-square z =
      (ap-∘ out ext-glue (glue z)
        ∙ ap (ap out) (ExtGlue.glue-β z) ∙ Out.glue-β z)
      ∙v⊡ out-square z

    module OutIntoCod = PushoutElim
      {d = ⊙span-out ps} {P = λ γ → out (into (cfcod _ γ)) == cfcod _ γ}
      (λ x → cfglue _ (winl x))
      (λ y → cfglue _ (winr y))
      (λ z → ↓-='-from-square (out-into-cod-square z))

    out-into-cod = OutIntoCod.f

  out-into : ∀ κ → out (into κ) == κ
  out-into = CofPushoutSection.elim reglue
    (λ _ → unit) (λ _ → idp)
    idp
    out-into-cod
    (↓-='-from-square ∘ λ x →
      (ap-∘ out into (cfglue _ (winl x))
       ∙ ap (ap out) (Into.glue-β (winl x)))
      ∙v⊡ connection
      ⊡v∙ ! (ap-idf (glue (winl x))))
    (↓-='-from-square ∘ λ y →
      (ap-∘ out into (cfglue _ (winr y))
       ∙ ap (ap out) (Into.glue-β (winr y))
       ∙ Out.glue-β (snd Z)
       ∙ square-top-unique (out-square (snd Z))
           (! (ap-cst (cfbase _) wglue) ∙v⊡
            natural-square (cfglue _) wglue
            ⊡v∙ (ap-∘ (cfcod _) reglue wglue
                 ∙ ap (ap (cfcod _)) (Reglue.glue-β ∙ !-! (glue (snd Z))))))
      ∙v⊡ connection
      ⊡v∙ ! (ap-idf (glue (winr y))))

  {- equivalence and path -}

  eq : Cofiber reglue ≃ Suspension (fst Z)
  eq = equiv into out into-out out-into

  ⊙eq : ⊙Cof ⊙reglue ⊙≃ ⊙Susp Z
  ⊙eq = ⊙≃-in eq idp

  path = ua eq
  ⊙path = ⊙ua ⊙eq

  {- Transporting [cfcod reglue] over the equivalence -}

  cfcod-over : cfcod reglue == ext-glue
              [ (λ W → fst (⊙Pushout ps) → fst W) ↓ ⊙path ]
  cfcod-over = ↓-cst2-in _ _ $ codomain-over-equiv _ _

  {- Transporting [ext-glue] over the equivalence. -}

  ext-over : ext-glue == mv-diff
             [ (λ W → fst W → fst (⊙Susp (X ⊙∨ Y))) ↓ ⊙path ]
  ext-over = ↓-cst2-in _ _ $ ! (λ= fn-lemma) ◃ domain-over-equiv _ _
    where
    fn-lemma : ∀ κ → mv-diff (into κ) == ext-glue κ
    fn-lemma = CofPushoutSection.elim reglue
      (λ _ → unit) (λ _ → idp)
      idp
      (Pushout-elim
        (λ x → merid _ (winl x))
        (λ y → merid _ (winr y))
        (↓-='-from-square ∘ λ z →
          (ap-∘ mv-diff ext-glue (glue z)
           ∙ ap (ap mv-diff) (ExtGlue.glue-β z)
           ∙ MVDiff.glue-β z)
          ∙v⊡ (lt-square (merid _ (winl (f z)))
               ⊡h rt-square (merid _ (winr (g z))))
          ⊡v∙ ! (ap-cst (south _) (glue z))))
      (↓-='-from-square ∘ λ x →
        (ap-∘ mv-diff into (cfglue _ (winl x))
         ∙ ap (ap mv-diff) (Into.glue-β (winl x)))
        ∙v⊡ connection
        ⊡v∙ ! (ExtGlue.glue-β (winl x)))
      (↓-='-from-square ∘ λ y →
        (ap-∘ mv-diff into (cfglue _ (winr y))
         ∙ ap (ap mv-diff) (Into.glue-β (winr y))
         ∙ MVDiff.glue-β (snd Z)
         ∙ ap (λ w → merid _ w ∙ ! (merid _ (winr (g (snd Z))))) wglue
         ∙ !-inv-r (merid _ (winr (g (snd Z)))))
        ∙v⊡ connection
        ⊡v∙ ! (ExtGlue.glue-β (winr y)))

{- Main results -}
module MayerVietoris (ps : ⊙Span {i} {i} {i}) where

  private
    record Results (ps : ⊙Span {i} {i} {i}) : Type (lsucc i) where
      open ⊙Span ps
      open MayerVietorisFunctions ps public
      field
        eq : Cofiber reglue ≃ Suspension (fst Z)
        ⊙eq : ⊙Cof ⊙reglue ⊙≃ ⊙Susp Z
        path : Cofiber reglue == Suspension (fst Z)
        ⊙path : ⊙Cof ⊙reglue == ⊙Susp Z
        cfcod-over : cfcod reglue == ext-glue
                     [ (λ W → fst (⊙Pushout ps) → fst W) ↓ ⊙path ]
        ext-over : ext-glue == mv-diff
                   [ (λ W → fst W → fst (⊙Susp (X ⊙∨ Y))) ↓ ⊙path ]

    results : Results ps
    results = ⊙pushout-J Results base-results ps
      where
      base-results : ∀ {A} {B} Z (f : fst Z → A) (g : fst Z → B) →
        Results (⊙span _ _ Z (f , idp) (g , idp))
      base-results Z f g = record {
        eq = eq;
        ⊙eq = ⊙eq;
        path = path;
        ⊙path = ⊙path;
        cfcod-over = cfcod-over;
        ext-over = ext-over}
        where open MayerVietorisBase Z f g

  open Results results public