{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.ImplShared.Consensus.Types.EpochIndep
open import Optics.All
open import Util.ByteString
open import Util.Encode
open import Util.Hash
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

-- This module postulates a collision-resistant cryptographic hash
-- function (we call it sha256 for concreteness, but it could be any
-- collision-resistant cryptographic hash function), and defines hash
-- functions used in (an earlier version of) LibraBFT, properties
-- about it, and how Votes and Blocks are signed.

module LibraBFT.ImplShared.Util.Crypto where
  -- Note that this is an abstraction of a hash function.  It could be any such hash function, not
  -- necessarily sha256.  We just call it sha256 for "concreteness", to remind ourselves it's
  -- modeling such a function.
  postulate -- valid assumption (hash function)
    sha256    : BitString → Hash

  -- For two values x and y, if their hashes are equal, then either there is a hash collision, or x
  -- and y are equal.
  sha256-cr : ∀{x y} → sha256 x ≡ sha256 y → Collision sha256 x y ⊎ x ≡ y
  sha256-cr {x} {y} hyp
     with x ≟BitString y
  ...| no  col  = inj₁ (col , hyp)
  ...| yes refl = inj₂ refl

  open WithCryptoHash sha256 sha256-cr

  -- We do not yet have sufficient support to model precisely the hashing used in the Haskell code,
  -- so it is better that we postulate its intended properties to ensure proofs have the desired
  -- properties available.  Note that a simpler injectivity property such as
  --
  -- hashBD-inj' : ∀ {bd1} {bd2}
  --             → hashBD bd1 ≡ hashBD bd2
  --             → NonInjective-≡ sha256
  --             ⊎ bd1 ≡L bd2
  --
  -- does *not* hold because the input to the hash function used in hashBD does *not* include all
  -- components of the BlockData being hashed.

  -- TODO-2: Similarly express other hashing functions and their intended injectivity properties where
  -- the Agda implementation does not accurately reflect the Haskell implementation.

  -- TODO-2: Enable support for the hashS function we use in the Haskell code, which hashes tuples
  -- of serializable types), and then define hashBD using this and prove that it ensures hashBD-inj.
  -- Note also the TODO below related to HashTags.

  record _BlockDataInjectivityProps_ (bd1 bd2 : BlockData) : Set where
    constructor mkBdInjProps
    field
      bdInjEpoch  : bd1 ≡L bd2 at bdEpoch
      bdInjRound  : bd1 ≡L bd2 at bdRound
      bdInjVD     : bd1 ≡L bd2 at (bdQuorumCert ∙ qcVoteData)
      bdInjLI     : bd1 ≡L bd2 at (bdQuorumCert ∙ qcSignedLedgerInfo ∙ liwsLedgerInfo)
      bdInjBTNil  : bd1 ^∙ bdBlockType ≡ NilBlock → bd2 ^∙ bdBlockType ≡ NilBlock
      bdInjBTGen  : bd1 ^∙ bdBlockType ≡ Genesis  → bd2 ^∙ bdBlockType ≡ Genesis
      bdInjBTProp : ∀ {tx}{auth} → bd1 ^∙ bdBlockType ≡ Proposal tx auth
                                 → bd1 ^∙ bdBlockType ≡ bd2 ^∙ bdBlockType
  open _BlockDataInjectivityProps_

  sameBlockData⇒≈ : ∀ {b1 b2}
                    → b1 ^∙ bId ≡ b2 ^∙ bId
                    → (b1 ^∙ bBlockData) BlockDataInjectivityProps (b2 ^∙ bBlockData)
                    → b1 ≈Block b2
  sameBlockData⇒≈ {b1} {b2} refl (mkBdInjProps refl refl refl refl nil gen prop)
     with b1 ^∙ bBlockData ∙ bdBlockType
  ...| NilBlock         rewrite nil  refl = refl
  ...| Genesis          rewrite gen  refl = refl
  ...| Proposal tx auth rewrite prop refl = refl

  BSL : Set
  BSL = List ByteString

  _≟-BSL_ : ∀ (bsl1 bsl2 : List ByteString) → Dec (bsl1 ≡ bsl2)
  _≟-BSL_ = List-≡-dec _≟ByteString_

  hashBSL = sha256 ∘ bs-concat

  postulate  -- TODO-2: implement after adding support for "HashTag" (see below)
    blockData-bsl     : BlockData → List ByteString

  hashBD : BlockData → HashValue
  hashBD = hashBSL ∘ blockData-bsl

  Injective-BlockData : Set
  Injective-BlockData = Injective-int _BlockDataInjectivityProps_ hashBSL blockData-bsl blockData-bsl

  postulate  -- TODO-1: prove it using bs-concat-inj
    hashBD-inj : Injective-BlockData

  hashBlock : Block → HashValue
  hashBlock = hashBD ∘ (_^∙ bBlockData)

  blockInfoBSList : BlockInfo → List ByteString
  blockInfoBSList (BlockInfo∙new epoch round id execStId ver mes) =
    encode epoch ∷ encode round ∷ encode id ∷ encode execStId ∷ encode ver ∷ encode mes ∷ []

  hashBI : BlockInfo → HashValue
  hashBI = sha256 ∘ bs-concat ∘ blockInfoBSList

  hashBI-inj : ∀ {bi1 bi2} → hashBI bi1 ≡ hashBI bi2 → NonInjective-≡ sha256 ⊎ bi1 ≡ bi2
  hashBI-inj {bi1} {bi2} hyp with sha256-cr hyp
  ...| inj₁ col = inj₁ (_ , col)
  ...| inj₂ res with bs-concat-inj (blockInfoBSList bi1) (blockInfoBSList bi2) res
  ...| final = inj₂ (BlockInfo-η (encode-inj (proj₁ (∷-injective final)))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective final)))))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective final)))))))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective final)))))))))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective final)))))))))))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective final))))))))))))))

  voteDataHashList : VoteData → List Hash
  voteDataHashList (VoteData∙new proposed parent) =
    hProposed ∷ hParent ∷ []
   where
    hProposed = hashBI proposed
    hParent   = hashBI parent

  hashVD : VoteData → HashValue
  hashVD = hash-concat ∘ voteDataHashList

  VoteData-≢-eid : ∀ {vd1 vd2 : VoteData}
                 → vd1 ^∙ vdProposed ∙ biEpoch ≢ vd2 ^∙ vdProposed ∙ biEpoch
                 → vd1 ≢ vd2
  VoteData-≢-eid neq = λ x → neq (cong (_^∙ vdProposed ∙ biEpoch) x)

  VoteData-hb : ∀ {vd1 vd2 : VoteData}
              → vd1 ^∙ vdProposed ∙ biEpoch ≢ vd2 ^∙ vdProposed ∙ biEpoch
              → hashVD vd1 ≡ hashVD vd2
              → NonInjective-≡ sha256
  VoteData-hb {vd1} {vd2} neq hvd≡
    with hash-concat-inj {voteDataHashList vd1} {voteDataHashList vd2} hvd≡
  ...| inj₁ hb = hb
  ...| inj₂ xxx
     with cong head xxx
  ...| yyy
     with cong tail xxx
  ...| yyy'
     with cong head (just-injective yyy')
  ...| yyy''
     with just-injective yyy | just-injective yyy''
  ...| zzz | zzz'
     with hashBI-inj {vd1 ^∙ vdProposed} {vd2 ^∙ vdProposed} zzz |
          hashBI-inj {vd1 ^∙ vdParent}   {vd2 ^∙ vdParent}   zzz'
  ...| inj₁ hb  | _         = hb
  ...| inj₂ _   | inj₁ hb   = hb
  ...| inj₂ aaa | inj₂ aaa' = ⊥-elim (VoteData-≢-eid {vd1} {vd2} neq (VoteData-η aaa aaa'))

  hashVD-inj : ∀ {vd1 vd2} → hashVD vd1 ≡ hashVD vd2 → NonInjective-≡ sha256 ⊎ vd1 ≡ vd2
  hashVD-inj {vd1} {vd2} prf
    with hash-concat-inj {voteDataHashList vd1} {voteDataHashList vd2} prf
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ vdLists≡
     with hashBI-inj (proj₁ (∷-injective vdLists≡)) | hashBI-inj (proj₁ (∷-injective (proj₂ (∷-injective vdLists≡))))
  ...| inj₁ hb    | _         = inj₁ hb
  ...| inj₂ _     | inj₁ hb   = inj₁ hb
  ...| inj₂ prop≡ | inj₂ par≡ = inj₂ (VoteData-η prop≡ par≡)

  -- The Haskell implementation includes "HashTag"s when hashing in order to ensure that it is not
  -- possible (modulo hash collisions) for the encodings of two values of different types (e.g.,
  -- Vote and Block) to yield the same bitstring and thus the same hash (and therefore potentially
  -- the same signature, where hashes are signed).  For example, the Haskell hashLI function is:
  --
  -- hashLI :: LedgerInfo -> HashValue
  -- hashLI (LedgerInfo commitInfo (HashValue consensusDataHash)) =
  --   hashS (HLI, biParts commitInfo, consensusDataHash)
  --
  -- Note the HashTag HLI, which is not yet reflected in the Agda implementation.
  -- TODO-2: include HashTags in hash functions, consistent with the Haskell code.
  --
  -- As an aside, it is not clear whether these HashTags are necessary for all of the "inner"
  -- hashes.  They are needed to ensure that, for example, a dishonest peer cannot notice that the
  -- bits signed for a Vote happen to decode to a valid Block, and therefore take a Vote signature
  -- and use it to masquerade as a Block signture.  However, the implementation does include
  -- HashTags at each level, so we should too unless and until that changes.
  hashLI : LedgerInfo → HashValue
  hashLI (LedgerInfo∙new commitInfo consensusDataHash) =
    hash-concat (hashBI commitInfo ∷ consensusDataHash ∷ [])

  hashLI-inj : ∀ {li1 li2} → hashLI li1 ≡ hashLI li2 → NonInjective-≡ sha256 ⊎ li1 ≡ li2
  hashLI-inj {LedgerInfo∙new ci1 cd1} {LedgerInfo∙new ci2 cd2} prf
     with hash-concat-inj {hashBI ci1 ∷ cd1 ∷ []} {hashBI ci2 ∷ cd2 ∷ []} prf
  ...| inj₁ hb      = inj₁ hb
  ...| inj₂ li1≡li2
     with ∷-injective li1≡li2
  ...| ci≡ , rest≡
     with ∷-injective rest≡
  ...| cdh≡ , _
     with hashBI-inj ci≡
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ cis≡
     = inj₂ (LedgerInfo-η cis≡ cdh≡)

  record Ledger2WaypointConverterInjectivityProps (l1 l2 : Ledger2WaypointConverter) : Set where
    {- TODO-2 : implement Ledger2WaypointConverterInjectivityProps
    field
      l2wcInjEpoch          : ?
      l2wcInjRootHash       : ?
      l2wcInjVersion        : ?
      --timestamp
      l2wcInjNextEpochState : ?
    -}
  postulate -- TODO-2: prove after defining Ledger2WaypointConverterInjectivityProps
    hashL2WC     : Ledger2WaypointConverter → HashValue
    hashL2WC-inj : ∀ {l1 l2}
                 → hashL2WC l1 ≡ hashL2WC l2
                 → NonInjective-≡ sha256 ⊎ Ledger2WaypointConverterInjectivityProps l1 l2

  constructLI : Vote → LedgerInfo
  constructLI v = LedgerInfo∙new (_liCommitInfo (_vLedgerInfo v)) (hashVD (_vVoteData v))

  hashVote : Vote → HashValue
  hashVote = hashLI ∘ constructLI

  hashVote-inj1 : ∀ {v1 v2} → hashVote v1 ≡ hashVote v2
                → NonInjective-≡ sha256 ⊎ _vVoteData v1 ≡ _vVoteData v2
  hashVote-inj1 {v1} {v2} hyp with hashLI-inj {constructLI v1} {constructLI v2} hyp
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ ok = hashVD-inj {_vVoteData v1} {_vVoteData v2} (cong _liConsensusDataHash ok)

  -- A vote is always signed; as seen by the 'Unit'
  -- in the definition of Signed.
  instance
    sig-Vote : WithSig Vote
    sig-Vote = record
       { Signed         = λ _ → Unit
       ; Signed-pi      = λ _ _ _ → Unit-pi
       ; isSigned?      = λ _ → yes unit
       ; signature      = λ v _ → _vSignature v
       ; signableFields = encodeH ∘ hashVote
       }

  sameSig⇒sameVoteData : ∀ {v1 v2 : Vote} {pk}
                       → WithVerSig pk v1
                       → WithVerSig pk v2
                       → v1 ^∙ vSignature ≡ v2 ^∙ vSignature
                       → NonInjective-≡ sha256 ⊎ v2 ^∙ vVoteData ≡ v1 ^∙ vVoteData
  sameSig⇒sameVoteData {v1} {v2} wvs1 wvs2 refl
     with verify-bs-inj (verified wvs1) (verified wvs2)
       -- The signable fields of the votes must be the same (we do not model signature collisions)
  ...| bs≡
       -- Therefore the LedgerInfo is the same for the new vote as for the previous vote
       = sym <⊎$> (hashVote-inj1 {v1} {v2} (sameBS⇒sameHash bs≡))

  -- Captures a proof that a vote was cast by α by recording that 'verify' returns true.
  VoteSigVerifies : PK → Vote → Set
  VoteSigVerifies pk v = T (verify (signableFields ⦃ sig-Vote ⦄ v) (_vSignature v) pk)

  Signed-pi-Blk : (b : Block)
                → (is1 is2 : (Is-just ∘ _bSignature) b)
                → is1 ≡ is2
  Signed-pi-Blk (Block∙new _ _ .(just _)) (just _) (just _) = cong just refl

  -- A Block might carry a signature
  instance
    sig-Block : WithSig Block
    sig-Block = record
       { Signed         = Is-just ∘ _bSignature
       ; Signed-pi      = Signed-pi-Blk
       ; isSigned?      = λ b → Maybe-Any-dec (λ _ → yes tt) (b ^∙ bSignature)
       ; signature      = λ { _ prf → to-witness prf }
       ; signableFields = λ b → concat (encodeH (_bId b) ∷ encode (b ^∙ bBlockData) ∷ [])
       }


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

open import Relation.Binary.PropositionalEquality using (_≡_; refl; trans; sym; subst)
open import Function.Reasoning

import Data.Empty as Empty
import Data.Maybe as Maybe
import Data.Nat as Nat
import Data.Bool as Bool
import Data.Fin as Fin
import Data.Product as Product
import Data.Vec as Vec
import Data.Vec.Relation.Unary.All as All
import Data.Fin.Properties as Finₚ

open Empty using (⊥; ⊥-elim)
open Nat using (ℕ; zero; suc)
open Fin using (Fin ; zero ; suc)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)
open Product using (_×_; Σ-syntax; ∃-syntax; _,_; proj₁; proj₂)

open import PiCalculus.Syntax
open Scoped
open import PiCalculus.Semantics
open import PiCalculus.Semantics.Properties
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem.SubjectReduction (Ω : Algebras) where
open Algebras Ω
open import PiCalculus.LinearTypeSystem Ω
open import PiCalculus.LinearTypeSystem.ContextLemmas Ω
open import PiCalculus.LinearTypeSystem.Framing Ω
open import PiCalculus.LinearTypeSystem.Weakening Ω
open import PiCalculus.LinearTypeSystem.Strengthening Ω
open import PiCalculus.LinearTypeSystem.Substitution Ω
open import PiCalculus.LinearTypeSystem.SubjectCongruence Ω

SubjectReduction : Set
SubjectReduction = {n : ℕ} {γ : PreCtx n} {idxs : Idxs n} {idx : Idx} {Γ Γ' Ξ : Ctx idxs}
                   {c : Channel n} {P Q : Scoped n}
                 → maybe (Γ' ≡ Γ) (λ i → Γ' ∋[ i ] ℓ# {idx} ▹ Γ) c
                 → P =[ c ]⇒ Q
                 → γ ； Γ'  ⊢ P ▹ Ξ
                 → γ ； Γ   ⊢ Q ▹ Ξ

private
  variable
    n : ℕ
    i j : Fin n
    idxs : Idxs n
    P Q : Scoped n

extract-ℓ# : {Γ Ξ Δ Ψ Θ : Ctx idxs} {idx idx' : Idx}
           → Γ ∋[ i ] ℓᵢ {idx} ▹ Ξ
           → Ψ ∋[ i ] ℓₒ {idx'} ▹ Θ
           → Ξ ≔ Δ ⊗ Ψ
           → ∃[ z ] (All.lookup i Γ ≔ ℓ# ∙² z)
extract-ℓ# (zero x) (zero y) (_ , s) =
  let
    ⁇ , Ξ≔ℓₒ∙⁇ , _ = ∙²-assoc (∙²-comm s) y
    _ , Γ≔[ℓᵢℓₒ]∙⁇ , [ℓᵢℓₒ]≔ℓᵢ∙ℓₒ = ∙²-assoc⁻¹ x Ξ≔ℓₒ∙⁇
    ℓ#≡ℓᵢℓₒ = ∙²-unique [ℓᵢℓₒ]≔ℓᵢ∙ℓₒ (∙-idʳ , ∙-idˡ)
  in _ , subst (λ ● → _ ≔ ● ∙² ⁇) ℓ#≡ℓᵢℓₒ Γ≔[ℓᵢℓₒ]∙⁇
extract-ℓ# (suc i) (suc o) (s , _) = extract-ℓ# i o s

-- What we have: Γ' ---ℓᵢ--> Θ ---P--> Ξ ---ℓₒ--> Ψ
-- What we need: Γ' ---ℓ#--> Γ ---P--> Ψ
align : ∀ {i : Fin n} {γ : PreCtx n} {idxs : Idxs n} {Γ' Γ Ξ Θ Ψ : Ctx idxs} {idx' idx'' idx'''}
    → Γ' ∋[ i ] ℓᵢ {idx'} ▹ Θ
    → Ξ  ∋[ i ] ℓₒ {idx''} ▹ Ψ
    → Γ' ∋[ i ] ℓ# {idx'''} ▹ Γ
    → γ ； Θ ⊢ P ▹ Ξ
    → γ ； Γ ⊢ P ▹ Ψ
align i o io ⊢P with ∋-≡Idx io | ∋-≡Idx i | ∋-≡Idx o
align i o io ⊢P | refl | refl | refl =
  let
  Δi , Γ'≔Δi∙Θ , Δi≔ℓᵢ = ∋-⊗ i
  Δo , Ξ≔Δo∙Ψ , Δo≔ℓₒ = ∋-⊗ o
  Δio , Γ'≔Δio∙Γ , Δio≔ℓ# = ∋-⊗ io
  Δ⊢P , Θ≔Δ⊢P∙Ξ = ⊢-⊗ ⊢P
  ΨΔ⊢P , Θ≔Δo∙[ΨΔ⊢P] , ΨΔ⊢P≔Ψ∙Δ⊢P = ⊗-assoc (⊗-comm Θ≔Δ⊢P∙Ξ) Ξ≔Δo∙Ψ
  ΔiΔo , Γ'≔[ΔiΔo]∙[ΨΔ⊢P] , ΔiΔo≔ℓᵢℓₒ = ⊗-assoc⁻¹ Γ'≔Δi∙Θ Θ≔Δo∙[ΨΔ⊢P]
  Δio≔Δi∙Δo = ∙²-⊗ Δio≔ℓ# Δi≔ℓᵢ Δo≔ℓₒ (∙-idʳ , ∙-idˡ)
  ΔiΔo≡Δio = ⊗-unique ΔiΔo≔ℓᵢℓₒ Δio≔Δi∙Δo
  Γ'≔Δio∙[ΨΔ⊢P] = subst (λ ● → _ ≔ ● ⊗ _) ΔiΔo≡Δio Γ'≔[ΔiΔo]∙[ΨΔ⊢P]
  ΨΔ⊢P≡Γ = ⊗-uniqueˡ (⊗-comm Γ'≔Δio∙[ΨΔ⊢P]) (⊗-comm Γ'≔Δio∙Γ)
  Γ≔Ψ∙Δ⊢P = subst (λ ● → ● ≔ _ ⊗ _) ΨΔ⊢P≡Γ ΨΔ⊢P≔Ψ∙Δ⊢P
  in ⊢-frame Θ≔Δ⊢P∙Ξ (⊗-comm Γ≔Ψ∙Δ⊢P) ⊢P

comm-≥ℓ# : {γ : PreCtx n} {Γ Δ : Ctx idxs} {c : Channel n}
      → P =[ c ]⇒ Q → γ ； Γ ⊢ P ▹ Δ → c ≡ external i → ∃[ y ] (All.lookup i Γ ≔ ℓ# ∙² y)
comm-≥ℓ# {i = i} comm (((_ , x) ⦅⦆ ⊢P) ∥ ((_ , x') ⟨ _ ⟩ ⊢Q)) refl with ⊢-⊗ ⊢P
comm-≥ℓ# {i = i} comm (((_ , x) ⦅⦆ ⊢P) ∥ ((_ , x') ⟨ _ ⟩ ⊢Q)) refl | (_ -, _) , (Ξ≔ , _) = extract-ℓ# x x' Ξ≔
comm-≥ℓ# (par P→P') (⊢P ∥ ⊢Q) refl = comm-≥ℓ# P→P' ⊢P refl
comm-≥ℓ# (res_ {c = internal} P→Q) (ν t m μ ⊢P) ()
comm-≥ℓ# (res_ {c = external zero} P→Q) (ν t m μ ⊢P) ()
comm-≥ℓ# (res_ {c = external (suc i)} P→Q) (ν t m μ ⊢P) refl = comm-≥ℓ# P→Q ⊢P refl
comm-≥ℓ# (struct P≅P' P'→Q' P'≅Q ) ⊢P refl = comm-≥ℓ# P'→Q' (subject-cong P≅P' ⊢P) refl

subject-reduction : SubjectReduction
subject-reduction Γ'⇒Γ comm (((_⦅⦆_ {P = P} (tx , x) ⊢P)) ∥ ((tx' , x') ⟨ y ⟩ ⊢Q)) with trans (sym (∋-≡Type tx)) (∋-≡Type tx')
subject-reduction Γ'⇒Γ comm (((_⦅⦆_ {P = P} (tx , x) ⊢P)) ∥ ((tx' , x') ⟨ y ⟩ ⊢Q)) | refl = ⊢P' ∥ ⊢Q
  where ⊢P' = ⊢P
            |> align (suc x) (suc x') (suc Γ'⇒Γ)
            |> ⊢-subst y
            |> ⊢-strengthen zero (subst-unused (λ ()) P)
subject-reduction Γ'⇒Γ (par P→P') (⊢P ∥ ⊢Q) = subject-reduction Γ'⇒Γ P→P' ⊢P ∥ ⊢Q
subject-reduction {idx = idx} refl (res_ {c = internal} P→Q) (ν t m μ ⊢P)
  = ν t m μ (subject-reduction {idx = idx} refl P→Q ⊢P)
subject-reduction refl (res_ {c = external zero} P→Q) (ν t m μ ⊢P)
  = let (lμ' , rμ') , (ls , rs) = comm-≥ℓ# P→Q ⊢P refl
        rs' = subst (λ ● → _ ≔ _ ∙ ●) (∙-uniqueˡ (∙-comm rs) (∙-comm ls)) rs
     in ν t m lμ' (subject-reduction (zero (ls , rs')) P→Q ⊢P)
subject-reduction Γ'⇒Γ (res_ {c = external (suc i)} P→Q) (ν t m μ ⊢P)
  = ν t m μ (subject-reduction (suc Γ'⇒Γ) P→Q ⊢P)
subject-reduction Γ'⇒Γ (struct P≅P' P'→Q' Q'≅Q) ⊢P
  = subject-cong Q'≅Q (subject-reduction Γ'⇒Γ P'→Q' (subject-cong P≅P' ⊢P))


module spaceShipSimpleVar where

open import Unit
open import Data.List.Base hiding ([])
open import Data.Bool.Base
open import Data.Integer
open import Data.Product hiding (map)
open import NativeIO

open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.WxGraphicsLib
open import StateSized.GUI.ShipBitMap
open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent
open import StateSizedIO.GUI.VariableList

VarType = ℤ

varInit : VarType
varInit = (+ 150)

onPaint : ∀{i} → VarType → DC → Rect → IO GuiLev1Interface i VarType
onPaint z dc rect      =  do (drawBitmap dc ship (z , (+ 150)) true) λ _ →
                          return z

moveSpaceShip  : ∀{i} → Frame → VarType → IO GuiLev1Interface i VarType
moveSpaceShip  fra z   =  return (z + + 20)

callRepaint    : ∀{i} → Frame → VarType → IO GuiLev1Interface i VarType
callRepaint    fra z   =  do (repaint fra) λ _ → return z

buttonHandler : ∀{i} → Frame → List (VarType  → IO GuiLev1Interface i VarType)
buttonHandler fra = moveSpaceShip fra ∷ [ callRepaint fra ]

program : ∀{i} → IOˢ GuiLev2Interface i (λ _ → Unit) []
program =  doˢ (level1C makeFrame)           λ fra →
           doˢ (level1C (makeButton fra))    λ bt →
           doˢ (level1C (addButton fra bt))  λ _ →
           doˢ (createVar varInit)           λ _ →
           doˢ (setButtonHandler bt (buttonHandler fra)) λ _ →
           doˢ (setOnPaint       fra [ onPaint  ])
           returnˢ

main : NativeIO Unit
main = start (translateLev2 program)


module Data.Strict.Primitive where

data Strict (A : Set) : Set where
  ! : A → Strict A

{-# IMPORT Data.Strict.AgdaFFI #-}
{-# COMPILED_DATA Strict Data.Strict.AgdaFFI.Strict Data.Strict.AgdaFFI.Strict #-}


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

open import HoTT

module homotopy.3x3.PushoutPushout where

-- Numbering is in row/column form
-- A span^2 is a 5 × 5 table (numbered from 0 to 4) where
-- * the even/even cells are types
-- * the odd/even and even/odd cells are functions
-- * the odd/odd cells are equalities between functions
record Span^2 {i} : Type (lsucc i) where
  constructor span^2
  field
    A₀₀ A₀₂ A₀₄ A₂₀ A₂₂ A₂₄ A₄₀ A₄₂ A₄₄ : Type i
    f₀₁ : A₀₂ → A₀₀
    f₀₃ : A₀₂ → A₀₄
    f₂₁ : A₂₂ → A₂₀
    f₂₃ : A₂₂ → A₂₄
    f₄₁ : A₄₂ → A₄₀
    f₄₃ : A₄₂ → A₄₄
    f₁₀ : A₂₀ → A₀₀
    f₃₀ : A₂₀ → A₄₀
    f₁₂ : A₂₂ → A₀₂
    f₃₂ : A₂₂ → A₄₂
    f₁₄ : A₂₄ → A₀₄
    f₃₄ : A₂₄ → A₄₄
    H₁₁ : (x : A₂₂) → f₁₀ (f₂₁ x) == f₀₁ (f₁₂ x)
    H₁₃ : (x : A₂₂) → f₀₃ (f₁₂ x) == f₁₄ (f₂₃ x)
    H₃₁ : (x : A₂₂) → f₃₀ (f₂₁ x) == f₄₁ (f₃₂ x)
    H₃₃ : (x : A₂₂) → f₄₃ (f₃₂ x) == f₃₄ (f₂₃ x)

record SquareFunc {i} : Type (lsucc i) where
  constructor square
  field
    {A B₁ B₂ C} : Type i
    f₁ : A  → B₁
    f₂ : A  → B₂
    g₁ : B₁ → C
    g₂ : B₂ → C

module _ {i} where

  square=-raw :
    {A A' : Type i} (eq-A : A == A')
    {B₁ B₁' : Type i} (eq-B₁ : B₁ == B₁')
    {B₂ B₂' : Type i} (eq-B₂ : B₂ == B₂')
    {C C' : Type i} (eq-C : C == C')
    {f₁ : A → B₁} {f₁' : A' → B₁'} (eq-f₁ : f₁ == f₁' [ (λ u → fst u → snd u) ↓ pair×= eq-A eq-B₁ ])
    {f₂ : A → B₂} {f₂' : A' → B₂'} (eq-f₂ : f₂ == f₂' [ (λ u → fst u → snd u) ↓ pair×= eq-A eq-B₂ ])
    {g₁ : B₁ → C} {g₁' : B₁' → C'} (eq-g₁ : g₁ == g₁' [ (λ u → fst u → snd u) ↓ pair×= eq-B₁ eq-C ])
    {g₂ : B₂ → C} {g₂' : B₂' → C'} (eq-g₂ : g₂ == g₂' [ (λ u → fst u → snd u) ↓ pair×= eq-B₂ eq-C ])
    → square f₁ f₂ g₁ g₂ == square f₁' f₂' g₁' g₂'
  square=-raw idp idp idp idp idp idp idp idp = idp

  square-thing :
    {A A' : Type i} (eq-A : A == A')
    {B₁ B₁' : Type i} (eq-B₁ : B₁ == B₁')
    {B₂ B₂' : Type i} (eq-B₂ : B₂ == B₂')
    {C C' : Type i} (eq-C : C == C')
    {f₁ : A → B₁} {f₁' : A' → B₁'} (eq-f₁ : f₁ == f₁' [ (λ u → fst u → snd u) ↓ pair×= eq-A eq-B₁ ])
    {f₂ : A → B₂} {f₂' : A' → B₂'} (eq-f₂ : f₂ == f₂' [ (λ u → fst u → snd u) ↓ pair×= eq-A eq-B₂ ])
    {g₁ : B₁ → C} {g₁' : B₁' → C'} (eq-g₁ : g₁ == g₁' [ (λ u → fst u → snd u) ↓ pair×= eq-B₁ eq-C ])
    {g₂ : B₂ → C} {g₂' : B₂' → C'} (eq-g₂ : g₂ == g₂' [ (λ u → fst u → snd u) ↓ pair×= eq-B₂ eq-C ])
    {a : _} {b : _}
    → a == b [ (λ u → ((x : SquareFunc.A u) → SquareFunc.g₂ u (SquareFunc.f₂ u x) == SquareFunc.g₁ u (SquareFunc.f₁ u x))) ↓ (square=-raw eq-A eq-B₂ eq-B₁ eq-C eq-f₂ eq-f₁ eq-g₂ eq-g₁) ]
    → a == b [ (λ u → ((x : SquareFunc.A u) → SquareFunc.g₁ u (SquareFunc.f₁ u x) == SquareFunc.g₂ u (SquareFunc.f₂ u x))) ↓ (square=-raw eq-A eq-B₁ eq-B₂ eq-C eq-f₁ eq-f₂ eq-g₁ eq-g₂) ]
  square-thing idp idp idp idp idp idp idp idp α = α

  span^2=-raw :
    {A₀₀ A₀₀' : Type i} (eq-A₀₀ : A₀₀ == A₀₀')
    {A₀₂ A₀₂' : Type i} (eq-A₀₂ : A₀₂ == A₀₂')
    {A₀₄ A₀₄' : Type i} (eq-A₀₄ : A₀₄ == A₀₄')
    {A₂₀ A₂₀' : Type i} (eq-A₂₀ : A₂₀ == A₂₀')
    {A₂₂ A₂₂' : Type i} (eq-A₂₂ : A₂₂ == A₂₂')
    {A₂₄ A₂₄' : Type i} (eq-A₂₄ : A₂₄ == A₂₄')
    {A₄₀ A₄₀' : Type i} (eq-A₄₀ : A₄₀ == A₄₀')
    {A₄₂ A₄₂' : Type i} (eq-A₄₂ : A₄₂ == A₄₂')
    {A₄₄ A₄₄' : Type i} (eq-A₄₄ : A₄₄ == A₄₄')
    {f₀₁ : A₀₂ → A₀₀} {f₀₁' : A₀₂' → A₀₀'} (eq-f₀₁ : f₀₁ == f₀₁' [ (λ u → fst u → snd u) ↓ pair×= eq-A₀₂ eq-A₀₀ ])
    {f₀₃ : A₀₂ → A₀₄} {f₀₃' : A₀₂' → A₀₄'} (eq-f₀₃ : f₀₃ == f₀₃' [ (λ u → fst u → snd u) ↓ pair×= eq-A₀₂ eq-A₀₄ ])
    {f₂₁ : A₂₂ → A₂₀} {f₂₁' : A₂₂' → A₂₀'} (eq-f₂₁ : f₂₁ == f₂₁' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₂ eq-A₂₀ ])
    {f₂₃ : A₂₂ → A₂₄} {f₂₃' : A₂₂' → A₂₄'} (eq-f₂₃ : f₂₃ == f₂₃' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₂ eq-A₂₄ ])
    {f₄₁ : A₄₂ → A₄₀} {f₄₁' : A₄₂' → A₄₀'} (eq-f₄₁ : f₄₁ == f₄₁' [ (λ u → fst u → snd u) ↓ pair×= eq-A₄₂ eq-A₄₀ ])
    {f₄₃ : A₄₂ → A₄₄} {f₄₃' : A₄₂' → A₄₄'} (eq-f₄₃ : f₄₃ == f₄₃' [ (λ u → fst u → snd u) ↓ pair×= eq-A₄₂ eq-A₄₄ ])
    {f₁₀ : A₂₀ → A₀₀} {f₁₀' : A₂₀' → A₀₀'} (eq-f₁₀ : f₁₀ == f₁₀' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₀ eq-A₀₀ ])
    {f₃₀ : A₂₀ → A₄₀} {f₃₀' : A₂₀' → A₄₀'} (eq-f₃₀ : f₃₀ == f₃₀' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₀ eq-A₄₀ ])
    {f₁₂ : A₂₂ → A₀₂} {f₁₂' : A₂₂' → A₀₂'} (eq-f₁₂ : f₁₂ == f₁₂' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₂ eq-A₀₂ ])
    {f₃₂ : A₂₂ → A₄₂} {f₃₂' : A₂₂' → A₄₂'} (eq-f₃₂ : f₃₂ == f₃₂' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₂ eq-A₄₂ ])
    {f₁₄ : A₂₄ → A₀₄} {f₁₄' : A₂₄' → A₀₄'} (eq-f₁₄ : f₁₄ == f₁₄' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₄ eq-A₀₄ ])
    {f₃₄ : A₂₄ → A₄₄} {f₃₄' : A₂₄' → A₄₄'} (eq-f₃₄ : f₃₄ == f₃₄' [ (λ u → fst u → snd u) ↓ pair×= eq-A₂₄ eq-A₄₄ ])
    {H₁₁ : (x : A₂₂) → f₁₀ (f₂₁ x) == f₀₁ (f₁₂ x)} {H₁₁' : (x : A₂₂') → f₁₀' (f₂₁' x) == f₀₁' (f₁₂' x)}
    (eq-H₁₁ : H₁₁ == H₁₁' [ (λ u → ((x : SquareFunc.A u) → SquareFunc.g₁ u (SquareFunc.f₁ u x) == SquareFunc.g₂ u (SquareFunc.f₂ u x)))
                          ↓ square=-raw eq-A₂₂ eq-A₂₀ eq-A₀₂ eq-A₀₀ eq-f₂₁ eq-f₁₂ eq-f₁₀ eq-f₀₁ ])
    {H₁₃ : (x : A₂₂) → f₀₃ (f₁₂ x) == f₁₄ (f₂₃ x)} {H₁₃' : (x : A₂₂') → f₀₃' (f₁₂' x) == f₁₄' (f₂₃' x)}
    (eq-H₁₃ : H₁₃ == H₁₃' [ (λ u → ((x : SquareFunc.A u) → SquareFunc.g₁ u (SquareFunc.f₁ u x) == SquareFunc.g₂ u (SquareFunc.f₂ u x)))
                          ↓ square=-raw eq-A₂₂ eq-A₀₂ eq-A₂₄ eq-A₀₄ eq-f₁₂ eq-f₂₃ eq-f₀₃ eq-f₁₄ ])
    {H₃₁ : (x : A₂₂) → f₃₀ (f₂₁ x) == f₄₁ (f₃₂ x)} {H₃₁' : (x : A₂₂') → f₃₀' (f₂₁' x) == f₄₁' (f₃₂' x)}
    (eq-H₃₁ : H₃₁ == H₃₁' [ (λ u → ((x : SquareFunc.A u) → SquareFunc.g₁ u (SquareFunc.f₁ u x) == SquareFunc.g₂ u (SquareFunc.f₂ u x)))
                          ↓ square=-raw eq-A₂₂ eq-A₂₀ eq-A₄₂ eq-A₄₀ eq-f₂₁ eq-f₃₂ eq-f₃₀ eq-f₄₁ ])
    {H₃₃ : (x : A₂₂) → f₄₃ (f₃₂ x) == f₃₄ (f₂₃ x)} {H₃₃' : (x : A₂₂') → f₄₃' (f₃₂' x) == f₃₄' (f₂₃' x)}
    (eq-H₃₃ : H₃₃ == H₃₃' [ (λ u → ((x : SquareFunc.A u) → SquareFunc.g₁ u (SquareFunc.f₁ u x) == SquareFunc.g₂ u (SquareFunc.f₂ u x)))
                          ↓ square=-raw eq-A₂₂ eq-A₄₂ eq-A₂₄ eq-A₄₄ eq-f₃₂ eq-f₂₃ eq-f₄₃ eq-f₃₄ ])
     → span^2 A₀₀  A₀₂  A₀₄  A₂₀  A₂₂  A₂₄  A₄₀  A₄₂  A₄₄  f₀₁  f₀₃  f₂₁  f₂₃  f₄₁  f₄₃  f₁₀  f₃₀  f₁₂  f₃₂  f₁₄  f₃₄  H₁₁  H₁₃  H₃₁  H₃₃
    == span^2 A₀₀' A₀₂' A₀₄' A₂₀' A₂₂' A₂₄' A₄₀' A₄₂' A₄₄' f₀₁' f₀₃' f₂₁' f₂₃' f₄₁' f₄₃' f₁₀' f₃₀' f₁₂' f₃₂' f₁₄' f₃₄' H₁₁' H₁₃' H₃₁' H₃₃'
  span^2=-raw idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp idp = idp

module M {i} (d : Span^2 {i}) where

  open Span^2 d

  A₀∙ : Type i
  A₀∙ = Pushout (span A₀₀ A₀₄ A₀₂ f₀₁ f₀₃)

  A₂∙ : Type i
  A₂∙ = Pushout (span A₂₀ A₂₄ A₂₂ f₂₁ f₂₃)

  A₄∙ : Type i
  A₄∙ = Pushout (span A₄₀ A₄₄ A₄₂ f₄₁ f₄₃)

  module F₁∙ = PushoutRec {D = A₀∙}
                          (left ∘ f₁₀) (right ∘ f₁₄)
                          (λ c → ap left (H₁₁ c)
                                 ∙ glue (f₁₂ c)
                                 ∙ ap right (H₁₃ c))

  f₁∙ : A₂∙ → A₀∙
  f₁∙ = F₁∙.f

  module F₃∙ = PushoutRec {D = A₄∙}
                          (left ∘ f₃₀) (right ∘ f₃₄)
                          (λ c → ap left (H₃₁ c)
                                 ∙ glue (f₃₂ c)
                                 ∙ ap right (H₃₃ c))

  f₃∙ : A₂∙ → A₄∙
  f₃∙ = F₃∙.f

  -- Span obtained after taking horizontal pushouts
  v-h-span : Span
  v-h-span = span A₀∙ A₄∙ A₂∙ f₁∙ f₃∙

  Pushout^2 : Type i
  Pushout^2 = Pushout v-h-span

  {-
  Definition of [f₁∙] and [f₃∙] in ∞TT:

  f₁∙ : A₂∙ → A₀∙
  f₁∙ (left a) = left (f₁₀ a)
  f₁∙ (right c) = right (f₁₄ c)
  ap f₁∙ (glue b) = ap left (H₁₁ c) ∙ glue (f₁₂ c) ∙ ap right (H₁₃ c)

  f₃∙ : A₂∙ → A₄∙
  f₃∙ (left a) = left (f₃₀ a)
  f₃∙ (right c) = right (f₃₄ c)
  ap f₃∙ (glue b) = ap left (H₃₁ c) ∙ glue (f₃₂ c) ∙ ap right (H₃₃ c)
  -}


open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong; cong₂)
open import Data.Nat using (ℕ; zero; suc; _≤_; z≤n; s≤s)
open import Data.Nat.Properties using (≤-total)
open import Data.Fin using (Fin; zero; suc)
open import Data.Product using (∃; ∃-syntax; _×_; _,_)
open import Data.Sum using ([_,_])

open import DeBruijn
open import Substitution using (rename-subst-commute; subst-commute; extensionality)
open import Beta
open import BetaSubstitutivity using (sub-betas)
open import Takahashi

infix 8 _*⁽_⁾

_*⁽_⁾ : ∀ {n} → Term n → ℕ → Term n
M *⁽ zero ⁾  = M
M *⁽ suc k ⁾ = (M *) *⁽ k ⁾

data _—↠⁽_⁾_ : ∀ {n} → Term n → ℕ → Term n → Set where

  _∎ : ∀ {n} (M : Term n)
      --------------
    → M —↠⁽ zero ⁾ M

  _—→⁽⁾⟨_⟩_ : ∀ {n} {N L : Term n} {k : ℕ} (M : Term n)
    → M —→ L
    → L —↠⁽ k ⁾ N
      ---------------
    → M —↠⁽ suc k ⁾ N

lemma3-2 : ∀ {n} {M : Term n}
  → M —↠ M *
lemma3-2 {M = # x}       = # x ∎
lemma3-2 {M = ƛ _}       = —↠-cong-ƛ lemma3-2
lemma3-2 {M = # _ · _}   = —↠-congᵣ           lemma3-2
lemma3-2 {M = _ · _ · _} = —↠-cong   lemma3-2 lemma3-2
lemma3-2 {M = (ƛ M) · N} = (ƛ M) · N —→⟨ —→-β ⟩ sub-betas {M = M} lemma3-2 lemma3-2

lemma3-3 : ∀ {n} {M N : Term n}
  → M —→ N
    --------
  → N —↠ M *
lemma3-3 {M = # _} ()
lemma3-3 {M = ƛ M}         (—→-ƛ M—→M′)  = —↠-cong-ƛ (lemma3-3 M—→M′)
lemma3-3 {M = # _     · N} (—→-ξᵣ N—→N′) = —↠-congᵣ                 (lemma3-3 N—→N′)
lemma3-3 {M = _ · _   · N} (—→-ξᵣ N—→N′) = —↠-cong   lemma3-2       (lemma3-3 N—→N′)
lemma3-3 {M = M₁ · M₂ · _} (—→-ξₗ M—↠M′) = —↠-cong  (lemma3-3 M—↠M′) lemma3-2
lemma3-3 {M = (ƛ M)   · N}  —→-β         = sub-betas {M = M} lemma3-2 lemma3-2
lemma3-3 {M = (ƛ M)   · N} (—→-ξᵣ       {N′ = N′} N—→N′)  = (ƛ M ) · N′ —→⟨ —→-β ⟩ sub-betas {M = M} lemma3-2 (lemma3-3 N—→N′)
lemma3-3 {M = (ƛ M)   · N} (—→-ξₗ (—→-ƛ {M′ = M′} M—→M′)) = (ƛ M′) · N  —→⟨ —→-β ⟩ sub-betas {N = N} (lemma3-3 M—→M′) lemma3-2

_*ˢ : ∀ {n m} → Subst n m → Subst n m
σ *ˢ = λ x → (σ x) *

rename-* : ∀ {n m} (ρ : Rename n m) (M : Term n)
  → rename ρ (M *) ≡ (rename ρ M) *
rename-* ρ (# _)         = refl
rename-* ρ (ƛ M)         = cong ƛ_ (rename-* (ext ρ) M)
rename-* ρ (# _     · N) = cong₂ _·_ refl                   (rename-* ρ N)
rename-* ρ (M₁ · M₂ · N) = cong₂ _·_ (rename-* ρ (M₁ · M₂)) (rename-* ρ N)
rename-* ρ ((ƛ M)   · N) rewrite sym (rename-subst-commute {N = M *}{M = N *}{ρ = ρ})
                               | rename-* (ext ρ) M
                               | rename-* ρ N
                               = refl

exts-ts-commute : ∀ {n m} (σ : Subst n m)
  → exts (σ *ˢ) ≡ (exts σ) *ˢ
exts-ts-commute {n} σ = extensionality exts-ts-commute′
  where
    exts-ts-commute′ : (x : Fin (suc n))
      → (exts (σ *ˢ)) x ≡ ((exts σ) *ˢ) x
    exts-ts-commute′ zero    = refl
    exts-ts-commute′ (suc x) = rename-* suc (σ x)

app-*-join : ∀ {n} (M N : Term n)
  → M * · N * —↠ (M · N) *
app-*-join (# x)     N = # x · N * ∎
app-*-join (ƛ M)     N = (ƛ M *) · N * —→⟨ —→-β ⟩ subst (subst-zero (N *)) (M *) ∎
app-*-join (M₁ · M₂) N = (M₁ · M₂) * · N * ∎

subst-ts : ∀ {n m} (σ : Subst n m) (M : Term n)
  → subst (σ *ˢ) (M *) —↠ (subst σ M) *
subst-ts σ (# x) = σ x * ∎
subst-ts σ (ƛ M) rewrite exts-ts-commute σ = —↠-cong-ƛ (subst-ts (exts σ) M)
subst-ts σ (# x · N) = —↠-trans (—↠-congᵣ (subst-ts σ N))
                                (app-*-join (σ x) (subst σ N))
subst-ts σ (M₁ · M₂ · N) = —↠-cong (subst-ts σ (M₁ · M₂)) (subst-ts σ N)
subst-ts σ ((ƛ M) · N) rewrite sym (subst-commute {N = M *}{M = N *}{σ = σ *ˢ})
                             | exts-ts-commute σ
                             = sub-betas (subst-ts (exts σ) M) (subst-ts σ N)

subst-zero-ts : ∀ {n} {N : Term n}
  → subst-zero (N *) ≡ (subst-zero N) *ˢ
subst-zero-ts = extensionality (λ { zero → refl ; (suc x) → refl })

lemma3-4 : ∀ {n} (M : Term (suc n)) (N : Term n)
  → M * [ N * ] —↠ (M [ N ]) *
lemma3-4 M N rewrite subst-zero-ts {N = N} = subst-ts (subst-zero N) M

lemma3-5 : ∀ {n} {M N : Term n}
  → M   —→ N
    ----------
  → M * —↠ N *
lemma3-5 {M = # x} ()
lemma3-5 {M = ƛ M}         (—→-ƛ  M—→M′)  = —↠-cong-ƛ (lemma3-5 M—→M′)
lemma3-5 {M = # _     · N} (—→-ξᵣ M₂—→M′) = —↠-congᵣ  (lemma3-5 M₂—→M′)
lemma3-5 {M = (ƛ M)   · N}  —→-β                = lemma3-4 M N
lemma3-5 {M = (ƛ M)   · N} (—→-ξₗ (—→-ƛ M—→M′)) = sub-betas (lemma3-5 M—→M′) (N * ∎)
lemma3-5 {M = (ƛ M)   · N} (—→-ξᵣ N—→N′)        = sub-betas (M * ∎) (lemma3-5 N—→N′)
lemma3-5 {M = M₁ · M₂ · _} (—→-ξᵣ N—→N′)                         = —↠-congᵣ (lemma3-5 N—→N′)
lemma3-5 {M = M₁ · M₂ · _} (—→-ξₗ {M′ = # x}       M₁M₂—→#x)     = —↠-congₗ (lemma3-5 M₁M₂—→#x)
lemma3-5 {M = M₁ · M₂ · _} (—→-ξₗ {M′ = M′₁ · M′₂} M₁M₂—→M′₁M′₂) = —↠-congₗ (lemma3-5 M₁M₂—→M′₁M′₂)
lemma3-5 {M = M₁ · M₂ · N} (—→-ξₗ {M′ = ƛ M′}      M₁M₂—→ƛM′)    =
  —↠-trans (—↠-congₗ (lemma3-5 M₁M₂—→ƛM′))
           ((ƛ M′ *) · N * —→⟨ —→-β ⟩ subst (subst-zero (N *)) (M′ *) ∎)

corollary3-6 : ∀ {n} {M N : Term n}
  → M   —↠ N
    ----------
  → M * —↠ N *
corollary3-6 (M ∎) = M * ∎
corollary3-6 (M —→⟨ M—→L ⟩ L—↠N) = —↠-trans (lemma3-5 M—→L) (corollary3-6 L—↠N)

corollary3-7 : ∀ {n} {M N : Term n} (m : ℕ)
  → M        —↠ N
    --------------------
  → M *⁽ m ⁾ —↠ N *⁽ m ⁾
corollary3-7 zero    M—↠N = M—↠N
corollary3-7 (suc m) M—↠N = corollary3-7 m (corollary3-6 M—↠N)

theorem3-8 : ∀ {n} {M N : Term n} {m : ℕ}
  → M —↠⁽ m ⁾ N
    -------------
  → N —↠ M *⁽ m ⁾
theorem3-8 {m = zero}  (M ∎) = M ∎
theorem3-8 {m = suc m} (M —→⁽⁾⟨ M—→L ⟩ L—↠ᵐN) =
  —↠-trans (theorem3-8 L—↠ᵐN) (corollary3-7 m (lemma3-3 M—→L))

unnamed-named : ∀ {n} {M N : Term n}
  →         M —↠      N
    --------------------
  → ∃[ m ] (M —↠⁽ m ⁾ N)
unnamed-named (M ∎) = zero , (M ∎)
unnamed-named (M —→⟨ M—→L ⟩ L—↠N) with unnamed-named L—↠N
... | m′ , L—↠ᵐ′N = suc m′ , (M —→⁽⁾⟨ M—→L ⟩ L—↠ᵐ′N)

lift-* : ∀ {n} (M : Term n) (m : ℕ)
  → M —↠ M *⁽ m ⁾
lift-* M zero    = M ∎
lift-* M (suc m) = —↠-trans lemma3-2 (lift-* (M *) m)

complete-* : ∀ {k} (M : Term k) {n m : ℕ}
  → n ≤ m
    --------------------
  → M *⁽ n ⁾ —↠ M *⁽ m ⁾
complete-* M {m = m} z≤n = lift-* M m
complete-* M (s≤s k) = complete-* (M *) k

theorem3-9 : ∀ {n} {M A B : Term n}
  →         M —↠ A → M —↠ B
    ------------------------
  → ∃[ N ] (A —↠ N × B —↠ N)
theorem3-9 {M = M} M—↠A M—↠B =
    let n , M—↠ⁿA = unnamed-named M—↠A
        m , M—↠ᵐB = unnamed-named M—↠B
        A—↠M*ⁿ = theorem3-8 M—↠ⁿA
        B—↠M*ᵐ = theorem3-8 M—↠ᵐB
     in [ (λ n≤m →
            let M*ⁿ—↠M*ᵐ : M *⁽ n ⁾ —↠ M *⁽ m ⁾
                M*ⁿ—↠M*ᵐ = complete-* M n≤m
             in M *⁽ m ⁾ , —↠-trans A—↠M*ⁿ M*ⁿ—↠M*ᵐ , B—↠M*ᵐ)
        , (λ m≤n →
            let M*ᵐ—↠M*ⁿ : M *⁽ m ⁾ —↠ M *⁽ n ⁾
                M*ᵐ—↠M*ⁿ = complete-* M m≤n
             in M *⁽ n ⁾ , A—↠M*ⁿ , —↠-trans B—↠M*ᵐ M*ᵐ—↠M*ⁿ)
        ] (≤-total n m)


------------------------------------------------------------------------
-- Nested applications of the defined function can be handled
------------------------------------------------------------------------

module Nested where

open import Codata.Musical.Notation
open import Codata.Musical.Stream
open import Function
import Relation.Binary.PropositionalEquality as P

------------------------------------------------------------------------
-- A definition of φ (x ∷ xs) = x ∷ φ (φ xs)

module φ where

  infixr 5 _∷_

  data StreamP (A : Set) : Set where
    _∷_ : (x : A) (xs : ∞ (StreamP A)) → StreamP A
    φP  : (xs : StreamP A) → StreamP A

  data StreamW (A : Set) : Set where
    _∷_ : (x : A) (xs : StreamP A) → StreamW A

  φW  : {A : Set} → StreamW A → StreamW A
  φW (x ∷ xs) = x ∷ φP (φP xs)

  whnf : {A : Set} → StreamP A → StreamW A
  whnf (x ∷ xs)   = x ∷ ♭ xs
  whnf (φP xs)    = φW (whnf xs)

  mutual

    ⟦_⟧W : {A : Set} → StreamW A → Stream A
    ⟦ x ∷ xs ⟧W = x ∷ ♯ ⟦ xs ⟧P

    ⟦_⟧P : {A : Set} → StreamP A → Stream A
    ⟦ xs ⟧P = ⟦ whnf xs ⟧W

  ⌈_⌉ : {A : Set} → Stream A → StreamP A
  ⌈ x ∷ xs ⌉ = x ∷ ♯ ⌈ ♭ xs ⌉

  φ : {A : Set} → Stream A → Stream A
  φ xs = ⟦ φP ⌈ xs ⌉ ⟧P

open φ using (⟦_⟧P; ⟦_⟧W; φP; φW; φ; _∷_; ⌈_⌉)

------------------------------------------------------------------------
-- An equality proof language

module Equality where

  φ-rhs : {A : Set} → (Stream A → Stream A) → Stream A → Stream A
  φ-rhs φ (x ∷ xs) = x ∷ ♯ φ (φ (♭ xs))

  SatisfiesEquation : {A : Set} → (Stream A → Stream A) → Set
  SatisfiesEquation φ = ∀ xs → φ xs ≈ φ-rhs φ xs

  infixr 5 _∷_
  infix  4 _≈P_ _≈W_
  infix  3 _∎
  infixr 2 _≈⟨_⟩_

  data _≈P_ {A : Set} : Stream A → Stream A → Set where
    _∷_     : ∀ (x : A) {xs ys}
              (xs≈ys : ∞ (♭ xs ≈P ♭ ys)) → x ∷ xs ≈P x ∷ ys
    _≈⟨_⟩_  : ∀ (xs : Stream A) {ys zs}
              (xs≈ys : xs ≈P ys) (ys≈zs : ys ≈P zs) → xs ≈P zs
    _∎      : (xs : Stream A) → xs ≈P xs
    sym     : ∀ {xs ys} (xs≈ys : xs ≈P ys) → ys ≈P xs
    φP-cong : (xs ys : φ.StreamP A) (xs≈ys : ⟦ xs ⟧P ≈P ⟦ ys ⟧P) →
              ⟦ φP xs ⟧P ≈P ⟦ φP ys ⟧P
    lemma   : (φ₁ φ₂ : Stream A → Stream A)
              (s₁ : SatisfiesEquation φ₁) (s₂ : SatisfiesEquation φ₂) →
              ∀ {xs ys} (xs≈ys : xs ≈P ys) → φ-rhs φ₁ xs ≈P φ-rhs φ₂ ys

  -- Completeness.

  completeP : {A : Set} {xs ys : Stream A} → xs ≈ ys → xs ≈P ys
  completeP (P.refl ∷ xs≈ys) = _ ∷ ♯ completeP (♭ xs≈ys)

  -- Weak head normal forms.

  data _≈W_ {A : Set} : Stream A → Stream A → Set where
    _∷_ : ∀ x {xs ys} (xs≈ys : ♭ xs ≈P ♭ ys) → x ∷ xs ≈W x ∷ ys

  transW : {A : Set} {xs ys zs : Stream A} →
           xs ≈W ys → ys ≈W zs → xs ≈W zs
  transW (x ∷ xs≈ys) (.x ∷ ys≈zs) = x ∷ (_ ≈⟨ xs≈ys ⟩ ys≈zs)

  reflW : {A : Set} (xs : Stream A) → xs ≈W xs
  reflW (x ∷ xs) = x ∷ (♭ xs ∎)

  symW : {A : Set} {xs ys : Stream A} → xs ≈W ys → ys ≈W xs
  symW (x ∷ xs≈ys) = x ∷ sym xs≈ys

  φW-cong : {A : Set} (xs ys : φ.StreamW A) →
            ⟦ xs ⟧W ≈W ⟦ ys ⟧W → ⟦ φW xs ⟧W ≈W ⟦ φW ys ⟧W
  φW-cong (.x ∷ xs) (.x ∷ ys) (x ∷ xs≈ys) =
    x ∷ φP-cong (φP xs) (φP ys) (φP-cong xs ys xs≈ys)

  lemmaW : {A : Set} (φ₁ φ₂ : Stream A → Stream A)
           (s₁ : SatisfiesEquation φ₁) (s₂ : SatisfiesEquation φ₂) →
           ∀ {xs ys} → xs ≈W ys → φ-rhs φ₁ xs ≈W φ-rhs φ₂ ys
  lemmaW φ₁ φ₂ s₁ s₂ {.x ∷ xs} {.x ∷ ys} (x ∷ xs≈ys) = x ∷ (
    φ₁ (φ₁ (♭ xs))        ≈⟨ completeP $ s₁ (φ₁ (♭ xs)) ⟩
    φ-rhs φ₁ (φ₁ (♭ xs))  ≈⟨ lemma φ₁ φ₂ s₁ s₂ (
      φ₁ (♭ xs)                ≈⟨ completeP $ s₁ (♭ xs) ⟩
      φ-rhs φ₁ (♭ xs)          ≈⟨ lemma φ₁ φ₂ s₁ s₂ xs≈ys ⟩
      φ-rhs φ₂ (♭ ys)          ≈⟨ sym $ completeP $ s₂ (♭ ys) ⟩
      φ₂ (♭ ys)                ∎) ⟩
    φ-rhs φ₂ (φ₂ (♭ ys))  ≈⟨ sym $ completeP $ s₂ (φ₂ (♭ ys)) ⟩
    φ₂ (φ₂ (♭ ys))        ∎)

  whnf : {A : Set} {xs ys : Stream A} → xs ≈P ys → xs ≈W ys
  whnf (x ∷ xs≈ys)               = x ∷ ♭ xs≈ys
  whnf (xs ≈⟨ xs≈ys ⟩ ys≈zs)     = transW (whnf xs≈ys) (whnf ys≈zs)
  whnf (xs ∎)                    = reflW xs
  whnf (sym xs≈ys)               = symW (whnf xs≈ys)
  whnf (lemma φ₁ φ₂ s₁ s₂ xs≈ys) = lemmaW φ₁ φ₂ s₁ s₂ (whnf xs≈ys)
  whnf (φP-cong xs ys xs≈ys)     =
    φW-cong (φ.whnf xs) (φ.whnf ys) (whnf xs≈ys)

  -- Soundness.

  mutual

    soundW : {A : Set} {xs ys : Stream A} → xs ≈W ys → xs ≈ ys
    soundW (x ∷ xs≈ys) = P.refl ∷ ♯ soundP xs≈ys

    soundP : {A : Set} {xs ys : Stream A} → xs ≈P ys → xs ≈ ys
    soundP xs≈ys = soundW (whnf xs≈ys)

open Equality
  using (_≈P_; _∷_; _≈⟨_⟩_; _∎; sym; φP-cong; φ-rhs; SatisfiesEquation)

------------------------------------------------------------------------
-- Correctness

module Correctness where

  -- Uniqueness of solutions for φ's defining equation.

  φ-unique : {A : Set} (φ₁ φ₂ : Stream A → Stream A) →
             SatisfiesEquation φ₁ → SatisfiesEquation φ₂ →
             ∀ xs → φ₁ xs ≈P φ₂ xs
  φ-unique φ₁ φ₂ hyp₁ hyp₂ xs =
    φ₁ xs        ≈⟨ Equality.completeP (hyp₁ xs) ⟩
    φ-rhs φ₁ xs  ≈⟨ Equality.lemma φ₁ φ₂ hyp₁ hyp₂ (xs ∎) ⟩
    φ-rhs φ₂ xs  ≈⟨ sym (Equality.completeP (hyp₂ xs)) ⟩
    φ₂ xs        ∎

  -- The remainder of this module establishes the existence of a
  -- solution.

  ⟦⌈_⌉⟧P : {A : Set} (xs : Stream A) → ⟦ ⌈ xs ⌉ ⟧P ≈P xs
  ⟦⌈ x ∷ xs ⌉⟧P = x ∷ ♯ ⟦⌈ ♭ xs ⌉⟧P

  φ-cong : {A : Set} (xs ys : Stream A) → xs ≈P ys → φ xs ≈P φ ys
  φ-cong xs ys xs≈ys =
    φ xs            ≈⟨ φ xs ∎ ⟩
    ⟦ φP ⌈ xs ⌉ ⟧P  ≈⟨ φP-cong ⌈ xs ⌉ ⌈ ys ⌉ lemma ⟩
    ⟦ φP ⌈ ys ⌉ ⟧P  ≈⟨ φ ys ∎ ⟩
    φ ys  ∎
    where
    lemma =
      ⟦ ⌈ xs ⌉ ⟧P  ≈⟨ ⟦⌈ xs ⌉⟧P ⟩
      xs           ≈⟨ xs≈ys ⟩
      ys           ≈⟨ sym ⟦⌈ ys ⌉⟧P ⟩
      ⟦ ⌈ ys ⌉ ⟧P  ∎

  -- ♯′ provides a workaround for Agda's strange definitional
  -- equality.

  infix 10 ♯′_

  ♯′_ : {A : Set} → A → ∞ A
  ♯′ x = ♯ x

  φW-hom : {A : Set} (xs : φ.StreamW A) →
           ⟦ φW xs ⟧W ≈P head ⟦ xs ⟧W ∷ ♯′ φ (φ (tail ⟦ xs ⟧W))
  φW-hom (x ∷ xs) = x ∷ ♯ (
    ⟦ φP (φP xs) ⟧P                  ≈⟨ φP-cong (φP xs) (φP ⌈ ⟦ xs ⟧P ⌉) $
                                                φP-cong xs (⌈ ⟦ xs ⟧P ⌉)
                                                        (sym ⟦⌈ ⟦ xs ⟧P ⌉⟧P) ⟩
    ⟦ φP (φP ⌈ ⟦ xs ⟧P ⌉) ⟧P         ≈⟨ φP-cong (φP ⌈ ⟦ xs ⟧P ⌉)
                                                ⌈ ⟦ φP ⌈ ⟦ xs ⟧P ⌉ ⟧P ⌉
                                                (sym ⟦⌈ ⟦ φP ⌈ ⟦ xs ⟧P ⌉ ⟧P ⌉⟧P) ⟩
    ⟦ φP ⌈ ⟦ φP ⌈ ⟦ xs ⟧P ⌉ ⟧P ⌉ ⟧P  ∎)

  φ-hom : {A : Set} (xs : φ.StreamP A) →
          ⟦ φP xs ⟧P ≈P head ⟦ xs ⟧P ∷ ♯′ φ (φ (tail ⟦ xs ⟧P))
  φ-hom xs = φW-hom (φ.whnf xs)

  φ-correct : {A : Set} (xs : Stream A) →
              φ xs ≈P φ-rhs φ xs
  φ-correct (x ∷ xs) =
    φ (x ∷ xs)                  ≈⟨ φ (x ∷ xs) ∎ ⟩
    ⟦ φP ⌈ x ∷ xs ⌉ ⟧P          ≈⟨ φ-hom ⌈ x ∷ xs ⌉ ⟩
    x ∷ ♯′ φ (φ ⟦ ⌈ ♭ xs ⌉ ⟧P)  ≈⟨ x ∷ ♯ φ-cong (φ ⟦ ⌈ ♭ xs ⌉ ⟧P) (φ (♭ xs))
                                                (φ-cong (⟦ ⌈ ♭ xs ⌉ ⟧P) (♭ xs) ⟦⌈ ♭ xs ⌉⟧P) ⟩
    φ-rhs φ (x ∷ xs)            ∎


module Issue4835.ModB where

data B : Set where
  b : B -> B


{-# OPTIONS --postfix-projections #-}

module UnSizedIO.Base where

open import Data.Maybe.Base
open import Data.Sum renaming (inj₁ to left; inj₂ to right; [_,_]′ to either)
open import Function

open import NativeIO

record IOInterface : Set₁ where
  field
    Command   : Set
    Response : (m : Command) → Set
open IOInterface public

module _ (I : IOInterface) (let C = Command I) (let R = Response I) (A : Set)
  where

  mutual
    record IO : Set where
      coinductive
      constructor delay
      field
        force : IO'

    data IO' : Set where
      exec'      : (c : C) (f : R c → IO) → IO'
      return' : (a : A) → IO'

open IO public

module _ {I : IOInterface} (let C = Command I) (let R = Response I)
      where
  return : ∀{A} (a : A) → IO I A
  return a .force = return' a

  exec : ∀{A} (c : C) (f : R c → IO I A) → IO I A
  exec c f .force = exec' c f

  exec1 :  (c : C) → IO I (R c)
  exec1 c = exec c return

  infixl 2 _>>=_ _>>='_ _>>_

  mutual
    _>>='_ : ∀{A B} (m : IO' I A) (k : A → IO I B) → IO' I B
    exec' c f    >>=' k = exec' c λ x → f x >>= k
    return' a >>=' k = force (k a)

    _>>=_ : ∀{A B} (m : IO I A) (k : A → IO I B) → IO I B
    force (m >>= k) = force m >>=' k

  _>>_ : ∀{B} (m : IO I Unit) (k : IO I B) → IO I B
  m >> k = m >>= λ _ → k

module _ {I : IOInterface} (let C = Command I) (let R = Response I)
      where
  {-# NON_TERMINATING #-}
  translateIO : ∀ {A}
    →  (translateLocal : (c : C) → NativeIO (R c))
    →  IO I A
    →  NativeIO A
  translateIO translateLocal m = case (m .force) of
    λ{ (exec' c f)    → (translateLocal c) native>>= λ r →
         translateIO translateLocal (f r)
     ; (return' a) → nativeReturn a
     }

-- Recursion

-- trampoline provides a generic form of loop (generalizing while/repeat).
-- Starting at state s : S, step function f is iterated until it returns
-- a result in A.

module _ (I : IOInterface)(let C = Command I) (let R = Response I)
      where
  data IO+ (A : Set) : Set where
      exec' : (c : C) (f : R c → IO I A) → IO+ A

module _ {I : IOInterface}(let C = Command I) (let R = Response I)
      where
  fromIO+' : ∀{A} → IO+ I A → IO' I A
  fromIO+' (exec' c f) = exec' c f

  fromIO+ : ∀{A} → IO+ I A → IO I A
  fromIO+ (exec' c f) .force = exec' c f

  _>>=+'_ : ∀{A B} (m : IO+ I A) (k : A → IO I B) → IO' I B
  exec' c f >>=+' k = exec' c λ x → f x >>= k

  _>>=+_ : ∀{A B} (m : IO+ I A) (k : A → IO I B) → IO I B
  force (m >>=+ k) = m >>=+' k

  mutual

    _>>+_ : ∀{A B} (m : IO I (A ⊎ B)) (k : A → IO I B) → IO I B
    force (m >>+ k) = force m >>+' k

    _>>+'_ : ∀{A B} (m : IO' I (A ⊎ B)) (k : A → IO I B) → IO' I B
    exec' c f            >>+' k = exec' c λ x → f x >>+ k
    return' (left  a) >>+' k = force (k a)
    return' (right b) >>+' k = return' b

   -- loop

  {-# TERMINATING #-}
  trampoline : ∀{A S} (f : S → IO+ I (S ⊎ A)) (s : S) → IO I A
  force (trampoline f s) = case (f s) of
    \{ (exec' c k) → exec' c λ r → k r >>+ trampoline f }

  -- simple infinite loop

  {-# TERMINATING #-}
  forever : ∀{A B} → IO+ I A → IO I B
  force (forever (exec' c f)) = exec' c λ r → f r >>= λ _ → forever (exec' c f)

  whenJust : {A : Set} → Maybe A → (A → IO I Unit) → IO I Unit
  whenJust nothing  k = return _
  whenJust (just a) k = k a

module _ (I : IOInterface )
         (let C = I .Command)
         (let R = I .Response)
           where

    data IOind (A : Set) : Set where

      exec''     : (c : C) (f : (r : R c) → IOind A) → IOind A
      return'' : (a : A) → IOind A

main : NativeIO Unit
main = nativePutStrLn "Hello, world!"


module Type where

open import Type.Core   public
open import Type.NbE    public
open import Type.Lemmas public


------------------------------------------------------------------------
-- Compatibility lemmas
------------------------------------------------------------------------

open import Atom

module Compatibility (atoms : χ-atoms) where

open import Bag-equivalence hiding (trans)
open import Equality.Propositional
open import Prelude hiding (const)
open import Tactic.By

open import List equality-with-J using (map)

open import Chi       atoms
open import Constants atoms
open import Reasoning atoms
open import Values    atoms

open χ-atoms atoms

-- A compatibility lemma that does not hold.

¬-⇓-[←]-right :
  ¬ (∀ {e′ v′} e x {v} →
     e′ ⇓ v′ → e [ x ← v′ ] ⇓ v → e [ x ← e′ ] ⇓ v)
¬-⇓-[←]-right hyp = ¬e[x←e′]⇓v (hyp e x e′⇓v′ e[x←v′]⇓v)
  where
  x : Var
  x = v-x

  e′ v′ e v : Exp
  e′ = apply (lambda v-x (var v-x)) (const c-true [])
  v′ = const c-true []
  e  = lambda v-y (var v-x)
  v  = lambda v-y (const c-true [])

  e′⇓v′ : e′ ⇓ v′
  e′⇓v′ = apply lambda (const [])
            (case v-x V.≟ v-x
             return (λ b → if b then const c-true []
                                else var v-x ⇓ v′) of (λ where
               (yes _)   → const []
               (no  x≢x) → ⊥-elim (x≢x refl)))

  lemma : ∀ v → e [ x ← v ] ≡ lambda v-y v
  lemma _ with v-x V.≟ v-y
  ... | yes x≡y = ⊥-elim (V.distinct-codes→distinct-names (λ ()) x≡y)
  ... | no  _   with v-x V.≟ v-x
  ...   | yes _   = refl
  ...   | no  x≢x = ⊥-elim (x≢x refl)

  e[x←v′]⇓v : e [ x ← v′ ] ⇓ v
  e[x←v′]⇓v =
    e [ x ← v′ ]   ≡⟨ lemma _ ⟩⟶
    lambda v-y v′  ⇓⟨ lambda ⟩■
    v

  ¬e[x←e′]⇓v : ¬ e [ x ← e′ ] ⇓ v
  ¬e[x←e′]⇓v p with _[_←_] e x e′ | lemma e′
  ¬e[x←e′]⇓v () | ._ | refl

mutual

  -- Contexts.

  data Context : Type where
    ∙       : Context
    apply←_ : Context → {e : Exp} → Context
    apply→_ : {e : Exp} → Context → Context
    const   : {c : Const} → Context⋆ → Context
    case    : Context → {bs : List Br} → Context

  data Context⋆ : Type where
    here  : Context → {es : List Exp} → Context⋆
    there : {e : Exp} → Context⋆ → Context⋆

mutual

  -- Filling a context's hole (∙) with an expression.

  infix 6 _[_] _[_]⋆

  _[_] : Context → Exp → Exp
  ∙                  [ e ] = e
  apply←_ c {e = e′} [ e ] = apply (c [ e ]) e′
  apply→_ {e = e′} c [ e ] = apply e′ (c [ e ])
  const {c = c′} c   [ e ] = const c′ (c [ e ]⋆)
  case c {bs = bs}   [ e ] = case (c [ e ]) bs

  _[_]⋆ : Context⋆ → Exp → List Exp
  here c {es = es} [ e ]⋆ = (c [ e ]) ∷ es
  there {e = e′} c [ e ]⋆ = e′ ∷ (c [ e ]⋆)

mutual

  -- If e₁ terminates with v₁ and c [ v₁ ] terminates with v₂, then
  -- c [ e₁ ] also terminates with v₂.

  []⇓ :
    ∀ c {e₁ v₁ v₂} →
    e₁ ⇓ v₁ → c [ v₁ ] ⇓ v₂ → c [ e₁ ] ⇓ v₂
  []⇓ ∙ {e₁} {v₁} {v₂} p q =
    e₁  ⇓⟨ p ⟩
    v₁  ⇓⟨ q ⟩■
    v₂

  []⇓ (apply← c) p (apply q r s)  = apply ([]⇓ c p q) r s
  []⇓ (apply→ c) p (apply q r s)  = apply q ([]⇓ c p r) s
  []⇓ (const c)  p (const ps)     = const ([]⇓⋆ c p ps)
  []⇓ (case c)   p (case q r s t) = case ([]⇓ c p q) r s t

  []⇓⋆ :
    ∀ c {e v vs} →
    e ⇓ v → c [ v ]⋆ ⇓⋆ vs → c [ e ]⋆ ⇓⋆ vs
  []⇓⋆ (here  c) p (q ∷ qs) = []⇓ c p q ∷ qs
  []⇓⋆ (there c) p (q ∷ qs) = q ∷ []⇓⋆ c p qs


------------------------------------------------------------------------
-- An implementation of the Thue-Morse sequence
------------------------------------------------------------------------

-- This module is a variant of ThueMorse. The difference is that, in
-- this module, the cast operation takes an inequality instead of an
-- equality, and that this module does not contain any correctness
-- proofs.

module ThueMorseLeq where

open import Codata.Musical.Notation
open import Codata.Musical.Stream using (Stream; _≈_)
open Codata.Musical.Stream.Stream
open import Data.Bool using (Bool; not); open Data.Bool.Bool
open import Data.Nat using (ℕ); open Data.Nat.ℕ
open import Data.Vec using (Vec; _∷ʳ_); open Data.Vec.Vec

------------------------------------------------------------------------
-- Chunks

-- A value of type Chunks describes how a stream is generated. Note
-- that an infinite sequence of empty chunks is not allowed.

data Chunks : Set where
  -- Start the next chunk.
  next : (m :   Chunks) → Chunks
  -- Cons an element to the current chunk.
  cons : (m : ∞ Chunks) → Chunks

-- Inequality of chunks.

infix 4 _≥C_

data _≥C_ : Chunks → Chunks → Set where
  next  : ∀ {m m′} (m≥m′ :      m ≥C   m′ ) → next m ≥C next m′
  cons  : ∀ {m m′} (m≥m′ : ∞ (♭ m ≥C ♭ m′)) → cons m ≥C cons m′
  consˡ : ∀ {m m′} (m≥m′ :    ♭ m ≥C   m′ ) → cons m ≥C      m′

------------------------------------------------------------------------
-- Chunk transformers

tailC : Chunks → Chunks
tailC (next m) = next (tailC m)
tailC (cons m) = ♭ m

mutual

  evensC : Chunks → Chunks
  evensC (next m) = next (evensC m)
  evensC (cons m) = cons (♯ oddsC (♭ m))

  oddsC : Chunks → Chunks
  oddsC (next m) = next (oddsC m)
  oddsC (cons m) = evensC (♭ m)

infixr 5 _⋎C_

-- Note that care is taken to create as few and large chunks as
-- possible (see also _⋎W_).

_⋎C_ : Chunks → Chunks → Chunks
next m ⋎C next m′ = next (m ⋎C      m′)   -- Two chunks in, one out.
next m ⋎C cons m′ = next (m ⋎C cons m′)
cons m ⋎C      m′ = cons (♯ (m′ ⋎C ♭ m))

------------------------------------------------------------------------
-- Stream programs

-- StreamP m A encodes programs which generate streams with chunk
-- sizes given by m.

infixr 5 _∷_ _⋎_

data StreamP : Chunks → Set → Set₁ where
  [_]     : ∀ {m A} (xs : ∞ (StreamP m A)) → StreamP (next m) A
  _∷_     : ∀ {m A} (x : A) (xs : StreamP (♭ m) A) → StreamP (cons m) A
  tail    : ∀ {m A} (xs : StreamP m A) → StreamP (tailC m) A
  evens   : ∀ {m A} (xs : StreamP m A) → StreamP (evensC m) A
  odds    : ∀ {m A} (xs : StreamP m A) → StreamP (oddsC m) A
  _⋎_     : ∀ {m m′ A} (xs : StreamP m A) (ys : StreamP m′ A) →
            StreamP (m ⋎C m′) A
  map     : ∀ {m A B} (f : A → B) (xs : StreamP m A) → StreamP m B
  cast    : ∀ {m m′ A} (ok : m ≥C m′) (xs : StreamP m A) → StreamP m′ A

data StreamW : Chunks → Set → Set₁ where
  [_] : ∀ {m A} (xs : StreamP m A) → StreamW (next m) A
  _∷_ : ∀ {m A} (x : A) (xs : StreamW (♭ m) A) → StreamW (cons m) A

program : ∀ {m A} → StreamW m A → StreamP m A
program [ xs ]   = [ ♯ xs ]
program (x ∷ xs) = x ∷ program xs

tailW : ∀ {m A} → StreamW m A → StreamW (tailC m) A
tailW [ xs ]   = [ tail xs ]
tailW (x ∷ xs) = xs

mutual

  evensW : ∀ {m A} → StreamW m A → StreamW (evensC m) A
  evensW [ xs ]   = [ evens xs ]
  evensW (x ∷ xs) = x ∷ oddsW xs

  oddsW : ∀ {m A} → StreamW m A → StreamW (oddsC m) A
  oddsW [ xs ]   = [ odds xs ]
  oddsW (x ∷ xs) = evensW xs

infixr 5 _⋎W_

-- Note: Uses swapping of arguments.

_⋎W_ : ∀ {m m′ A} → StreamW m A → StreamW m′ A → StreamW (m ⋎C m′) A
[ xs ]   ⋎W [ ys ]   = [ xs ⋎ ys ]
[ xs ]   ⋎W (y ∷ ys) = [ xs ⋎ program (y ∷ ys) ]
(x ∷ xs) ⋎W ys       = x ∷ ys ⋎W xs

mapW : ∀ {m A B} → (A → B) → StreamW m A → StreamW m B
mapW f [ xs ]   = [ map f xs ]
mapW f (x ∷ xs) = f x ∷ mapW f xs

module Cast where

  infixr 6 _+_
  infixr 5 _++_

  _+_ : ℕ → Chunks → Chunks
  zero  + m = m
  suc n + m = cons (♯ (n + m))

  _++_ : ∀ {A n m} → Vec A n → StreamP m A → StreamP (n + m) A
  []       ++ ys = ys
  (x ∷ xs) ++ ys = x ∷ (xs ++ ys)

  +ˡ : ∀ {m m′} n → m ≥C m′ → n + m ≥C m′
  +ˡ zero    m≥m′ = m≥m′
  +ˡ (suc n) m≥m′ = consˡ (+ˡ n m≥m′)

  castW : ∀ {n m m′ A} → m ≥C m′ → Vec A n → StreamW m A → StreamW m′ A
  castW {n} (next  m≥m′) xs       [ ys ]   = [ cast (+ˡ n m≥m′) (xs ++ ys) ]
  castW     (cons  m≥m′) []       (y ∷ ys) = y ∷ castW (♭ m≥m′) []        ys
  castW     (cons  m≥m′) (x ∷ xs) (y ∷ ys) = x ∷ castW (♭ m≥m′) (xs ∷ʳ y) ys
  castW     (consˡ m≥m′) xs       (y ∷ ys) = castW m≥m′ (xs ∷ʳ y) ys

whnf : ∀ {m A} → StreamP m A → StreamW m A
whnf [ xs ]         = [ ♭ xs ]
whnf (x ∷ xs)       = x ∷ whnf xs
whnf (tail xs)      = tailW (whnf xs)
whnf (evens xs)     = evensW (whnf xs)
whnf (odds xs)      = oddsW (whnf xs)
whnf (xs ⋎ ys)      = whnf xs ⋎W whnf ys
whnf (map f xs)     = mapW f (whnf xs)
whnf (cast m≥m′ xs) = Cast.castW m≥m′ [] (whnf xs)

mutual

  ⟦_⟧W : ∀ {m A} → StreamW m A → Stream A
  ⟦ [ xs ] ⟧W = ⟦ xs ⟧P
  ⟦ x ∷ xs ⟧W = x ∷ ♯ ⟦ xs ⟧W

  ⟦_⟧P : ∀ {m A} → StreamP m A → Stream A
  ⟦ xs ⟧P = ⟦ whnf xs ⟧W

------------------------------------------------------------------------
-- The Thue-Morse sequence

[ccn]ω : Chunks
[ccn]ω = cons (♯ cons (♯ next [ccn]ω))

[cn]²[ccn]ω : Chunks
[cn]²[ccn]ω = cons (♯ next (cons (♯ next [ccn]ω)))

[cn]³[ccn]ω : Chunks
[cn]³[ccn]ω = cons (♯ next [cn]²[ccn]ω)

lemma₁ : oddsC [ccn]ω ⋎C [ccn]ω ≥C [ccn]ω
lemma₁ = cons (♯ cons (♯ next (cons (♯ cons (♯ next lemma₁)))))

lemma : evensC [cn]³[ccn]ω ⋎C tailC [cn]³[ccn]ω ≥C [cn]²[ccn]ω
lemma = cons (♯ next (cons (♯ next (cons (♯ cons (♯ next lemma₁))))))

thueMorse : StreamP [cn]³[ccn]ω Bool
thueMorse =
  false ∷ [ ♯ cast lemma (map not (evens thueMorse) ⋎ tail thueMorse) ]


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; cong; cong₂; cong-app)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; step-≡; _∎)
open import Function using (_∘_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Fin hiding (_+_; #_)

open import DeBruijn

postulate
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

⟪_⟫ : ∀ {n m} → Subst n m → Term n → Term m
⟪ σ ⟫ = subst σ

ids : ∀ {n} → Subst n n
ids x = # x

↑ : ∀ {n} → Subst n (suc n)
↑ x = # (suc x)

infix 6 _•_

_•_ : ∀ {n m} → Term m → Subst n m → Subst (suc n) m
(M • σ) zero    = M
(M • σ) (suc x) = σ x

infixr 5 _⨟_

_⨟_ : ∀ {n k m} → Subst n k → Subst k m → Subst n m
σ ⨟ τ = ⟪ τ ⟫ ∘ σ

ren : ∀ {n m} → Rename n m → Subst n m
ren ρ = ids ∘ ρ

sub-head : ∀ {n m} {M : Term m} {σ : Subst n m}
         → ⟪ M • σ ⟫ (# zero) ≡ M
sub-head = refl

sub-tail : ∀ {n m} {M : Term m} {σ : Subst n m}
         → (↑ ⨟ M • σ) ≡ σ
sub-tail = extensionality λ x → refl

sub-idL : ∀ {n m} {σ : Subst n m}
       → ids ⨟ σ ≡ σ
sub-idL = extensionality λ x → refl

sub-dist :  ∀ {n m k} {σ : Subst n m} {τ : Subst m k} {M : Term m}
         → ((M • σ) ⨟ τ) ≡ ((subst τ M) • (σ ⨟ τ))
sub-dist {n}{m}{k}{σ}{τ}{M} = extensionality λ x → lemma {x = x}
  where
  lemma : ∀ {x : Fin (suc n)} → ((M • σ) ⨟ τ) x ≡ ((subst τ M) • (σ ⨟ τ)) x
  lemma {x = zero} = refl
  lemma {x = suc x} = refl

cong-ext : ∀ {n m}{ρ ρ′ : Rename n m}
  → (ρ ≡ ρ′)
    ---------------------------------
  → ext ρ ≡ ext ρ′
cong-ext{n}{m}{ρ}{ρ′} rr = extensionality λ x → lemma {x}
  where
  lemma : ∀ {x : Fin (suc n)} → ext ρ x ≡ ext ρ′ x
  lemma {zero} = refl
  lemma {suc y} = cong suc (cong-app rr y)

cong-rename : ∀ {n m}{ρ ρ′ : Rename n m}{M M′ : Term n}
  → ρ ≡ ρ′
  → M ≡ M′
    ------------------------
  → rename ρ M ≡ rename ρ′ M
cong-rename {M = # x} rr refl = cong #_ (cong-app rr x)
cong-rename {ρ = ρ} {ρ′ = ρ′} {M = ƛ N} rr refl =
   cong ƛ_ (cong-rename {ρ = ext ρ}{ρ′ = ext ρ′}{M = N} (cong-ext rr) refl)
cong-rename {M = L · M} rr refl =
   cong₂ _·_ (cong-rename rr refl) (cong-rename rr refl)

cong-exts : ∀ {n m}{σ σ′ : Subst n m}
   → σ ≡ σ′
     ----------------
   → exts σ ≡ exts σ′
cong-exts{n}{m}{σ}{σ′} ss = extensionality λ x → lemma {x}
   where
   lemma : ∀ {x} → exts σ x ≡ exts σ′ x
   lemma {zero} = refl
   lemma {suc x} = cong (rename suc) (cong-app (ss) x)

cong-sub : ∀ {n m}{σ σ′ : Subst n m}{M M′ : Term n}
  → σ ≡ σ′
  → M ≡ M′
    -----------------------
  → subst σ M ≡ subst σ′ M′
cong-sub {n}{m}{σ}{σ′}{# x} ss refl = cong-app ss x
cong-sub {n}{m}{σ}{σ′}{ƛ M} ss refl =
   cong ƛ_ (cong-sub {σ = exts σ}{σ′ = exts σ′} {M = M} (cong-exts ss) refl)
cong-sub {n}{m}{σ}{σ′}{L · M} ss refl =
   cong₂ _·_ (cong-sub {M = L} ss refl) (cong-sub {M = M} ss refl)

cong-sub-zero : ∀ {n} {M M′ : Term n}
  → M ≡ M′
    ----------------------------
  → subst-zero M ≡ subst-zero M′
cong-sub-zero {n}{M}{M′} mm′ =
   extensionality λ x → cong (λ z → subst-zero z x) mm′

cong-cons : ∀ {n m}{M N : Term m}{σ τ : Subst n m}
  → M ≡ N
  → σ ≡ τ
    -----------------
  → (M • σ) ≡ (N • τ)
cong-cons{n}{m}{M}{N}{σ}{τ} refl st = extensionality lemma
  where
  lemma : (x : Fin (suc n)) → (M • σ) x ≡ (M • τ) x
  lemma zero = refl
  lemma (suc x) = cong-app st x

cong-seq : ∀ {n m k}{σ σ′ : Subst n m}{τ τ′ : Subst m k}
  → (σ ≡ σ′) → (τ ≡ τ′)
  → (σ ⨟ τ) ≡ (σ′ ⨟ τ′)
cong-seq {n}{m}{k}{σ}{σ′}{τ}{τ′} ss′ tt′ = extensionality lemma
  where
  lemma : (x : Fin n) → (σ ⨟ τ) x ≡ (σ′ ⨟ τ′) x
  lemma x =
     begin
       (σ ⨟ τ) x
     ≡⟨⟩
       subst τ (σ x)
     ≡⟨ cong (subst τ) (cong-app ss′ x) ⟩
       subst τ (σ′ x)
     ≡⟨ cong-sub{M = σ′ x} tt′ refl ⟩
       subst τ′ (σ′ x)
     ≡⟨⟩
       (σ′ ⨟ τ′) x
     ∎

ren-ext : ∀ {n m} {ρ : Rename n m}
        → ren (ext ρ) ≡ exts (ren ρ)
ren-ext {n}{m}{ρ} = extensionality λ x → lemma {x = x}
  where
  lemma : ∀ {x : Fin (suc n)} → (ren (ext ρ)) x ≡ exts (ren ρ) x
  lemma {x = zero} = refl
  lemma {x = suc x} = refl

rename-subst-ren : ∀ {n m} {ρ : Rename n m} {M : Term n}
                 → rename ρ M ≡ ⟪ ren ρ ⟫ M
rename-subst-ren {M = # x} = refl
rename-subst-ren {n}{ρ = ρ}{M = ƛ N} =
  begin
      rename ρ (ƛ N)
    ≡⟨⟩
      ƛ rename (ext ρ) N
    ≡⟨ cong ƛ_ (rename-subst-ren {ρ = ext ρ}{M = N}) ⟩
      ƛ ⟪ ren (ext ρ) ⟫ N
    ≡⟨ cong ƛ_ (cong-sub{M = N} ren-ext refl) ⟩
      ƛ ⟪ exts (ren ρ) ⟫ N
    ≡⟨⟩
      ⟪ ren ρ ⟫ (ƛ N)
  ∎
rename-subst-ren {M = L · M} = cong₂ _·_ rename-subst-ren rename-subst-ren

exts-cons-shift : ∀ {n m} {σ : Subst n m}
                → exts σ  ≡ (# zero • (σ ⨟ ↑))
exts-cons-shift = extensionality λ x → lemma{x = x}
  where
  lemma : ∀ {n m} {σ : Subst n m} {x : Fin (suc n)}
                  → exts σ x ≡ (# zero • (σ ⨟ ↑)) x
  lemma {x = zero} = refl
  lemma {x = suc y} = rename-subst-ren

subst-zero-cons-ids : ∀ {n}{M : Term n}
                 → subst-zero M ≡ (M • ids)
subst-zero-cons-ids = extensionality λ x → lemma {x = x}
  where
  lemma : ∀ {n}{M : Term n}{x : Fin (suc n)}
        → subst-zero M x ≡ (M • ids) x
  lemma {x = zero} = refl
  lemma {x = suc x} = refl

exts-ids : ∀ {n}
         → exts ids ≡ ids {suc n}
exts-ids {n} = extensionality lemma
  where lemma : (x : Fin (suc n)) → exts ids x ≡ ids x
        lemma zero = refl
        lemma (suc x) = refl

sub-id : ∀ {n} {M : Term n}
         → ⟪ ids ⟫ M ≡ M
sub-id {M = # x} = refl
sub-id {M = ƛ N} =
   begin
     ⟪ ids ⟫ (ƛ N)
   ≡⟨⟩
     ƛ ⟪ exts ids ⟫ N
   ≡⟨ cong ƛ_ (cong-sub{M = N} exts-ids refl)  ⟩
     ƛ ⟪ ids ⟫ N
   ≡⟨ cong ƛ_ sub-id ⟩
     ƛ N
   ∎
sub-id {M = L · M} = cong₂ _·_ sub-id sub-id

sub-idR : ∀ {n m} {σ : Subst n m}
       → (σ ⨟ ids) ≡ σ
sub-idR {n}{σ = σ} =
          begin
            σ ⨟ ids
          ≡⟨⟩
            ⟪ ids ⟫ ∘ σ
          ≡⟨ extensionality (λ x → sub-id) ⟩
            σ
          ∎

compose-ext : ∀ {n m k}{ρ : Rename m k} {ρ′ : Rename n m}
            → ((ext ρ) ∘ (ext ρ′)) ≡ ext (ρ ∘ ρ′)
compose-ext = extensionality λ x → lemma {x = x}
  where
  lemma : ∀ {n m k}{ρ : Rename m k} {ρ′ : Rename n m} {x : Fin (suc n)}
              → ((ext ρ) ∘ (ext ρ′)) x ≡ ext (ρ ∘ ρ′) x
  lemma {x = zero} = refl
  lemma {x = suc x} = refl

compose-rename : ∀ {n m k}{M : Term n}{ρ : Rename m k}{ρ′ : Rename n m}
  → rename ρ (rename ρ′ M) ≡ rename (ρ ∘ ρ′) M
compose-rename {M = # x} = refl
compose-rename {n}{m}{k}{ƛ N}{ρ}{ρ′} = cong ƛ_ G
  where
  G : rename (ext ρ) (rename (ext ρ′) N) ≡ rename (ext (ρ ∘ ρ′)) N
  G =
      begin
        rename (ext ρ) (rename (ext ρ′) N)
      ≡⟨ compose-rename{ρ = ext ρ}{ρ′ = ext ρ′} ⟩
        rename ((ext ρ) ∘ (ext ρ′)) N
      ≡⟨ cong-rename compose-ext refl ⟩
        rename (ext (ρ ∘ ρ′)) N
      ∎
compose-rename {M = L · M} = cong₂ _·_ compose-rename compose-rename

commute-subst-rename : ∀ {n m}{M : Term n}{σ : Subst n m}
                        {ρ : ∀ {n} → Rename n (suc n)}
     → (∀ {x : Fin n} → exts σ (ρ x) ≡ rename ρ (σ x))
     → subst (exts σ) (rename ρ M) ≡ rename ρ (subst σ M)
commute-subst-rename {M = # x} r = r
commute-subst-rename{n}{m}{ƛ N}{σ}{ρ} r =
   cong ƛ_ (commute-subst-rename{suc n}{suc m}{N}
               {exts σ}{ρ = ρ′} (λ {x} → H {x}))
   where
   ρ′ : ∀ {n} → Rename n (suc n)
   ρ′ {zero} = λ ()
   ρ′ {suc n} = ext ρ

   H : {x : Fin (suc n)} → exts (exts σ) (ext ρ x) ≡ rename (ext ρ) (exts σ x)
   H {zero} = refl
   H {suc y} =
     begin
       exts (exts σ) (ext ρ (suc y))
     ≡⟨⟩
       rename suc (exts σ (ρ y))
     ≡⟨ cong (rename suc) r ⟩
       rename suc (rename ρ (σ y))
     ≡⟨ compose-rename ⟩
       rename (suc ∘ ρ) (σ y)
     ≡⟨ cong-rename refl refl ⟩
       rename ((ext ρ) ∘ suc) (σ y)
     ≡⟨ sym compose-rename ⟩
       rename (ext ρ) (rename suc (σ y))
     ≡⟨⟩
       rename (ext ρ) (exts σ (suc y))
     ∎
commute-subst-rename {M = L · M}{ρ = ρ} r =
   cong₂ _·_ (commute-subst-rename{M = L}{ρ = ρ} r)
             (commute-subst-rename{M = M}{ρ = ρ} r)

exts-seq : ∀ {n m m′} {σ₁ : Subst n m} {σ₂ : Subst m m′}
         → (exts σ₁ ⨟ exts σ₂) ≡ exts (σ₁ ⨟ σ₂)
exts-seq = extensionality λ x → lemma {x = x}
  where
  lemma : ∀ {n m m′}{x : Fin (suc n)} {σ₁ : Subst n m}{σ₂ : Subst m m′}
     → (exts σ₁ ⨟ exts σ₂) x ≡ exts (σ₁ ⨟ σ₂) x
  lemma {x = zero} = refl
  lemma {x = suc x}{σ₁}{σ₂} =
     begin
       (exts σ₁ ⨟ exts σ₂) (suc x)
     ≡⟨⟩
       ⟪ exts σ₂ ⟫ (rename suc (σ₁ x))
     ≡⟨ commute-subst-rename{M = σ₁ x}{σ = σ₂}{ρ = suc} refl ⟩
       rename suc (⟪ σ₂ ⟫ (σ₁ x))
     ≡⟨⟩
       rename suc ((σ₁ ⨟ σ₂) x)
     ∎

sub-sub : ∀ {n m k}{M : Term n} {σ₁ : Subst n m}{σ₂ : Subst m k}
            → ⟪ σ₂ ⟫ (⟪ σ₁ ⟫ M) ≡ ⟪ σ₁ ⨟ σ₂ ⟫ M
sub-sub {M = # x} = refl
sub-sub {n}{m}{k}{ƛ N}{σ₁}{σ₂} =
   begin
     ⟪ σ₂ ⟫ (⟪ σ₁ ⟫ (ƛ N))
   ≡⟨⟩
     ƛ ⟪ exts σ₂ ⟫ (⟪ exts σ₁ ⟫ N)
   ≡⟨ cong ƛ_ (sub-sub{M = N}{σ₁ = exts σ₁}{σ₂ = exts σ₂}) ⟩
     ƛ ⟪ exts σ₁ ⨟ exts σ₂ ⟫ N
   ≡⟨ cong ƛ_ (cong-sub{M = N} exts-seq refl) ⟩
     ƛ ⟪ exts ( σ₁ ⨟ σ₂) ⟫ N
   ∎
sub-sub {M = L · M} = cong₂ _·_ (sub-sub{M = L}) (sub-sub{M = M})

rename-subst : ∀ {n m m′}{M : Term n}{ρ : Rename n m}{σ : Subst m m′}
             → ⟪ σ ⟫ (rename ρ M) ≡ ⟪ σ ∘ ρ ⟫ M
rename-subst {n}{m}{m′}{M}{ρ}{σ} =
   begin
     ⟪ σ ⟫ (rename ρ M)
   ≡⟨ cong ⟪ σ ⟫ (rename-subst-ren{M = M}) ⟩
     ⟪ σ ⟫ (⟪ ren ρ ⟫ M)
   ≡⟨ sub-sub{M = M} ⟩
     ⟪ ren ρ ⨟ σ ⟫ M
   ≡⟨⟩
     ⟪ σ ∘ ρ ⟫ M
   ∎

sub-assoc : ∀ {n m k Ψ} {σ : Subst n m} {τ : Subst m k} {θ : Subst k Ψ}
          → (σ ⨟ τ) ⨟ θ ≡ (σ ⨟ τ ⨟ θ)
sub-assoc {n}{m}{k}{Ψ}{σ}{τ}{θ} = extensionality λ x → lemma{x = x}
  where
  lemma : ∀ {x : Fin n} → ((σ ⨟ τ) ⨟ θ) x ≡ (σ ⨟ τ ⨟ θ) x
  lemma {x} =
      begin
        ((σ ⨟ τ) ⨟ θ) x
      ≡⟨⟩
        ⟪ θ ⟫ (⟪ τ ⟫ (σ x))
      ≡⟨ sub-sub{M = σ x} ⟩
        ⟪ τ ⨟ θ ⟫ (σ x)
      ≡⟨⟩
        (σ ⨟ τ ⨟ θ) x
      ∎

subst-zero-exts-cons : ∀ {n m}{σ : Subst n m}{M : Term m}
                     → exts σ ⨟ subst-zero M ≡ (M • σ)
subst-zero-exts-cons {n}{m}{σ}{M} =
    begin
      exts σ ⨟ subst-zero M
    ≡⟨ cong-seq exts-cons-shift subst-zero-cons-ids ⟩
      (# zero • (σ ⨟ ↑)) ⨟ (M • ids)
    ≡⟨ sub-dist ⟩
      (⟪ M • ids ⟫ (# zero)) • ((σ ⨟ ↑) ⨟ (M • ids))
    ≡⟨ cong-cons (sub-head{σ = ids}) refl ⟩
      M • ((σ ⨟ ↑) ⨟ (M • ids))
    ≡⟨ cong-cons refl (sub-assoc{σ = σ}) ⟩
      M • (σ ⨟ (↑ ⨟ (M • ids)))
    ≡⟨ cong-cons refl (cong-seq{σ = σ} refl (sub-tail{M = M}{σ = ids})) ⟩
      M • (σ ⨟ ids)
    ≡⟨ cong-cons refl (sub-idR{σ = σ}) ⟩
      M • σ
    ∎

subst-commute : ∀ {n m} {N : Term (suc n)} {M : Term n} {σ : Subst n m}
  → ⟪ exts σ ⟫ N [ ⟪ σ ⟫ M ] ≡ ⟪ σ ⟫ (N [ M ])
subst-commute {n}{m}{N}{M}{σ} =
  begin
    ⟪ exts σ ⟫ N [ ⟪ σ ⟫ M ]
  ≡⟨⟩
    ⟪ subst-zero (⟪ σ ⟫ M) ⟫ (⟪ exts σ ⟫ N)
  ≡⟨ cong-sub {M = ⟪ exts σ ⟫ N} subst-zero-cons-ids refl ⟩
    ⟪ ⟪ σ ⟫ M • ids ⟫ (⟪ exts σ ⟫ N)
  ≡⟨ sub-sub {M = N} ⟩
    ⟪ (exts σ) ⨟ ((⟪ σ ⟫ M) • ids) ⟫ N
  ≡⟨ cong-sub {M = N} (cong-seq exts-cons-shift refl) refl ⟩
  ⟪ (# zero • (σ ⨟ ↑)) ⨟ (⟪ σ ⟫ M • ids) ⟫ N
  ≡⟨ cong-sub {M = N} (sub-dist {M = # zero}) refl ⟩
    ⟪ ⟪ ⟪ σ ⟫ M • ids ⟫ (# zero) • ((σ ⨟ ↑) ⨟ (⟪ σ ⟫ M • ids)) ⟫ N
  ≡⟨⟩
    ⟪ ⟪ σ ⟫ M • ((σ ⨟ ↑) ⨟ (⟪ σ ⟫ M • ids)) ⟫ N
  ≡⟨ cong-sub {M = N} (cong-cons refl (sub-assoc {σ = σ})) refl ⟩
    ⟪ ⟪ σ ⟫ M • (σ ⨟ ↑ ⨟ ⟪ σ ⟫ M • ids) ⟫ N
  ≡⟨ cong-sub {M = N} refl refl ⟩
    ⟪ ⟪ σ ⟫ M • (σ ⨟ ids) ⟫ N
  ≡⟨ cong-sub {M = N} (cong-cons refl (sub-idR {σ = σ})) refl ⟩
    ⟪ ⟪ σ ⟫ M • σ ⟫ N
  ≡⟨ cong-sub {M = N} (cong-cons refl (sub-idL {σ = σ})) refl ⟩
    ⟪ ⟪ σ ⟫ M • (ids ⨟ σ) ⟫ N
  ≡⟨ cong-sub {M = N} (sym sub-dist) refl ⟩
    ⟪ M • ids ⨟ σ ⟫ N
  ≡⟨ sym (sub-sub {M = N}) ⟩
    ⟪ σ ⟫ (⟪ M • ids ⟫ N)
  ≡⟨ cong ⟪ σ ⟫ (sym (cong-sub {M = N} subst-zero-cons-ids refl)) ⟩
    ⟪ σ ⟫ (N [ M ])
  ∎

rename-subst-commute : ∀ {n m} {N : Term (suc n)} {M : Term n} {ρ : Rename n m }
  → (rename (ext ρ) N) [ rename ρ M ] ≡ rename ρ (N [ M ])
rename-subst-commute {n}{m}{N}{M}{ρ} =
  begin
    (rename (ext ρ) N) [ rename ρ M ]
  ≡⟨ cong-sub (cong-sub-zero (rename-subst-ren {M = M})) (rename-subst-ren {M = N}) ⟩
    (⟪ ren (ext ρ) ⟫ N) [ ⟪ ren ρ ⟫ M ]
  ≡⟨ cong-sub refl (cong-sub {M = N} ren-ext refl) ⟩
    (⟪ exts (ren ρ) ⟫ N) [ ⟪ ren ρ ⟫ M ]
  ≡⟨ subst-commute {N = N} ⟩
    subst (ren ρ) (N [ M ])
  ≡⟨ sym (rename-subst-ren) ⟩
    rename ρ (N [ M ])
  ∎

infix 8 _〔_〕

_〔_〕 : ∀ {n} → Term (suc (suc n)) → Term n → Term (suc n)
_〔_〕 N M = subst (exts (subst-zero M)) N

substitution-lemma : ∀ {n} {M : Term (suc (suc n))} {N : Term (suc n)} {L : Term n}
  → M [ N ] [ L ] ≡ (M 〔 L 〕) [ (N [ L ]) ]
substitution-lemma {M = M}{N = N}{L = L} =
  sym (subst-commute {N = M}{M = N}{σ = subst-zero L})


open import Prelude
open import Data.Maybe using (Maybe; just; nothing)
open import Data.String renaming (_++_ to _++s_)

open import RW.Language.RTerm
open import RW.Language.RTermUtils
open import RW.Language.FinTerm
open import RW.Language.Instantiation

-- Strategy Module.
--
--  Here we'll provide a modular approach to implementing both
--  unification and  abstraction-guessing strategies based
--  on the head of both terms.
module RW.Strategy where

  --   The complexity annotations might require
  --   a slight notational introduction.
  --
  --   If a variable name overlaps one in the corresponding type signature,
  --   this is intentional.
  --
  --   Sₜ is defined by (S t).
  --   #Fvₜ is defined by length (Fv t).
  --   Both measures are defined at RW.Language.RTermUtils.
  --

  open import RW.Utils.Monads using (module Monad)
  open import RW.Utils.Error
  open Monad {{...}}
  open IsError {{...}}

  -------------------------
  -- Error Layer
  -------------------------

  -- Strategy related errors
  data StratErr : Set where
    Nothing       : StratErr
    NoUnification : StratErr
    NoUStrat      : StratErr
    NoTStrat      : RTermName → RTermName → StratErr
    Custom        : String → StratErr

  instance
    IsError-StratErr : IsError StratErr
    IsError-StratErr = record { showError = showErr }
      where
        showErr : StratErr → String
        showErr Nothing        = "Nothing; Internal msg passing flag."
        showErr NoUnification  = "No unification could be performed."
        showErr NoUStrat       = "No suitable unification strategy found."
        showErr (NoTStrat g a) = "No suitable term stragety found.\n"
                              ++s showRTermName g ++s ", " ++s showRTermName a
        showErr (Custom msg)   = "[!] " Data.String.++ msg

  -------------------------
  -- Strategy Pipeline
  --
  --  Whenever we want to perform a rewrite, we'll have a goal and an action to perform on a "subgoal"
  --  This subgoal has to figured out by us, which we denote by g□.
  --  Afterwards, we need to somehow apply our action.

  -- Let's encapsulate everything we need in a record
  record RWData : Set where
    constructor rw-data
    field
      goal   : RBinApp ⊥
      actℕ   : ℕ
      act    : RBinApp (Fin actℕ)
      ctx    : List (RTerm ⊥)

    goal-name : RTermName
    goal-name = p1 goal

    goal-1 : RTerm ⊥
    goal-1 = p1 (p2 goal)
    goal-2 : RTerm ⊥
    goal-2 = p2 (p2 goal)

    act-name : RTermName
    act-name = p1 act

  open RWData

  -- We might need a few transformations here and there.
  data Trs : Set where
    Symmetry : Trs

  -- Unification data
  record UData : Set where
    constructor u-data
    field
      -- We should have an abstraction available,
      □ : RTerm Unit

      -- A substitution
      σ : RSubst

      -- Our action and a few transformations that might need to be applied.
      trs : List Trs

  -------------------------
  -- Unification Strategy Layer
  -------------------------

  private
    μ : ∀{a}{A : Set a} → Maybe (Maybe A) → Maybe A
    μ (just x) = x
    μ nothing  = nothing

  -- Alternatives
  infixr 4 _<|>_
  _<|>_ : ∀{a b}{A : Set a}{B E : Set b} ⦃ isErr : IsError E ⦄
        → (A → Err E B) → (A → Err E B)
        → A → Err E B
  (f <|> g) a with f a
  ...| i1 _ = g a
  ...| i2b  = i2b

  try-all : ∀{a b}{A : Set a}{B E : Set b} ⦃ isErr : IsError E ⦄
          → (A → Err E B) → E → List A → Err E B
  try-all f e [] = i1 e
  try-all f e (a ∷ as) with f a
  ...| i1 _ = try-all f e as
  ...| i2 r = return r

  -- Basic unification strategy
  --
  --  g□ ← g₁ ∩↑ g₂    ∈ O(min(Sg₁, Sg₂))
  --  t1 ← g□ -↓ g₁    ∈ O(# Fv g□)
  --  u1 ← inst ty1 t1 ∈ O(ty1n² + (Sty1 + 1) × ty1n + Sty1)
  --  t2 ← g□ -↓ g₂    ∈ O(# Fv g□)
  --  u2 ← inst ty2 t2 ∈ O(ty2n² + (Sty2 + 1) × ty2n + Sty2)
  --
  --  Summing everything up and symplifying a bit, we get:
  --  (Note that S ty = S t₁ + S t₂ + 1)
  --
  --  min(Sg₁, Sg₂) + 2 #(Fv g□) + t₁² + t₂² + Sty₁ ty₁ + Sty2 ty₂
  --                                                    + t₁ + t₂ + ST - 1
  --
  --  Yet, g□, ideally is our context, with one hole, since
  --  we are doing one rewrite at a time. Therefore #Fv g□ = 1.
  --  Prunning out this constant we get:
  --
  --  min(Sg₁, Sg₂) + t₁² + t₂² + Sty₁ ty₁ + Sty2 ty₂ + t₁ + t₂ + ST
  --
  --  wlog, let us assume that t₁ ≥ t₂ and Sty1 ≥ Sty2.
  --  So,
  --      2t₁² + 2S₁t₁ + 2t₁ + 2S₁
  --         ≥ t₁² + t₂² + Sty₁ ty₁ + Sty2 ty₂ + t₁ + t₂ + ST
  --
  --  Also ignoring min(Sg₁, Sg₂), since it can be seen as a constant,
  --  Our basic unification strategy is somewhere around:
  --
  --  basic ∈ O(2t(t + S + 1) + 2S), for t = max(t₁ , t₂)
  --                                 and S = max(St₁ , St₂)
  --
  --  Which was expected! Our RTermUtils functions are linear in some of
  --  the parameters that appeared here, and instantiation was the
  --  only quadratic one, on the number of free variables to instantiate.
  --
  basic : RWData → Err StratErr UData
  basic (rw-data (hdₓ , g1 , g2) zero (hdₐ , ty1 , ty2) _ )
    = let g□ = g1 ∩↑ g2
      in i2 (u-data (⊥2UnitCast g□) [] [])
  basic (rw-data (hdₓ , g1 , g2) tn (hdₐ , ty1 , ty2)  _ )
    = let g□ = g1 ∩↑ g2
          u1 = (g□ -↓ g1) >>= (inst ty1)
          u2 = (g□ -↓ g2) >>= (inst ty2)
          σ  = μ ((_++ₓ_ <$> u1) <*> u2)
    in maybe (λ s → i2 (u-data (⊥2UnitCast g□) s [])) (i1 NoUnification) (σ >>= X2RSubst)

  -- Unification over the symmetric action type.
  basic-sym : RWData → Err StratErr UData
  basic-sym (rw-data (hdₓ , g1 , g2) tn (hdₐ , ty1 , ty2) _ )
    = let g□ = g1 ∩↑ g2
          u1 = (g□ -↓ g1) >>= (inst ty2)
          u2 = (g□ -↓ g2) >>= (inst ty1)
          σ  = μ ((_++ₓ_ <$> u1) <*> u2)
    in maybe (λ s → i2 (u-data (⊥2UnitCast g□) s (Symmetry ∷ []))) (i1 NoUnification) (σ >>= X2RSubst)

  -- Runs the unification strategies we know about
  -- in the given target terms.
  runUStrats : RWData → Err StratErr UData
  runUStrats = basic <|> basic-sym

  -------------------------
  -- Term Strategy Layer
  -------------------------

  -- The Term Guessing Strategy should be plugged right after
  -- a unification has been succesfuly performed.
  --
  -- Given the head of both our goal and action we
  -- should be able to guess a term that 'bridges' them.
  --
  record TStrat : Set where
    field
      when : RTermName → RTermName → Bool

      how  : Name → UData → Err StratErr (RTerm ⊥)

  -- For now, we'll use a naive list to implement a TStrat
  -- database.
  TStratDB : Set
  TStratDB = List TStrat

  -- Utility to run a list of TStrat's.
  -- Not only returns the resulting term, but also the selected TStrat.
  runTStrats : TStratDB → RWData → Name → UData → Err StratErr (RTerm ⊥)
  runTStrats [] rw = λ _ _ → i1 (NoTStrat (goal-name rw) (act-name rw))
  runTStrats (s ∷ ss) rw with TStrat.when s (goal-name rw) (act-name rw)
  ...| false = runTStrats ss rw
  ...| true  = TStrat.how s

  -- From a name and a substitution create an application.
  makeApp : Name → RSubst → RTerm ⊥
  makeApp act σ = rapp (rdef act) (map p2 σ)


open import Nat
open import Prelude
open import dynamics-core
open import disjointness

module elaboration-generality where
  mutual
    elaboration-generality-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : ihexp} {Δ : hctx} →
                                   Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                                   Γ ⊢ e => τ
    elaboration-generality-synth ESNum = SNum
    elaboration-generality-synth (ESPlus dis apt x₁ x₂) =
      SPlus (elaboration-generality-ana x₁) (elaboration-generality-ana x₂)
    elaboration-generality-synth (ESAsc x) = SAsc (elaboration-generality-ana x)
    elaboration-generality-synth (ESVar x₁) = SVar x₁
    elaboration-generality-synth (ESLam apt ex) with elaboration-generality-synth ex
    ... | ih = SLam apt ih
    elaboration-generality-synth (ESAp dis _ a x₁ x₂ x₃) =
      SAp a x₁ (elaboration-generality-ana x₃)
    elaboration-generality-synth (ESPair x x₁ x₂ x₃) =
      SPair (elaboration-generality-synth x₂) (elaboration-generality-synth x₃)
    elaboration-generality-synth ESEHole = SEHole
    elaboration-generality-synth (ESNEHole dis ex) = SNEHole (elaboration-generality-synth ex)
    elaboration-generality-synth (ESFst wt x₁ x₂) = SFst wt x₁
    elaboration-generality-synth (ESSnd wt x₁ x₂) = SSnd wt x₁

    elaboration-generality-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : ihexp} {Δ : hctx} →
                                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                                 Γ ⊢ e <= τ
    elaboration-generality-ana (EALam apt m ex) = ALam apt m (elaboration-generality-ana ex)
    elaboration-generality-ana (EASubsume x x₁ x₂ x₃) =
      ASubsume (elaboration-generality-synth x₂) x₃
    elaboration-generality-ana EAEHole = ASubsume SEHole TCHole1
    elaboration-generality-ana (EANEHole dis x) =
      ASubsume (SNEHole (elaboration-generality-synth x)) TCHole1
    elaboration-generality-ana (EAInl x x₁) = AInl x (elaboration-generality-ana x₁)
    elaboration-generality-ana (EAInr x x₁) = AInr x (elaboration-generality-ana x₁)
    elaboration-generality-ana (EACase x x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁) =
      ACase x₆ x₇ x₉ (elaboration-generality-synth x₈)
                     (elaboration-generality-ana x₁₀)
                     (elaboration-generality-ana x₁₁)


module Terms where

import Level
open import Data.Unit as Unit
open import Data.List as List
open import Data.Product as Product
open import Categories.Category using (Category)

open import Types

open import Common.Context GType
  using (Ctx; Var; zero; ctx-cat; ctx-bin-coproducts)
  renaming (succ to succ′)
open Categories.Category.Category ctx-cat
  renaming ( _⇒_ to _▹_
           ; _≡_ to _≈_
           ; _∘_ to _●_
           ; id  to ctx-id
           )
open import Categories.Object.BinaryCoproducts ctx-cat
open BinaryCoproducts ctx-bin-coproducts

-- | Signatures over which we can define terms
Sig = Ctx

-- | Typed patterns
data Pat : (a : GType) → Set where
  var′ : ∀{a : GType}       (x : Var [ a ] a)                 → Pat a
  κ₁′  : ∀{a₁ a₂ : GType}   (p : Pat a₁)           → Pat (a₁ ⊕ a₂)
  κ₂′  : ∀{a₁ a₂ : GType}   (p : Pat a₂)           → Pat (a₁ ⊕ a₂)
  α′   : ∀{a : Type [ tt ]} (p : Pat (unfold-μ a)) → Pat (μ a)

-- | Context defined by a pattern (this is either empty or contains a single
--   variable).
pat-ctx : ∀ {a} → Pat a → Ctx
pat-ctx {a} (var′ x) = [ a ]
pat-ctx     (κ₁′ x)  = pat-ctx x
pat-ctx     (κ₂′ x)  = pat-ctx x
pat-ctx     (α′ x)   = pat-ctx x

-- | Typed copatterns
data Copat : (a b : GType) → Set where
  ·    : ∀{a}                                                   → Copat a a
  app′ : ∀{a b c : GType}               (q : Copat (b ⇒ c) a)
                                        (p : Pat c)             → Copat c a
  π₁′  : ∀{a₁ a₂ a : GType}             (q : Copat (a₁ ⊗ a₂) a) → Copat a₁ a
  π₂′  : ∀{a₁ a₂ a : GType}             (q : Copat (a₁ ⊗ a₂) a) → Copat a₂ a
  ξ′   : ∀{b : Type [ tt ]} {a : GType} (q : Copat (ν b) a)     → Copat (unfold-ν b) a

-- | Context defined by a copattern
copat-ctx : ∀ { a b} → Copat a b → Ctx
copat-ctx ·          = []
copat-ctx (app′ q p) = (copat-ctx q) ∐ (pat-ctx p)
copat-ctx (π₁′ q)    = copat-ctx q
copat-ctx (π₂′ q)    = copat-ctx q
copat-ctx (ξ′ q)     = copat-ctx q

mutual
  -- | A clause { q₁ ↦ t₁ ; ... ; qₙ ↦ tₙ } defines the body of a λ-abstraction
  --   of the definition of a symbol in a signature.
  record Clause {Δ : Sig} {Γ : Ctx} {a : GType} : Set where
    inductive
    field
      body : List (
                  Σ GType (λ b →
                  Σ (Copat a b) (λ q →
                    (Term {Δ} ((copat-ctx q) ∐ Γ) b)))
             )

  -- | Terms typed in a context
  data Term {Δ : Sig} (Γ : Ctx) : GType → Set where
    var  : ∀{a : GType}       (x : Var Γ a)                 → Term Γ a
    κ₁   : ∀{a₁ a₂ : GType}   (t : Term {Δ} Γ a₁)           → Term Γ (a₁ ⊕ a₂)
    κ₂   : ∀{a₁ a₂ : GType}   (t : Term {Δ} Γ a₂)           → Term Γ (a₁ ⊕ a₂)
    α    : ∀{a : Type [ tt ]} (t : Term {Δ} Γ (unfold-μ a)) → Term Γ (μ a)
    app  : ∀{a b : GType}     (t : Term {Δ} Γ (a ⇒ b))
                              (s : Term {Δ} Γ a)            → Term Γ b
    π₁   : ∀{a₁ a₂ : GType}   (t : Term {Δ} Γ (a₁ ⊗ a₂))    → Term Γ a₁
    π₂   : ∀{a₁ a₂ : GType}   (t : Term {Δ} Γ (a₁ ⊗ a₂))    → Term Γ a₂
    ξ    : ∀{a : Type [ tt ]} (t : Term {Δ} Γ (ν a))        → Term Γ (unfold-ν a)
    svar : ∀{a : GType}       (f : Var Δ a)                 → Term Γ a
    abs  : ∀{a : GType}       (D : Clause {Δ} {Γ} {a})      → Term Γ a
    rlet : ∀{a : GType} {Δ' : Sig} →
           (Ω : Definition Δ') → Term {Δ ∐ Δ'} Γ a → Term {Δ} Γ a

  -- | A definition consists of a signature and its definition
  data DeclBlock : Sig → Set where
    empty : DeclBlock []

  record Definition (Δ : Sig) : Set where
    inductive
    field
      defs : List (Σ GType (λ a → (Var Δ a) × Clause {Δ} {[]} {a}))
open Definition

TermWDef : GType → Set
TermWDef a = Σ Sig (λ Δ → (Definition Δ) × (Term {Δ} [] a))

---------- Convenience
_↦_ : ∀{Δ : Sig} {Γ : Ctx} {a b : GType}
          (q : Copat a b) (t : Term {Δ} ((copat-ctx q) ∐ Γ) b) →
            (Σ GType (λ b →
              Σ (Copat a b) (λ q →
              (Term {Δ} ((copat-ctx q) ∐ Γ) b))))
_↦_ {b = b} q t = b , q , t

_≝_ : ∀{Δ : Sig} {a : GType}
      (f : Var Δ a) (c : Clause {Δ} {[]} {a}) →
        Σ GType (λ a → (Var Δ a) × Clause {Δ} {[]} {a})
_≝_ {a = a} f c = a , (f , c)

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

-- 〈〉 : Term [] unit
-- 〈〉 = ?

{-
hd : ∀ {a : GType} → Term (Str a) → Term a
hd t = π₁ (ξ q)

hd′ : ∀ {a b : GType} → Copat (Str a) b → Copat a b
hd′ q = π₁′ (ξ′ q)

ones : TermWDef (Str Nat)
ones = Δ , def , (svar o)
  where
    Δ : Sig
    Δ = [ Str Nat ]
    o : Var [ Str Nat ] (Str Nat)
    o = zero
    o-def : Clause {[ Str Nat ]} {[]} {Str Nat}
    o-def = record
      { body =
        [ (· ↦ svar o) ]
      }
    def : Definition Δ
    def = record
      { defs =
        [ o ≝ o-def ]
      }
-}


-- Andreas, 2014-09-03
-- Test explanation of local shadowed by import.

module _ where

module M where

  A = Set1

test : (A : Set) → let open M in {!A!}
test A = Set

-- The A exported by M is in competition with the local A.
-- Ambiguous name should be reported.


-- Andreas, 2020-05-16, issue #4649
-- Allow --safe flag in -I mode

{-# OPTIONS --safe #-}

data Unit : Set where
  unit : Unit

test : Unit
test = {!!}


module AbstractModuleMacro where

import Common.Issue481Parametrized as P

abstract
  module M = P Set


open import Issue623.B


open import IO

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

seven = suc (suc (suc (suc (suc (suc (suc zero))))))

main = run (putStrLn "Hello, world!")


module Issue309b where

data D : Set where
  d : D → D

syntax d x = f

g : D → D
g (d x) = f


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

import      LibraBFT.Base.KVMap                            as Map
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.Prelude
open import Optics.All

module LibraBFT.Impl.Consensus.TestUtils.MockSharedStorage where

new : ValidatorSet → MockSharedStorage
new = mkMockSharedStorage
  Map.empty
  Map.empty
  Map.empty
  nothing
  nothing

newObmWithLIWS : ValidatorSet → LedgerInfoWithSignatures → MockSharedStorage
newObmWithLIWS vs obmLIWS =
  new vs & mssLis ∙~ Map.singleton (obmLIWS ^∙ liwsVersion) obmLIWS


{-# OPTIONS --safe #-}

module Definition.Conversion.Lift where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.Conversion
open import Definition.Conversion.Whnf
open import Definition.Conversion.Soundness
open import Definition.Conversion.Reduction
open import Definition.Conversion.Weakening
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Fundamental.Reducibility
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Reduction
open import Definition.Typed.Consequences.Equality

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Lifting of algorithmic equality of types from WHNF to generic types.
liftConv : ∀ {A B rA Γ}
          → Γ ⊢ A [conv↓] B ^ rA
          → Γ ⊢ A [conv↑] B ^ rA
liftConv A<>B =
  let ⊢A , ⊢B = syntacticEq (soundnessConv↓ A<>B)
      whnfA , whnfB = whnfConv↓ A<>B
  in  [↑] _ _ (id ⊢A) (id ⊢B) whnfA whnfB A<>B

-- Lifting of algorithmic equality of terms from WHNF to generic terms.
liftConvTerm : ∀ {t u A Γ l}
             → Γ ⊢ t [conv↓] u ∷ A ^ l
             → Γ ⊢ t [conv↑] u ∷ A ^ l
liftConvTerm t<>u =
  let ⊢A , ⊢t , ⊢u = syntacticEqTerm (soundnessConv↓Term t<>u)
      whnfA , whnfT , whnfU = whnfConv↓Term t<>u
  in  [↑]ₜ _ _ _ (id ⊢A) (id ⊢t) (id ⊢u) whnfA whnfT whnfU t<>u

mutual
  -- Helper function for lifting from neutrals to generic terms in WHNF.
  lift~toConv↓!′ : ∀ {t u A A′ Γ l lA }
                → Γ ⊩⟨ l ⟩ A′ ^ [ ! , lA ]
                → Γ ⊢ A′ ⇒* A ^ [ ! , lA ]
                → Γ ⊢ t ~ u ↓! A ^ lA
                → Γ ⊢ t [conv↓] u ∷ A ^ lA
  lift~toConv↓!′ (Uᵣ′ _ l r l' l< PE.refl d) D ([~] A D₁ whnfB k~l)
                rewrite U≡A-whnf (trans (sym (subset* (red d))) (subset* D)) whnfB =
    ne ([~] A D₁ Uₙ k~l)
  lift~toConv↓!′ (ℕᵣ D) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , ℕₙ) (D₁ , whnfB)) =
    ℕ-ins ([~] A D₂ ℕₙ k~l)
  lift~toConv↓!′ (ne′ K D neK K≡K) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , ne neK) (D₁ , whnfB)) =
    let _ , ⊢t , ⊢u = syntacticEqTerm (soundness~↑! k~l)
        A≡K = subset* D₂
    in  ne-ins (conv ⊢t A≡K) (conv ⊢u A≡K) neK ([~] A D₂ (ne neK) k~l)
  lift~toConv↓!′ (Πᵣ′ rF lF lG l< l<' F G D ⊢F ⊢G A≡A [F] [G] G-ext) D₁ ([~] A D₂ whnfB k~l) with PE.sym (whrDet* (red D , Πₙ) (D₁ , whnfB))
  lift~toConv↓!′ (Πᵣ′ ! lF lG l< l<' F G D ⊢F ⊢G A≡A [F] [G] G-ext) D₁ ([~] A D₂ whnfB k~l) | PE.refl =
    let ⊢ΠFG , ⊢t , ⊢u = syntacticEqTerm (soundness~↓! ([~] A D₂ Πₙ k~l))
        neT , neU = ne~↑! k~l
        ⊢Γ = wf ⊢F
        var0 = neuTerm ([F] (step id) (⊢Γ ∙ ⊢F)) (var 0) (var (⊢Γ ∙ ⊢F) here)
                       (genRefl (var (⊢Γ ∙ ⊢F) here))
        0≡0 = lift~toConv↑′ ([F] (step id) (⊢Γ ∙ ⊢F)) (var-refl′ (var (⊢Γ ∙ ⊢F) here))
        k∘0≡l∘0 = lift~toConv↑′ ([G] (step id) (⊢Γ ∙ ⊢F) var0)
                                (~↑! (app-cong (wk~↓! (step id) (⊢Γ ∙ ⊢F) ([~] A D₂ Πₙ k~l)) 0≡0))
    in  η-eq l< l<' ⊢F ⊢t ⊢u (ne neT) (ne neU)
             (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ x ^ _)
                       (wkSingleSubstId _)
                       k∘0≡l∘0)
  lift~toConv↓!′ (Πᵣ′ % lF lG l< l<' F G D ⊢F ⊢G A≡A [F] [G] G-ext) D₁ ([~] A D₂ whnfB k~l) | PE.refl =
    let ⊢ΠFG , ⊢t , ⊢u = syntacticEqTerm (soundness~↓! ([~] A D₂ Πₙ k~l))
        neT , neU = ne~↑! k~l
        ⊢Γ = wf ⊢F
        var0 = neuTerm ([F] (step id) (⊢Γ ∙ ⊢F)) (var 0) (var (⊢Γ ∙ ⊢F) here)
                       (genRefl (var (⊢Γ ∙ ⊢F) here))
        k∘0≡l∘0 = lift~toConv↑′ ([G] (step id) (⊢Γ ∙ ⊢F) var0)
                                 (~↑! (app-cong (wk~↓! (step id) (⊢Γ ∙ ⊢F) ([~] A D₂ Πₙ k~l)) (%~↑ (var (⊢Γ ∙ ⊢F) here) (var (⊢Γ ∙ ⊢F) here))))
    in  η-eq l< l<' ⊢F ⊢t ⊢u (ne neT) (ne neU)
             (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ x ^ _)
                       (wkSingleSubstId _)
                       k∘0≡l∘0)
  lift~toConv↓!′ (emb emb< [A]) D t~u = lift~toConv↓!′ [A] D t~u
  lift~toConv↓!′ (emb ∞< [A]) D t~u = lift~toConv↓!′ [A] D t~u

  -- Helper function for lifting from neutrals to generic terms.
  lift~toConv↑!′ : ∀ {t u A Γ l lA}
                → Γ ⊩⟨ l ⟩ A ^ [ ! , lA ]
                → Γ ⊢ t ~ u ↑! A ^ lA
                → Γ ⊢ t [conv↑] u ∷ A ^ lA
  lift~toConv↑!′ [A] t~u =
    let B , whnfB , D = whNorm′ [A]
        t~u↓ = [~] _ (red D) whnfB t~u
        neT , neU = ne~↑! t~u
        _ , ⊢t , ⊢u = syntacticEqTerm (soundness~↓! t~u↓)
    in  [↑]ₜ _ _ _ (red D) (id ⊢t) (id ⊢u) whnfB
             (ne neT) (ne neU) (lift~toConv↓!′ [A] (red D) t~u↓)

  lift~toConv↑′ : ∀ {t u A  Γ l lA}
                → Γ ⊩⟨ l ⟩ A ^ [ ! , lA ]
                → Γ ⊢ t ~ u ↑ A ^ [ ! , lA ]
                → Γ ⊢ t [conv↑] u ∷ A ^ lA
  lift~toConv↑′ [A] (~↑! x) = lift~toConv↑!′ [A] x

-- Lifting of algorithmic equality of terms from neutrals to generic terms in WHNF.
lift~toConv↓! : ∀ {t u A Γ lA}
             → Γ ⊢ t ~ u ↓! A ^ lA
             → Γ ⊢ t [conv↓] u ∷ A ^ lA
lift~toConv↓! ([~] A D whnfB k~l) =
  lift~toConv↓!′ (reducible (proj₁ (syntacticRed D))) D ([~] A D whnfB k~l)

lift~toConv↓ : ∀ {t u A Γ lA}
             → Γ ⊢ t ~ u ↓! A ^ lA
             → Γ ⊢ t [conv↓] u ∷ A ^ lA
lift~toConv↓ x = lift~toConv↓! x

-- Lifting of algorithmic equality of terms from neutrals to generic terms.
lift~toConv↑! : ∀ {t u A Γ lA}
             → Γ ⊢ t ~ u ↑! A ^ lA
             → Γ ⊢ t [conv↑] u ∷ A ^ lA
lift~toConv↑! t~u =
  lift~toConv↑!′ (reducible (proj₁ (syntacticEqTerm (soundness~↑! t~u)))) t~u

lift~toConv↑ : ∀ {t u A Γ lA}
             → Γ ⊢ t ~ u ↑ A ^ [ ! , lA ]
             → Γ ⊢ t [conv↑] u ∷ A ^ lA
lift~toConv↑ (~↑! t~u) = lift~toConv↑! t~u


-- Partly based on code due to Andrea Vezzosi.

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

open import Agda.Builtin.Bool

data D : Set where
  run-time        : Bool → D
  @0 compile-time : Bool → D

g : D → D
g (run-time x)     = run-time x
g (compile-time x) = compile-time x

h : D → @0 D → D
h (run-time x)     _                = run-time x
h (compile-time x) (run-time y)     = compile-time y
h (compile-time x) (compile-time y) = compile-time x

i : @0 D → D → D
i _                (run-time y)     = run-time y
i (run-time x)     (compile-time y) = compile-time x
i (compile-time x) (compile-time y) = compile-time y

data E (@0 A : Set) : Set where
  c₁ c₂ : E A
  @0 c₃ : A → E A

m : {@0 A : Set} → @0 A → E A → E A
m _ c₁     = c₂
m _ c₂     = c₁
m x (c₃ _) = c₃ x