module Luau.Syntax where

open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Float using (Float)
open import Properties.Dec using (⊥)
open import Luau.Var using (Var)
open import Luau.Addr using (Addr)
open import Luau.Type using (Type)

infixr 5 _∙_

data Annotated : Set where
  maybe : Annotated
  yes : Annotated

data VarDec : Annotated → Set where
  var : Var → VarDec maybe
  var_∈_ : ∀ {a} → Var → Type → VarDec a

name : ∀ {a} → VarDec a → Var
name (var x) = x
name (var x ∈ T) = x

data FunDec : Annotated → Set where
  _⟨_⟩∈_ : ∀ {a} → Var → VarDec a → Type → FunDec a
  _⟨_⟩ : Var → VarDec maybe → FunDec maybe

fun : ∀ {a} → FunDec a → Var
fun (f ⟨ x ⟩∈ T) = f
fun (f ⟨ x ⟩) = f

arg : ∀ {a} → FunDec a → VarDec a
arg (f ⟨ x ⟩∈ T) = x
arg (f ⟨ x ⟩) = x

data BinaryOperator : Set where
  + : BinaryOperator
  - : BinaryOperator
  * : BinaryOperator
  / : BinaryOperator

data Block (a : Annotated) : Set
data Stat (a : Annotated) : Set
data Expr (a : Annotated) : Set

data Block a where
  _∙_ : Stat a → Block a → Block a
  done : Block a

data Stat a where
  function_is_end : FunDec a → Block a → Stat a
  local_←_ : VarDec a → Expr a → Stat a
  return : Expr a → Stat a

data Expr a where
  nil : Expr a
  var : Var → Expr a
  addr : Addr → Expr a
  _$_ : Expr a → Expr a → Expr a
  function_is_end : FunDec a → Block a → Expr a
  block_is_end : Var → Block a → Expr a
  number : Float → Expr a
  binexp : Expr a → BinaryOperator → Expr a → Expr a


-- Partly based on code due to Andrea Vezzosi.

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

open import Agda.Builtin.Bool

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

l : @0 D → D
l (run-time true)  = run-time true
l (run-time false) = run-time false
l (compile-time x) = compile-time x


{-# OPTIONS --type-in-type #-}

open import Agda.Primitive

test : Set
test = Setω


open import Theory

module Categories.Functor.Construction.Inclusion {ℓ₁ ℓ₂ ℓ₃} (Th : Theory ℓ₁ ℓ₂ ℓ₃) where

open import Syntax

open Theory.Theory Th
open Signature Sg
open Term Sg

open import Categories.Category.Construction.Renaming Sg as Renaming using (Ren; ren; _≐_)
open import Categories.Category.Construction.Classifying Th using (Cl; CC)

open import Categories.Functor
open import Categories.Category
open import Categories.Morphism Cl using (_≅_; Iso)
open import Categories.Category.CartesianClosed Cl
open import Categories.Category.Cartesian Cl
open import Categories.Category.BinaryProducts Cl

open import Data.List using (List; []; _∷_; _++_)
import Relation.Binary.Reasoning.Setoid as Reasoning
module TermReasoning {Γ A} = Reasoning (TermSetoid {Γ} {A})

inclusion : Functor Ren Cl
inclusion = record
      { F₀ = F₀
      ; F₁ = F₁
      ; identity = C.Equiv.refl
      ; homomorphism = λ {Γ₁} {Γ₂} {Γ₃} {f} {g} -> homomorphism f g
      ; F-resp-≈ = F-resp-≈
      }
  where
    module C = Category Cl
    open CartesianClosed CC
    open Cartesian cartesian
    open BinaryProducts products
    open import Categories.Morphism.Reasoning Cl

    id⁂id : forall {A B} -> C.id ⁂ C.id C.≈ C.id {A = A * B}
    id⁂id = trans (⟨⟩-cong₂ C.identityˡ C.identityˡ) η

    F₀ : Context -> Type
    F₀ [] = Unit
    F₀ (A ∷ Γ) = F₀ Γ * A

    F₀/*⇒++ : forall {Γ Δ} -> F₀ Γ * F₀ Δ C.⇒ F₀ (Δ ++ Γ)
    F₀/*⇒++ {Γ} {[]} = fst var
    F₀/*⇒++ {Γ} {A ∷ Δ} = (F₀/*⇒++ ⁂ C.id) C.∘ assocʳ

    F₀/++⇒* : forall {Γ Δ} -> F₀ (Δ ++ Γ) C.⇒ F₀ Γ * F₀ Δ
    F₀/++⇒* {Γ} {[]} = pair var unit
    F₀/++⇒* {Γ} {A ∷ Δ} = assocˡ C.∘ (F₀/++⇒* ⁂ C.id)

    F₀/*≅++ : forall {Γ Δ} -> F₀ Γ * F₀ Δ ≅ F₀ (Δ ++ Γ)
    F₀/*≅++ = record
      { from = F₀/*⇒++
      ; to = F₀/++⇒*
      ; iso = record { isoˡ = isoˡ ; isoʳ = isoʳ }
      }
      where
        isoˡ : forall {Γ Δ} -> F₀/++⇒* C.∘ F₀/*⇒++ C.≈ C.id {A = F₀ Γ * F₀ Δ}
        isoˡ {Γ} {[]} =
          begin
            pair var unit [ ext ! (fst var) ]
          ≈⟨ trans comm/pair (cong/pair (var/ext _ _) (comm/unit _ _ _)) ⟩
            pair (fst var) unit
          ≈⟨ cong/pair refl (eta/Unit _) ⟩
            pair (fst var) (snd var)
          ≈⟨ eta/* _ ⟩
            var
          ∎
          where open TermReasoning
        isoˡ {Γ} {A ∷ Δ} =
          begin
            (assocˡ C.∘ (F₀/++⇒* ⁂ var)) C.∘ ((F₀/*⇒++ ⁂ var) C.∘ assocʳ)
          ≈⟨ C.assoc ⟩
            assocˡ C.∘ (F₀/++⇒* ⁂ var) C.∘ (F₀/*⇒++ ⁂ var) C.∘ assocʳ
          ≈⟨ C.∘-resp-≈ʳ (pullˡ ⁂∘⁂) ⟩
            assocˡ C.∘ (F₀/++⇒* C.∘ F₀/*⇒++ ⁂ var C.∘ var) C.∘ assocʳ
          ≈⟨ C.∘-resp-≈ʳ (C.∘-resp-≈ˡ (⁂-cong₂ isoˡ C.identity²)) ⟩
            assocˡ C.∘ (var ⁂ var) C.∘ assocʳ
          ≈⟨ elim-center id⁂id ⟩
            assocˡ C.∘ assocʳ
          ≈⟨ assocˡ∘assocʳ ⟩
            var
          ∎
          where open TermReasoning

        isoʳ : forall {Γ Δ} -> F₀/*⇒++ C.∘ F₀/++⇒* {Γ = Γ} C.≈ C.id {A = F₀ (Δ ++ Γ)}
        isoʳ {Γ} {[]} = trans comm/fst (trans (cong/fst (var/ext _ _)) (beta/*₁ _ _))
        isoʳ {Γ} {A ∷ Δ} =
          begin
            ((F₀/*⇒++ ⁂ var) C.∘ assocʳ) C.∘ (assocˡ C.∘ (F₀/++⇒* ⁂ var))
          ≈⟨ cancelInner assocʳ∘assocˡ ⟩
            (F₀/*⇒++ ⁂ var) C.∘ (F₀/++⇒* ⁂ var)
          ≈⟨ ⁂∘⁂ ⟩
            F₀/*⇒++ C.∘ F₀/++⇒* ⁂ var C.∘ var
          ≈⟨ ⁂-cong₂ isoʳ C.identity² ⟩
            var ⁂ var
          ≈⟨ id⁂id ⟩
            var
          ∎
          where open TermReasoning

    F₁p : forall {Γ Δ} -> F₀ (Δ ++ Γ) ∷ [] ⊢ F₀ Γ
    F₁p = fst var C.∘ F₀/++⇒*

    F₁q : forall {Γ Δ} -> F₀ (Δ ++ Γ) ∷ [] ⊢ F₀ Δ
    F₁q = snd var C.∘ F₀/++⇒*

    F₁ : forall {Γ Δ : Context} -> ren Γ Δ -> F₀ Γ ∷ [] ⊢ F₀ Δ
    F₁ Renaming.id = C.id
    F₁ (r Renaming.∙ r₁) = F₁ r C.∘ F₁ r₁
    F₁ Renaming.! = unit
    F₁ Renaming.⟪ r , r₁ ⟫ = F₀/*⇒++ C.∘ pair (F₁ r) (F₁ r₁)
    F₁ Renaming.p = F₁p
    F₁ Renaming.q = F₁q

    homomorphism : forall {Γ₁ Γ₂ Γ₃} (f : ren Γ₁ Γ₂) (g : ren Γ₂ Γ₃)
      -> F₀ Γ₁ ∷ [] ⊢ F₁ g [ ext ! (F₁ f) ] ≡ F₁ g [ ext ! (F₁ f) ]
    homomorphism f g = refl

    F-resp-≈ : forall {Γ Δ} {f g : ren Γ Δ} -> f ≐ g -> F₀ Γ ∷ [] ⊢ F₁ f ≡ F₁ g
    F-resp-≈ _≐_.refl = refl
    F-resp-≈ (_≐_.sym x) = sym (F-resp-≈ x)
    F-resp-≈ (_≐_.trans x x₁) = trans (F-resp-≈ x) (F-resp-≈ x₁)
    F-resp-≈ _≐_.identityˡ = var/ext _ _
    F-resp-≈ _≐_.identityʳ = trans (cong/sub (trans (cong/ext !-unique refl) η-pair) refl) sub/id
    F-resp-≈ _≐_.assoc = C.assoc
    F-resp-≈ _≐_.!-unique = eta/Unit _
    F-resp-≈ _≐_.β₁/⟪⟫ = trans (cancelInner (Iso.isoˡ (_≅_.iso F₀/*≅++))) project₁
    F-resp-≈ _≐_.β₂/⟪⟫ = trans (cancelInner (Iso.isoˡ (_≅_.iso F₀/*≅++))) project₂
    F-resp-≈ _≐_.η/⟪⟫ = trans (C.∘-resp-≈ʳ (trans (⟨⟩-cong₂ C.assoc C.assoc) g-η)) (cancelˡ (Iso.isoʳ (_≅_.iso F₀/*≅++)))
    F-resp-≈ (_≐_.cong/∙ x x₁) = cong/sub (cong/ext refl (F-resp-≈ x₁)) (F-resp-≈ x)
    F-resp-≈ (_≐_.cong/⟪⟫ x x₁) = cong/sub (cong/ext refl (cong/pair (F-resp-≈ x) (F-resp-≈ x₁))) refl


module Selective.Examples.Chat where

open import Selective.ActorMonad
open import Selective.Libraries.Call
open import Prelude
  hiding (Maybe)
open import Data.Maybe as Maybe
  hiding (map)
open import Data.Maybe.Categorical as CMaybe

open import Data.List.Properties
open import Category.Monad

open import Debug
open import Data.Nat.Show using (show)

RoomName = ℕ
ClientName = ℕ

ClientInterface : InboxShape
Client-to-Room : InboxShape
Room-to-Client : InboxShape

-- =============
--  JOIN ROOM
-- =============

data JoinRoomSuccess : Set where
  JR-SUCCESS : RoomName → JoinRoomSuccess

data JoinRoomFail : Set where
  JR-FAIL : RoomName → JoinRoomFail

data JoinRoomStatus : Set where
  JRS-SUCCESS JRS-FAIL : RoomName → JoinRoomStatus

JoinRoomSuccessReply : MessageType
JoinRoomSuccessReply = ValueType UniqueTag ∷ ValueType JoinRoomSuccess ∷ [ ReferenceType Client-to-Room ]ˡ

JoinRoomFailReply : MessageType
JoinRoomFailReply = ValueType UniqueTag ∷ [ ValueType JoinRoomFail ]ˡ

JoinRoomReplyInterface : InboxShape
JoinRoomReplyInterface = JoinRoomSuccessReply ∷ JoinRoomFailReply ∷ Room-to-Client

JoinRoom : MessageType
JoinRoom = ValueType UniqueTag ∷ ReferenceType JoinRoomReplyInterface ∷ ValueType RoomName ∷ [ ValueType ClientName ]ˡ

-- =============
--  CREATE ROOM
-- =============

data CreateRoomResult : Set where
  CR-SUCCESS CR-EXISTS : RoomName → CreateRoomResult

CreateRoomReply : MessageType
CreateRoomReply = ValueType UniqueTag ∷ [ ValueType CreateRoomResult ]ˡ

CreateRoom : MessageType
CreateRoom = ValueType UniqueTag ∷ ReferenceType [ CreateRoomReply ]ˡ ∷ [ ValueType RoomName ]ˡ

-- ============
--  LIST ROOMS
-- ============

RoomList : Set
RoomList = List RoomName

ListRoomsReply : MessageType
ListRoomsReply = ValueType UniqueTag ∷ [ ValueType RoomList ]ˡ

ListRooms : MessageType
ListRooms = ValueType UniqueTag ∷ [ ReferenceType [ ListRoomsReply ]ˡ ]ˡ

-- ===
--
-- ===

Client-to-RoomManager : InboxShape
Client-to-RoomManager = JoinRoom ∷ CreateRoom ∷ [ ListRooms ]ˡ

RoomManagerInterface : InboxShape
RoomManagerInterface = Client-to-RoomManager

GetRoomManagerReply : MessageType
GetRoomManagerReply = ValueType UniqueTag ∷ [ ReferenceType RoomManagerInterface ]ˡ

GetRoomManager : MessageType
GetRoomManager = ValueType UniqueTag ∷ [ ReferenceType [ GetRoomManagerReply ]ˡ ]ˡ

RoomSupervisorInterface : InboxShape
RoomSupervisorInterface = [ GetRoomManager ]ˡ

ClientSupervisorInterface : InboxShape
ClientSupervisorInterface =
  [ ReferenceType RoomSupervisorInterface ]ˡ ∷ [ GetRoomManagerReply ]ˡ

--
--
--

record ChatMessageContent : Set where
  constructor chat-from_message:_
  field
    sender : ClientName
    message : String

ChatMessage : MessageType
ChatMessage = [ ValueType ChatMessageContent ]ˡ

LeaveRoom : MessageType
LeaveRoom = [ ValueType ClientName ]ˡ

Client-to-Room = ChatMessage ∷ [ LeaveRoom ]ˡ

Room-to-Client = [ ChatMessage ]ˡ

AddToRoom : MessageType
AddToRoom = ValueType ClientName ∷ [ ReferenceType Room-to-Client ]ˡ

RoomManager-to-Room : InboxShape
RoomManager-to-Room = [ AddToRoom ]ˡ

RoomInstanceInterface : InboxShape
RoomInstanceInterface = Client-to-Room ++ RoomManager-to-Room

ClientInterface = [ ReferenceType RoomManagerInterface ]ˡ ∷ CreateRoomReply ∷ ListRoomsReply ∷ JoinRoomReplyInterface

-- ======
--  ROOM
-- ======

ClientList : Set
ClientList = List ClientName

record RoomState : Set₁ where
  field
    clients : ClientList

cl-to-context : ClientList → TypingContext
cl-to-context = map λ _ → Room-to-Client

rs-to-context : RoomState → TypingContext
rs-to-context rs = let open RoomState
  in cl-to-context (rs .clients)

record RoomLeave (rs : ClientList) (name : ClientName) : Set₁ where
  field
    filtered : ClientList
    subs : (cl-to-context filtered) ⊆ (cl-to-context rs)

++-temp-fix : (l r : ClientList) → (x : ClientName) → (l ++ (x ∷ r)) ≡ ((l ∷ʳ x) ++ r)
++-temp-fix [] r x = refl
++-temp-fix (x₁ ∷ l) r x = cong (_∷_ x₁) (++-temp-fix l r x)

room-instance : ∀ {i} → ActorM i RoomInstanceInterface RoomState [] rs-to-context
room-instance = begin (loop (record { clients = [] }))
  where
    -- only removes first occurance...
    leave-room : (cl : ClientList) → (name : ClientName) → RoomLeave cl name
    leave-room [] name = record { filtered = [] ; subs = [] }
    leave-room (x ∷ cl) name with (x ≟ name)
    ... | (yes _) = record { filtered = cl ; subs = ⊆-suc ⊆-refl }
    ... | (no _) = let
        rl = leave-room cl name
        open RoomLeave
      in record { filtered = x ∷ rl .filtered ; subs = Z ∷ ⊆-suc (rl .subs) }
    send-to-others : ∀ {i} → (cl : ClientList) →
                     ClientName →
                     String →
                     ∞ActorM i RoomInstanceInterface ⊤₁ (cl-to-context cl) (λ _ → cl-to-context cl)
    send-to-others [] _ _ = return _
    send-to-others cl@(_ ∷ _) name message = send-loop [] cl
      where
        build-pointer : (l r : ClientList) →
                      cl-to-context r ⊢ Room-to-Client →
                      (cl-to-context (l ++ r)) ⊢ Room-to-Client
        build-pointer [] r p = p
        build-pointer (x ∷ l) r p = S (build-pointer l r p)
        recurse : ∀ {i} → (l r : ClientList) → (x : ClientName) →
                  ∞ActorM i RoomInstanceInterface ⊤₁ (cl-to-context (l ++ (x ∷ r))) (λ _ → (cl-to-context (l ++ (x ∷ r))))
        send-loop : ∀ {i} → (l r : ClientList) →
          ∞ActorM i RoomInstanceInterface ⊤₁ (cl-to-context (l ++ r)) (λ _ → cl-to-context (l ++ r))
        send-loop l [] = return _
        send-loop l (x ∷ r) with (x ≟ name)
        ... | (yes _) = recurse l r x
        ... | (no _) = let p = build-pointer l (x ∷ r) Z
          in debug ("Sending to " || show x || ": " || message) (p ![t: Z ] [ lift (chat-from name message: message) ]ᵃ ) >> recurse l r x
        recurse l r x rewrite ++-temp-fix l r x = send-loop (l ∷ʳ x) r
    handle-message : ∀ {i} → (rs : RoomState) →
                     (m : Message RoomInstanceInterface) →
                     ∞ActorM i RoomInstanceInterface RoomState (add-references (rs-to-context rs) m) rs-to-context
    -- chat message
    handle-message rs (Msg Z (chat-from client-name message: message ∷ [])) = do
      let open RoomState
      debug ("room sending " || show (pred (length (rs .clients))) ||  " messages from " || show client-name || ": " || message) (send-to-others (rs .clients) client-name message)
      (return₁ rs)
    -- leave room
    handle-message rs (Msg (S Z) (client-name ∷ [])) = do
      let
        open RoomState
        open RoomLeave
        rl = leave-room (rs .clients) client-name
      debug ("client#" || show client-name || " left the room") (strengthen (rl .subs))
      (return₁ (record { clients = rl .filtered }))
    -- add to room
    handle-message rs (Msg (S (S Z)) (client-name ∷ _ ∷ [])) = do
      let open RoomState
      return₁ (record { clients = client-name ∷ rs .clients })
    handle-message rs (Msg (S (S (S ()))) _)
    loop : ∀ {i} →
           (rs : RoomState) →
           ∞ActorM i RoomInstanceInterface RoomState (rs-to-context rs) rs-to-context
    loop state .force = begin do
      m ← debug ("ROOM LOOP") receive
      state' ← (handle-message state m)
      loop state'

-- ==============
--  ROOM MANAGER
-- ==============

record RoomManagerState : Set₁ where
  field
    rooms : RoomList

rms-to-context : RoomManagerState → TypingContext
rms-to-context rms = rl-to-context (rms .rooms)
  where
    open RoomManagerState
    rl-to-context : RoomList → TypingContext
    rl-to-context = map λ _ → RoomInstanceInterface

lookup-room : ∀ {i} → {Γ : TypingContext} →
              (rms : RoomManagerState) →
              RoomName →
              ∞ActorM i RoomManagerInterface (Maybe ((Γ ++ (rms-to-context rms)) ⊢ RoomInstanceInterface)) (Γ ++ (rms-to-context rms)) (λ _ → Γ ++ (rms-to-context rms))
lookup-room rms name =
  let open RoomManagerState
  in return₁ (loop _ (rms .rooms))
  where
    rl-to-context : RoomList → TypingContext
    rl-to-context = map λ _ → RoomInstanceInterface
    loop : (Γ : TypingContext) → (rl : RoomList) → Maybe ((Γ ++ rl-to-context rl) ⊢ RoomInstanceInterface)
    loop [] [] = nothing
    loop [] (x ∷ xs) with (x ≟ name)
    ... | (yes p) = just Z
    ... | (no _) = RawMonad._>>=_ CMaybe.monad (loop [] xs) λ p → just (S p)
    loop (x ∷ Γ) rl = RawMonad._>>=_ CMaybe.monad (loop Γ rl) (λ p → just (S p))

room-manager : ∀ {i} → ActorM i RoomManagerInterface RoomManagerState [] rms-to-context
room-manager = begin (loop (record { rooms = [] }))
  where
    handle-room-join : ∀ {i} → {Γ : TypingContext} →
                        UniqueTag →
                        RoomName →
                        ClientName →
                        (Γ ⊢ JoinRoomReplyInterface) →
                        (Maybe (Γ ⊢ RoomInstanceInterface)) →
                        ∞ActorM i RoomManagerInterface ⊤₁ Γ (λ _ → Γ)
    handle-room-join tag room-name client-name cp (just rp) = do
      cp ![t: Z ] ((lift tag) ∷ (lift (JR-SUCCESS room-name)) ∷ [ [ rp ]>: (Z ∷ [ S Z ]ᵐ) ]ᵃ)
      rp ![t: S (S Z) ] ((lift client-name) ∷ [ [ cp ]>: [ S (S Z) ]ᵐ ]ᵃ)
    handle-room-join tag room-name client-name p nothing =
      p ![t: S Z ] (lift tag ∷ [ lift (JR-FAIL room-name) ]ᵃ)
    handle-create-room : ∀ {i} →
                         (rms : RoomManagerState) →
                         UniqueTag →
                         RoomName →
                         Maybe (([ CreateRoomReply ]ˡ ∷ rms-to-context rms) ⊢ RoomInstanceInterface) →
                         ∞ActorM i RoomManagerInterface RoomManagerState ([ CreateRoomReply ]ˡ ∷ rms-to-context rms) rms-to-context
    handle-create-room rms tag name (just x) = do
      Z ![t: Z ] ((lift tag) ∷ [ lift (CR-EXISTS name) ]ᵃ)
      strengthen (⊆-suc ⊆-refl)
      return₁ rms
    handle-create-room rms tag name nothing = do
      Z ![t: Z ] ((lift tag) ∷ [ lift (CR-SUCCESS name) ]ᵃ)
      strengthen (⊆-suc ⊆-refl)
      spawn room-instance
      let
        rms' : RoomManagerState
        rms' = (record { rooms = name ∷ RoomManagerState.rooms rms })
      (return₁ rms')
    handle-message : ∀ {i} → (rms : RoomManagerState) →
                     (m : Message RoomManagerInterface) →
                     ∞ActorM i RoomManagerInterface RoomManagerState (add-references (rms-to-context rms) m) rms-to-context
    -- Jooin room
    handle-message state (Msg Z (tag ∷ _ ∷ room-name ∷ client-name ∷ [])) = do
      p ← (lookup-room state room-name)
      handle-room-join tag room-name client-name Z p
      (strengthen (⊆-suc ⊆-refl))
      (return₁ state)
    -- Create room
    handle-message state (Msg (S Z) (tag ∷ _ ∷ name ∷ [])) = do
      p ← lookup-room state name
      handle-create-room state tag name p
    -- List rooms
    handle-message state (Msg (S (S Z)) (tag ∷ _ ∷ [])) = do
      (Z ![t: Z ] ((lift tag) ∷ [(lift (RoomManagerState.rooms state) )]ᵃ))
      (strengthen (⊆-suc ⊆-refl))
      (return₁ state)
    handle-message state (Msg (S (S (S ()))) _)
    loop : ∀ {i} →
           (rms : RoomManagerState) →
           ∞ActorM i RoomManagerInterface RoomManagerState (rms-to-context rms) rms-to-context
    loop state .force = begin do
      m ← receive
      state' ← handle-message state m
      loop state'

-- =================
--  ROOM SUPERVISOR
-- =================

rs-context : TypingContext
rs-context = [ RoomManagerInterface ]ˡ

-- room-supervisor spawns the room-manager
-- and provides an interface for getting a reference to the current room-manager
-- we don't ever change that instance, but we could if we want
room-supervisor : ∀ {i} → ActorM i RoomSupervisorInterface ⊤₁ [] (λ _ → rs-context)
room-supervisor = begin do
    (spawn room-manager)
    provide-manager-instance
  where
    provide-manager-instance : ∀ {i} → ∞ActorM i RoomSupervisorInterface ⊤₁ rs-context (λ _ → rs-context)
    provide-manager-instance .force = begin do
      (Msg Z (tag ∷ _ ∷ [])) ← receive
        where (Msg (S ()) _)
      Z ![t: Z ] (lift tag ∷ [ [ S Z ]>: ⊆-refl ]ᵃ)
      (strengthen (⊆-suc ⊆-refl))
      provide-manager-instance

-- ================
--  CLIENT GENERAL
-- ================

busy-wait : ∀ {i IS Γ} → ℕ → ∞ActorM i IS ⊤₁ Γ (λ _ → Γ)
busy-wait zero = return _
busy-wait (suc n) = return tt >> busy-wait n

client-get-room-manager : ∀ {i} → ∞ActorM i ClientInterface ⊤₁ [] (λ _ → [ RoomManagerInterface ]ˡ)
client-get-room-manager = do
  record { msg = Msg Z _} ← (selective-receive (λ {
    (Msg Z x₁) → true
    ; (Msg (S _) _) → false
    }))
    where
      record { msg = (Msg (S _) _) ; msg-ok = ()}
  return _

client-create-room : ∀ {i } →
                     {Γ : TypingContext} →
                     Γ ⊢ RoomManagerInterface →
                     UniqueTag →
                     RoomName →
                     ∞ActorM i ClientInterface (Lift (lsuc lzero) CreateRoomResult) Γ (λ _ → Γ)
client-create-room p tag name = do
  record { msg = (Msg (S Z) (_ ∷ cr ∷ [])) } ← (call p (S Z) tag [ lift name ]ᵃ [ S Z ]ᵐ Z)
    where
      record { msg = (Msg Z (_ ∷ _)) ; msg-ok = () }
      record { msg = (Msg (S (S _)) _) ; msg-ok = () }
  return cr

add-if-join-success : TypingContext →
                      Lift (lsuc lzero) JoinRoomStatus →
                      TypingContext
add-if-join-success Γ (lift (JRS-SUCCESS x)) = Client-to-Room ∷ Γ
add-if-join-success Γ (lift (JRS-FAIL x)) = Γ

client-join-room : ∀ {i Γ} →
                   Γ ⊢ RoomManagerInterface →
                   UniqueTag →
                   RoomName →
                   ClientName →
                   ∞ActorM i ClientInterface (Lift (lsuc lzero) JoinRoomStatus) Γ (add-if-join-success Γ)
client-join-room p tag room-name client-name = do
    self
    S p ![t: Z ] (lift tag ∷ (([ Z ]>: ⊆-suc (⊆-suc (⊆-suc ⊆-refl))) ∷ (lift room-name) ∷ [ lift client-name ]ᵃ))
    (strengthen (⊆-suc ⊆-refl))
    m ← (selective-receive (select-join-reply tag))
    handle-message m
  where
    select-join-reply : UniqueTag → MessageFilter ClientInterface
    select-join-reply tag (Msg Z _) = false
    select-join-reply tag (Msg (S Z) _) = false
    select-join-reply tag (Msg (S (S Z)) _) = false
    select-join-reply tag (Msg (S (S (S Z))) (tag' ∷ _)) = ⌊ tag ≟ tag' ⌋
    select-join-reply tag (Msg (S (S (S (S Z)))) (tag' ∷ _)) = ⌊ tag ≟ tag' ⌋
    select-join-reply tag (Msg (S (S (S (S (S Z))))) x₁) = false
    select-join-reply tag (Msg (S (S (S (S (S (S ())))))) _)
    handle-message : ∀ {tag i Γ} → (m : SelectedMessage (select-join-reply tag)) →
                     ∞ActorM i ClientInterface (Lift (lsuc lzero) JoinRoomStatus)
                       (add-selected-references Γ m) (add-if-join-success Γ)
    handle-message record { msg = (Msg Z _) ; msg-ok = () }
    handle-message record { msg = (Msg (S Z) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S Z)) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S Z))) (_ ∷ JR-SUCCESS room-name ∷ _ ∷ [])) } = return (JRS-SUCCESS room-name)
    handle-message record { msg = (Msg (S (S (S (S Z)))) (_ ∷ JR-FAIL room-name ∷ [])) } = return (JRS-FAIL room-name)
    handle-message record { msg = (Msg (S (S (S (S (S Z))))) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S (S (S (S ())))))) _) }

client-send-message : ∀ {i  Γ} →
                      Γ ⊢ Client-to-Room →
                      ClientName →
                      String →
                      ∞ActorM i ClientInterface ⊤₁ Γ (λ _ → Γ)
client-send-message p client-name message = p ![t: Z ] [ lift (chat-from client-name message: message) ]ᵃ

client-receive-message : ∀ {i Γ} →
                         ∞ActorM i ClientInterface (Lift (lsuc lzero) ChatMessageContent) Γ (λ _ → Γ)
client-receive-message = do
    m ← (selective-receive select-message)
    handle-message m
  where
    select-message : MessageFilter ClientInterface
    select-message (Msg (S (S (S (S (S Z))))) _) = true
    select-message (Msg _ _) = false
    handle-message : ∀ {i Γ} → (m : SelectedMessage select-message) →
                     ∞ActorM i ClientInterface (Lift (lsuc lzero) ChatMessageContent) (add-selected-references Γ m) (λ _ → Γ)
    handle-message record { msg = (Msg Z _) ; msg-ok = () }
    handle-message record { msg = (Msg (S Z) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S Z)) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S Z))) x₁) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S (S Z)))) _) ; msg-ok = () }
    handle-message record { msg = (Msg (S (S (S (S (S Z))))) (m ∷ [])) ; msg-ok = _ } = return m
    handle-message record { msg = (Msg (S (S (S (S (S (S ())))))) _) }

client-leave-room : ∀ {i Γ} →
                    Γ ⊢ Client-to-Room →
                    ClientName →
                    ∞ActorM i ClientInterface ⊤₁ Γ (λ _ → Γ)
client-leave-room p name = p ![t: S Z ] [ lift name ]ᵃ

debug-chat : {a : Level} {A : Set a} → ClientName → ChatMessageContent → A → A
debug-chat client-name content = let open ChatMessageContent
  in debug ("client#" || show client-name || " received \"" || content .message || "\" from client#" || show (content .sender))

-- ==========
--  CLIENT 1
-- ==========

room1-2 = 1
room2-3 = 2
room3-1 = 3
room1-2-3 = 4
name1 = 1

client1 : ∀ {i} → ActorM i ClientInterface ⊤₁ [] (λ _ → [])
client1 = begin do
  client-get-room-manager
  _ ← (client-create-room Z 0 room1-2)
  _ ← (client-create-room Z 1 room3-1)
  _ ← (client-create-room Z 2 room1-2-3)
  lift (JRS-SUCCESS joined-room) ← (client-join-room Z 3 room3-1 name1)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S Z) 4 room1-2 name1)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S (S Z)) 5 room1-2-3 name1)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  busy-wait 100
  (client-send-message (S Z) name1 "hi from 1 to 2")
  (client-send-message Z name1 "hi from 1 to 2-3")
  let open ChatMessageContent
  lift m1 ← client-receive-message
  lift m2 ← debug-chat name1 m1 client-receive-message
  lift m3 ← debug-chat name1 m2 client-receive-message
  debug-chat name1 m3 (client-send-message Z name1 "hi1 from 1 to 2-3")
  (client-send-message Z name1 "hi2 from 1 to 2-3")
  (client-send-message Z name1 "hi3 from 1 to 2-3")
  client-leave-room (S Z) name1
  client-leave-room (Z) name1
  (strengthen [])

-- ==========
--  CLIENT 2
-- ==========

name2 = 2

client2 : ∀ {i} → ActorM i ClientInterface ⊤₁ [] (λ _ → [])
client2 = begin do
  client-get-room-manager
  _ ← (client-create-room Z 0 room1-2)
  _ ← (client-create-room Z 1 room2-3)
  _ ← (client-create-room Z 2 room1-2-3)
  lift (JRS-SUCCESS joined-room) ← (client-join-room Z 3 room1-2 name2)
    where
    (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S Z) 4 room2-3 name2)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S (S Z)) 5 room1-2-3 name2)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  busy-wait 100
  debug "client2 send message" (client-send-message (S Z) name2 "hi from 2 to 3")
  debug "client2 send message" (client-send-message Z name2 "hi from 2 to 1-3")
  let open ChatMessageContent
  lift m1 ← client-receive-message
  lift m2 ← debug-chat name2 m1 client-receive-message
  lift m3 ← debug-chat name2 m2 client-receive-message
  client-leave-room (S Z) name2
  client-leave-room (Z) name2
  debug-chat name2 m3 (strengthen [])

-- ==========
--  CLIENT 3
-- ==========

name3 = 3

client3 : ∀ {i} → ActorM i ClientInterface ⊤₁ [] (λ _ → [])
client3 = begin do
  client-get-room-manager
  _ ← (client-create-room Z 0 room2-3)
  _ ← (client-create-room Z 1 room3-1)
  _ ← (client-create-room Z 2 room1-2-3)
  lift (JRS-SUCCESS joined-room) ← (client-join-room Z 3 room2-3 name3)
    where
    (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S Z) 4 room3-1 name3)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  lift (JRS-SUCCESS joined-room) ← (client-join-room (S (S Z)) 5 room1-2-3 name3)
    where
      (lift (JRS-FAIL failed-room)) → strengthen []
  busy-wait 100
  debug "client3 send message" (client-send-message (S Z) name3 "hi from 3 to 1")
  debug "client3 send message" (client-send-message Z name3 "hi from 3 to 1-2")
  let open ChatMessageContent
  lift m1 ← client-receive-message
  lift m2 ← debug-chat name3 m1 client-receive-message
  lift m3 ← debug-chat name3 m2 client-receive-message
  debug-chat name3 m3 (client-leave-room Z name3)
  client-leave-room (S Z) name3
  client-leave-room Z name3
  (strengthen [])

-- ===================
--  CLIENT SUPERVISOR
-- ===================

cs-context : TypingContext
cs-context = RoomManagerInterface ∷ RoomSupervisorInterface ∷ []

client-supervisor : ∀ {i} → ActorM i ClientSupervisorInterface ⊤₁ [] (λ _ → cs-context)
client-supervisor = begin do
    wait-for-room-supervisor
    (get-room-manager Z 0)
    spawn-clients
  where
    wait-for-room-supervisor : ∀ {i Γ} → ∞ActorM i ClientSupervisorInterface ⊤₁ Γ (λ _ → RoomSupervisorInterface ∷ Γ)
    wait-for-room-supervisor = do
      record { msg = Msg Z f } ← (selective-receive (λ {
        (Msg Z _) → true
        ; (Msg (S _) _) → false
        }))
        where
          record { msg = (Msg (S _) _) ; msg-ok = () }
      return _
    get-room-manager : ∀ {i Γ} →
                     Γ ⊢ RoomSupervisorInterface →
                     UniqueTag →
                      ∞ActorM i ClientSupervisorInterface ⊤₁ Γ (λ _ → RoomManagerInterface ∷ Γ)
    get-room-manager p tag = do
      record { msg = Msg (S Z) (_ ∷  _ ∷ []) } ← (call p Z tag [] (⊆-suc ⊆-refl) Z)
        where
          record { msg = (Msg Z (_ ∷ _)) ; msg-ok = () }
          record { msg = (Msg (S (S ())) _) }
      return _
    spawn-clients : ∀ {i} → ∞ActorM i ClientSupervisorInterface ⊤₁ cs-context (λ _ → cs-context)
    spawn-clients = do
      spawn client1
      Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
      (strengthen (⊆-suc ⊆-refl))
      (spawn client2)
      Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
      (strengthen (⊆-suc ⊆-refl))
      (spawn client3)
      Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
      (strengthen (⊆-suc ⊆-refl))

-- chat-supervisor is the top-most actor
-- it spawns and connects the ClientRegistry to the RoomRegistry
chat-supervisor : ∀ {i} → ∞ActorM i [] ⊤₁ [] (λ _ → [])
chat-supervisor = do
    spawn room-supervisor
    spawn client-supervisor
    Z ![t: Z ] [ [ S Z ]>: ⊆-refl ]ᵃ
    strengthen []


open import MJ.Types
import MJ.Classtable.Core as Core

module MJ.Syntax.Erase {c}(Ct : Core.Classtable c) where

open import Prelude hiding (erase)
open import Data.Maybe as Maybe using (Maybe; just; nothing)
open import Data.Maybe.All as MayAll
open import Data.Vec as Vec hiding (_∈_)
open import Data.Star as Star
open import Data.List.Most as List
open import Data.List.Properties.Extra as List+
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Data.String

import Data.Vec.All as Vec∀

open Core c
open Classtable Ct
open import MJ.Classtable.Membership Ct
open import MJ.Classtable.Code Ct
open import MJ.LexicalScope Ct
open import MJ.Syntax.Typed Ct
open import MJ.Syntax.Program Ct
import MJ.Syntax.Untyped Ct as AST

{-# TERMINATING #-}
erase-expr : ∀ {Γ a} → Expr Γ a → AST.Expr (length Γ)
erase-expr (new C x) = AST.new C (List.erase erase-expr x)
erase-expr unit = AST.unit
erase-expr null = AST.null
erase-expr (num x) = AST.num x
erase-expr (iop x e e₁) = AST.iop x (erase-expr e) (erase-expr e₁)
erase-expr (call e m x) = AST.call (erase-expr e) m (List.erase erase-expr x)
erase-expr (var x) = AST.var (index x)
erase-expr (get e f) = AST.get (erase-expr e) f
erase-expr (upcast s e) = erase-expr e

mutual
  erase-stmt : ∀ {I r O} → Stmt I r O → AST.Stmt (length I) (length O)
  erase-stmt (loc a) = AST.loc a
  erase-stmt (asgn x e) = AST.asgn (index x) (erase-expr e)
  erase-stmt (set x f e) = AST.set (erase-expr x) f (erase-expr e)
  erase-stmt (do x) = AST.do (erase-expr x)
  erase-stmt (ret x) = AST.ret (erase-expr x)
  erase-stmt raise = AST.raise
  erase-stmt (try s catch s₁) = AST.try erase-stmt s catch erase-stmt s₁
  erase-stmt (while x do s) = AST.while erase-expr x do erase-stmt s
  erase-stmt (block x) = AST.block (erase-stmts x)

  -- this is an instance of Star.gmap, but the higher order version
  -- fails to pass the termination checker
  erase-stmts : ∀ {I r O} → Stmts I r O → AST.Stmts (length I) (length O)
  erase-stmts ε = ε
  erase-stmts (x ◅ st) = erase-stmt x ◅ erase-stmts st

erase-body : ∀ {I a} → Body I a → AST.Body (length I)
erase-body (body s* e) = AST.body (erase-stmts s*) (erase-expr e)

erase-constructor : ∀ {cid} → Constructor cid → AST.Constructor (length (Class.constr (Σ cid)))
erase-constructor (super args then b) = AST.super (List.erase erase-expr args) then (erase-body b)
erase-constructor (body x) = AST.body (erase-body x)

erase-method : ∀ {cid m as b} → Method cid m (as , b) → AST.Method (length as)
erase-method (super _ ⟨ args ⟩then b) = AST.super⟨ List.erase erase-expr args ⟩then (erase-body b)
erase-method (body x) = AST.body (erase-body x)

erase-implementation : ∀ {cid} → Implementation cid → AST.Implementation cid
erase-implementation (implementation construct mbodies) =
  AST.implementation (erase-constructor construct) (map-all erase-method mbodies)

erase-prog : ∀ {a} → Prog a → AST.Prog
erase-prog (ℂ , b) = (λ cid → erase-implementation (ℂ cid)) , erase-body b


{-

Groupoid quotients:

-}

{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.GroupoidQuotients.Properties where

open import Cubical.HITs.GroupoidQuotients.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Univalence

open import Cubical.Data.Sigma

open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary.Base

open import Cubical.HITs.PropositionalTruncation as PropTrunc using (∥_∥; ∣_∣; squash)
open import Cubical.HITs.SetTruncation as SetTrunc using (∥_∥₂; ∣_∣₂; squash₂)

-- Type quotients

private
  variable
    ℓA ℓR ℓ : Level
    A : Type ℓA
    R : A → A → Type ℓR
--    B : A // Rt → Type ℓ
--    C : A // Rt → A // Rt → Type ℓ

elimEq// : (Rt : BinaryRelation.isTrans R)
          {B : A // Rt → Type ℓ}
          (Bprop : (x : A // Rt) → isProp (B x))
          {x y : A // Rt}
          (eq : x ≡ y)
          (bx : B x)
          (by : B y) →
          PathP (λ i → B (eq i)) bx by
elimEq// Rt {B} Bprop {x = x} =
  J (λ y eq → ∀ bx by → PathP (λ i → B (eq i)) bx by) (λ bx by → Bprop x bx by)

elimProp : (Rt : BinaryRelation.isTrans R)
         → {B : A // Rt → Type ℓ}
         → ((x : A // Rt) → isProp (B x))
         → ((a : A) → B [ a ])
         → (x : A // Rt)
         → B x
elimProp Rt Bprop f [ x ] = f x
elimProp Rt Bprop f (eq// {a} {b} r i) = elimEq// Rt Bprop (eq// r) (f a) (f b) i
elimProp Rt Bprop f (comp// {a} {b} {c} r s i j) =
  isSet→isSetDep (λ x → isProp→isSet (Bprop x))
  (eq// r) (eq// (Rt a b c r s)) (λ j → [ a ]) (eq// s) (comp// r s)
  (λ i → elimEq// Rt Bprop (eq// r) (f a) (f b) i)
  (λ i → elimEq// Rt Bprop (eq// (Rt a b c r s)) (f a) (f c) i)
  (λ j → f a ) (λ j → elimEq// Rt Bprop (eq// s) (f b) (f c) j) i j
elimProp Rt Bprop f (squash// x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 (λ x → isSet→isGroupoid (isProp→isSet (Bprop x)))
  _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (squash// x y p q r s) i j k
  where
    g = elimProp Rt Bprop f

elimProp2 : (Rt : BinaryRelation.isTrans R)
          → {C : A // Rt → A // Rt → Type ℓ}
         → ((x y : A // Rt) → isProp (C x y))
         → ((a b : A) → C [ a ] [ b ])
         → (x y : A // Rt)
         → C x y
elimProp2 Rt Cprop f = elimProp Rt (λ x → isPropΠ (λ y → Cprop x y))
                                   (λ x → elimProp Rt (λ y → Cprop [ x ] y) (f x))

[]surjective : (Rt : BinaryRelation.isTrans R)
               → (x : A // Rt ) → ∃[ a ∈ A ] [ a ] ≡ x
[]surjective Rt = elimProp Rt (λ x → squash) (λ a → ∣ a , refl ∣)

elimSet : (Rt : BinaryRelation.isTrans R)
     → {B : A // Rt → Type ℓ}
     → ((x : A // Rt) → isSet (B x))
     → (f : (a : A) → B [ a ])
     → ({a b : A} (r : R a b) → PathP (λ i → B (eq// r i)) (f a) (f b))
     → (x : A // Rt)
     → B x
elimSet Rt Bset f feq [ a ] = f a
elimSet Rt Bset f feq (eq// r i) = feq r i
elimSet Rt Bset f feq (comp// {a} {b} {c} r s i j) =
  isSet→isSetDep Bset (eq// r) (eq// (Rt a b c r s)) (λ j → [ a ]) (eq// s) (comp// r s)
  (feq r) (feq (Rt a b c r s)) refl (feq s) i j
elimSet Rt Bset f feq (squash// x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 (λ x → isSet→isGroupoid (Bset x))
    _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (squash// x y p q r s) i j k
  where
    g = elimSet Rt Bset f feq

elim : (Rt : BinaryRelation.isTrans R)
     → {B : A // Rt → Type ℓ}
     → ((x : A // Rt) → isGroupoid (B x))
     → (f : (a : A) → B [ a ])
     → (feq : {a b : A} (r : R a b) → PathP (λ i → B (eq// r i)) (f a) (f b))
     → ({a b c : A} (r : R a b) (s : R b c)
           → SquareP (λ i j → B (comp// r s i j))
           (feq r) (feq (Rt a b c r s)) (λ j → f a) (feq s))
     → (x : A // Rt)
     → B x
elim Rt Bgpd f feq fcomp [ a ] = f a
elim Rt Bgpd f feq fcomp (eq// r i) = feq r i
elim Rt Bgpd f feq fcomp (comp// r s i j) = fcomp r s i j
elim Rt Bgpd f feq fcomp (squash// x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 Bgpd
    _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (squash// x y p q r s) i j k
  where
    g = elim Rt Bgpd f feq fcomp

rec : (Rt : BinaryRelation.isTrans R)
    → {B : Type ℓ}
    → isGroupoid B
    → (f : A → B)
    → (feq : {a b : A} (r : R a b) → f a ≡ f b)
    → ({a b c : A} (r : R a b) (s : R b c)
          → Square (feq r) (feq (Rt a b c r s)) refl (feq s))
    → (x : A // Rt)
    → B
rec Rt Bgpd = elim Rt (λ _ → Bgpd)

module BinarySetRelation {ℓA ℓR : Level} {A : Type ℓA} (R : Rel A A ℓR) where
  open BinaryRelation R

  isSetValued : Type (ℓ-max ℓA ℓR)
  isSetValued = (a b : A) → isSet (R a b)


module IID-Proof-Setup where

open import LF
open import Identity
open import IID
open import IIDr
open import DefinitionalEquality

OPg : Set -> Set1
OPg I = OP I I

-- Encoding indexed inductive types as non-indexed types.
ε : {I : Set}(γ : OPg I) -> OPr I
ε (ι i)     j = σ (i == j) (\_ -> ι ★)
ε (σ A γ)   j = σ A (\a -> ε (γ a) j)
ε (δ H i γ) j = δ H i (ε γ j)

-- Adds a reflexivity proof.
g→rArgs : {I : Set}(γ : OPg I)(U : I -> Set)
	      (a : Args γ U) ->
	      rArgs (ε γ) U (index γ U a)
g→rArgs (ι e)     U arg	= (refl , ★)
g→rArgs (σ A γ)   U arg = (π₀ arg , g→rArgs (γ (π₀ arg)) U (π₁ arg))
g→rArgs (δ H i γ) U arg = (π₀ arg , g→rArgs γ U (π₁ arg))

-- Strips the equality proof.
r→gArgs : {I : Set}(γ : OPg I)(U : I -> Set)
	      (i : I)(a : rArgs (ε γ) U i) ->
	      Args γ U
r→gArgs (ι i)     U j _	  = ★
r→gArgs (σ A γ)   U j arg = (π₀ arg , r→gArgs (γ (π₀ arg)) U j (π₁ arg))
r→gArgs (δ H i γ) U j arg = (π₀ arg , r→gArgs γ U j (π₁ arg))

-- Converting an rArgs to a gArgs and back is (provably, not definitionally)
-- the identity.
r←→gArgs-subst :
  {I : Set}(γ : OPg I)(U : I -> Set)
  (C : (i : I) -> rArgs (ε γ) U i -> Set)
  (i : I)(a : rArgs (ε γ) U i) ->
  (C (index γ U (r→gArgs γ U i a))
     (g→rArgs γ U (r→gArgs γ U i a))
  ) -> C i a

r←→gArgs-subst {I} (ι i) U C j arg m =
  elim== i (\k q -> C k (q , ★)) m j (π₀ arg)

r←→gArgs-subst (σ A γ)   U C j arg m =
  r←→gArgs-subst (γ (π₀ arg)) U (\i c -> C i (π₀ arg , c)) j (π₁ arg) m

r←→gArgs-subst (δ H i γ) U C j arg m =
  r←→gArgs-subst γ U (\i c -> C i (π₀ arg , c)) j (π₁ arg) m

-- r←→gArgs-subst eliminates the identity proof stored in the rArgs. If this proof is
-- by reflexivity r←→gArgs-subst is a definitional identity. This is the case
-- when a = g→rArgs a'
r←→gArgs-subst-identity :
  {I  : Set}(γ : OPg I)(U : I -> Set)
  (C  : (i : I) -> rArgs (ε γ) U i -> Set)
  (a' : Args γ U) ->
  let a = g→rArgs γ U a'
      i = index γ U a' in
  (h : C (index γ U (r→gArgs γ U i a))
	 (g→rArgs γ U (r→gArgs γ U i a))
  ) -> r←→gArgs-subst γ U C i a h ≡ h
r←→gArgs-subst-identity (ι i)	  U C _   h = refl-≡
r←→gArgs-subst-identity (σ A γ)	  U C arg h = r←→gArgs-subst-identity (γ (π₀ arg)) U C' (π₁ arg) h
  where C' = \i c -> C i (π₀ arg , c)
r←→gArgs-subst-identity (δ H i γ) U C arg h = r←→gArgs-subst-identity γ U C' (π₁ arg) h
  where C' = \i c -> C i (π₀ arg , c)

-- Going the other way around is definitionally the identity.
g←→rArgs-identity :
  {I : Set}(γ : OPg I)(U : I -> Set)
  (a : Args γ U) ->
  r→gArgs γ U (index γ U a) (g→rArgs γ U a) ≡ a
g←→rArgs-identity (ι i)	    U _	  = refl-≡
g←→rArgs-identity (σ A γ)   U arg = cong-≡ (\ ∙ -> (π₀ arg , ∙)) (g←→rArgs-identity (γ (π₀ arg)) U (π₁ arg))
g←→rArgs-identity (δ H i γ) U arg = cong-≡ (\ ∙ -> (π₀ arg , ∙)) (g←→rArgs-identity γ U (π₁ arg))

-- Corresponding conversion functions for assumptions to inductive occurrences.
-- Basically an identity function.
g→rIndArg : {I : Set}(γ : OPg I)(U : I -> Set)
        (i : I)(a : rArgs (ε γ) U i) ->
        IndArg γ U (r→gArgs γ U i a) -> IndArg (ε γ i) U a
g→rIndArg (ι j)	    U i _ ()
g→rIndArg (σ A γ)   U i arg v       = g→rIndArg (γ (π₀ arg)) U i (π₁ arg) v
g→rIndArg (δ A j γ) U i arg (inl a) = inl a
g→rIndArg (δ A j γ) U i arg (inr v) = inr (g→rIndArg γ U i (π₁ arg) v)

-- Basically we can substitute general inductive occurences for the encoded
-- restricted inductive occurrences.
g→rIndArg-subst :
    {I : Set}(γ : OPg I)(U : I -> Set)
    (C : (i : I) -> U i -> Set)
    (i : I)(a : rArgs (ε γ) U i)
    (v : IndArg γ U (r→gArgs γ U i a)) ->
    C (IndIndex (ε γ i) U a (g→rIndArg γ U i a v))
      (Ind	(ε γ i) U a (g→rIndArg γ U i a v)) ->
    C (IndIndex γ U (r→gArgs γ U i a) v)
      (Ind	γ U (r→gArgs γ U i a) v)
g→rIndArg-subst (ι j)	  U C i _ ()	    h
g→rIndArg-subst (σ A γ)	  U C i arg v	    h = g→rIndArg-subst (γ (π₀ arg)) U C i (π₁ arg) v h
g→rIndArg-subst (δ A j γ) U C i arg (inl a) h = h
g→rIndArg-subst (δ A j γ) U C i arg (inr v) h = g→rIndArg-subst γ U C i (π₁ arg) v h

-- g→rIndArg-subst is purely book-keeping. On the object level it's definitional identity.
g→rIndArg-subst-identity :
    {I : Set}(γ : OPg I)(U : I -> Set)
    (C : (i : I) -> U i -> Set)
    (i : I)(a : rArgs (ε γ) U i)
    (v : IndArg γ U (r→gArgs γ U i a))
    (h : C (IndIndex (ε γ i) U a (g→rIndArg γ U i a v))
	   (Ind	(ε γ i) U a (g→rIndArg γ U i a v))
    ) -> g→rIndArg-subst γ U C i a v h ≡ h
g→rIndArg-subst-identity (ι j)	   U C i _   ()	   h
g→rIndArg-subst-identity (σ A γ)   U C i arg v	   h =
  g→rIndArg-subst-identity (γ (π₀ arg)) U C i (π₁ arg) v h
g→rIndArg-subst-identity (δ A j γ) U C i arg (inl a) h = refl-≡
g→rIndArg-subst-identity (δ A j γ) U C i arg (inr v) h =
  g→rIndArg-subst-identity γ U C i (π₁ arg) v h

-- And finally conversion of induction hypotheses. This goes the other direction.
r→gIndHyp :
    {I : Set}(γ : OPg I)(U : I -> Set)
    (C : (i : I) -> U i -> Set)
    (i : I)(a : rArgs (ε γ) U i) ->
    IndHyp (ε γ i) U C a -> IndHyp γ U C (r→gArgs γ U i a)
r→gIndHyp γ U C i a h v = g→rIndArg-subst γ U C i a v (h (g→rIndArg γ U i a v))


{- 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
-}

open import LibraBFT.Base.Types
open import LibraBFT.Concrete.Records
open import LibraBFT.Impl.Consensus.Network
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.NetworkMsg
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.Network.Properties where

open Invariants

module processProposalSpec (proposal : ProposalMsg) (myEpoch : Epoch) (vv : ValidatorVerifier) where
  postulate -- TODO-2: Refine contract
    -- We also need to know that the the proposal message was successfully
    -- checked by `ProposalMsg.verify`
    contract
      : case (processProposal proposal myEpoch vv) of λ where
          (Left _) → Unit
          (Right _) → proposal ^∙ pmProposal ∙ bEpoch ≡ myEpoch
                      × BlockId-correct (proposal ^∙ pmProposal)


module GUIgeneric.GUI  where

open import GUIgeneric.Prelude
open import GUIgeneric.GUIDefinitions

Frame : Set
Frame  = ComponentEls frame

logOn : Bool
logOn = true

log : {A : Set} → String → (f : Unit → IO GuiLev1Interface ∞ A) →
         IO GuiLev1Interface ∞ A
log s f = if logOn then (do (putStrLn s) λ x → f x) else f unit

module _ where
  FFIcomponents : {c : Component}(e :  ComponentEls c) → Set
  FFIcomponents {c} (add i e e' _) = FFIcomponents e × FFIcomponents e'
  FFIcomponents {frame} (createC tt) = FFIFrame
  FFIcomponents {atomicComp} (createC (button x)) = FFIButton
  FFIcomponents {atomicComp} (createC (txtbox y)) = FFITextCtrl

  ffiComponentsToFrame : (e : ComponentEls frame)(ffi : FFIcomponents e) → FFIFrame
  ffiComponentsToFrame (createC x) ffi = ffi
  ffiComponentsToFrame (add c'c e e₁ _) (ffie , ffie₁) = ffiComponentsToFrame e₁ ffie₁

  FFIcomponentsReduce : {c c' : Component}(e : ComponentEls c)(e' : ComponentEls c')
                      (ee' : e <c e')
                      (ff1 : FFIcomponents e')
                       → FFIcomponents e
  FFIcomponentsReduce e (add i .e e'' _) (addsub i' .e .e'' _) ffi1 = proj₁ ffi1
  FFIcomponentsReduce e (add i e' .e _) (addlift i' .e' .e _) ffi1 = proj₂ ffi1

  FFIcomponentsReduce+ : {c c' : Component}(e : ComponentEls c)(e' : ComponentEls c')
                      (ee' : e <=c+ e')
                      (ffi : FFIcomponents e')
                       → FFIcomponents e
  FFIcomponentsReduce+ e .e (in0= .e) ffi1 = ffi1
  FFIcomponentsReduce+ e e' (in2= .e e'₁ .e' x ee') ffi1 =
    FFIcomponentsReduce e e'₁ x (FFIcomponentsReduce+ e'₁ e' ee' ffi1)

  data SemiDec (A : Frame → Set) : Set where
    isEmpty     : ((f : Frame) → A f → ⊥) → SemiDec A
    posNonEmpty : SemiDec A

  data MethodsStruct : Set where
      fficom : MethodsStruct
      ⊥^     : MethodsStruct
      _⊎^_   : (m m' : MethodsStruct) → MethodsStruct
      _⊎^unoptimized_   : (m m' : MethodsStruct) → MethodsStruct

  mutual

    methodsStruct2Method : (g : Frame)(m : MethodsStruct)  → Set
    methodsStruct2Method g fficom = FFIcomponents g
    methodsStruct2Method g ⊥^ = ⊥
    methodsStruct2Method g (m ⊎^ m₁) = methodsStruct2Methodaux g m m₁
                                        (methodsUnivIsEmpty  m)
                                        (methodsUnivIsEmpty  m₁)
    methodsStruct2Method g (m ⊎^unoptimized m₁) = methodsStruct2Method g m ⊎ methodsStruct2Method g m₁

    methodsStruct2Methodaux :  (g : Frame) (m m' : MethodsStruct)
                           (s  : SemiDec (λ g → methodsStruct2Method g m))
                           (s' : SemiDec (λ g → methodsStruct2Method g m'))
                           → Set
    methodsStruct2Methodaux g m m' s (isEmpty s') = methodsStruct2Method g m
    methodsStruct2Methodaux g m m' (isEmpty x) posNonEmpty = methodsStruct2Method g m'
    methodsStruct2Methodaux g m m' posNonEmpty posNonEmpty = methodsStruct2Method g m ⊎ methodsStruct2Method g m'

    methodsUnivIsEmpty : (m : MethodsStruct) → SemiDec (λ g → methodsStruct2Method g m)
    methodsUnivIsEmpty  fficom = posNonEmpty
    methodsUnivIsEmpty  ⊥^ = isEmpty (λ g → λ ())
    methodsUnivIsEmpty  (m ⊎^ m₁) =
                methodsUnivIsEmptyaux  m m₁
                  (methodsUnivIsEmpty   m)
                  (methodsUnivIsEmpty  m₁)
    methodsUnivIsEmpty  (m ⊎^unoptimized m₁) = posNonEmpty

    methodsUnivIsEmptyaux :  (m m' : MethodsStruct)
                           (s  : SemiDec (λ g → methodsStruct2Method g m ))
                           (s' : SemiDec (λ g → methodsStruct2Method g m' ))
                           → SemiDec (λ g → methodsStruct2Methodaux g m m' s s')
    methodsUnivIsEmptyaux  m m' s (isEmpty s') = s
    methodsUnivIsEmptyaux  m m' (isEmpty x) posNonEmpty = posNonEmpty
    methodsUnivIsEmptyaux  m m' posNonEmpty posNonEmpty = posNonEmpty

  inj₁MUaux : (g : Frame) (m m' : MethodsStruct)
                   (s  : SemiDec (λ g → methodsStruct2Method g m ))
                   (s'  : SemiDec (λ g → methodsStruct2Method g m' ))
                   (u : methodsStruct2Method g m)
                   → methodsStruct2Methodaux g m m' s s'
  inj₁MUaux g m m' s (isEmpty x) u = u
  inj₁MUaux g m m' (isEmpty x) posNonEmpty u = ⊥-elim (x g u)
  inj₁MUaux g m m' posNonEmpty posNonEmpty u = inj₁ u

  inj₁MUoptimized : (g : Frame) (m m' : MethodsStruct)(u : methodsStruct2Method g m )-- (isOpt : Bool)
                   → methodsStruct2Method g (m ⊎^ m') --isOpt
  inj₁MUoptimized g m m' u = inj₁MUaux g m m'
                         (methodsUnivIsEmpty  m)
                         (methodsUnivIsEmpty  m') u

  inj₁MUUnoptimized : (g : Frame) (m m' : MethodsStruct)(u : methodsStruct2Method g m )-- (isOpt : Bool)
                   → methodsStruct2Method g (m ⊎^unoptimized m') --isOpt
  inj₁MUUnoptimized g m m' u = inj₁ u

  inj₂MUaux : (g : Frame) (m m' : MethodsStruct)
                   (s  : SemiDec (λ g → methodsStruct2Method g m))
                   (s'  : SemiDec (λ g → methodsStruct2Method g m' ))
                   (u : methodsStruct2Method g m')
                   → methodsStruct2Methodaux g m m' s s'
  inj₂MUaux g m m' s (isEmpty x) u = ⊥-elim (x g u)
  inj₂MUaux g m m' (isEmpty x) posNonEmpty u = u
  inj₂MUaux g m m' posNonEmpty posNonEmpty u = inj₂ u

  inj₂MUoptimized : (g : Frame) (m m' : MethodsStruct)(u : methodsStruct2Method g m' )
                   → methodsStruct2Method g (m ⊎^ m') --isOpt
  inj₂MUoptimized g m m' u = inj₂MUaux g m m'
                         (methodsUnivIsEmpty  m)
                         (methodsUnivIsEmpty  m') u

  inj₂MUUnoptimized : (g : Frame) (m m' : MethodsStruct)(u : methodsStruct2Method g m' )
                   → methodsStruct2Method g (m ⊎^unoptimized m') --isOpt
  inj₂MUUnoptimized g m m' u = inj₂ u

  methodStruct : {c : Component}(e : ComponentEls c) → MethodsStruct
  methodStruct (add c'c x x₁ optimized) = methodStruct x  ⊎^ methodStruct x₁
  methodStruct (add c'c x x₁ notOptimized) = methodStruct x  ⊎^unoptimized methodStruct x₁
  methodStruct {atomicComp} (createC (button s)) = fficom
  methodStruct {atomicComp} (createC (txtbox s)) = ⊥^
  methodStruct _  = ⊥^

  methods : {c : Component}(e : ComponentEls c)(g : Frame) → Set
  methods e g =  methodsStruct2Method g (methodStruct e)

  methodsG : (g : Frame) → Set
  methodsG g =  methods g g

  methodLift : {c c'' : Component}(e : ComponentEls c)(e'₁ : ComponentEls c'')
               (g : Frame) (x : e <c e'₁)  (m : methods e g )
                → methods e'₁ g
  methodLift e .(add i e e₁ optimized) g (addsub i .e e₁ optimized) m =
                 inj₁MUoptimized g
                   (methodStruct e)
                   (methodStruct e₁)
                m
  methodLift e .(add i e e₁ notOptimzed) g (addsub i .e e₁ notOptimzed) m =
               inj₁MUUnoptimized g
                   (methodStruct e)
                   (methodStruct e₁)
                m

  methodLift e .(add i e'₂ e optimized) g (addlift i e'₂ .e optimized) m =
                 inj₂MUoptimized g
                    (methodStruct e'₂)
                    (methodStruct e)
                 m

  methodLift e .(add i e'₂ e notOptimzed) g (addlift i e'₂ .e notOptimzed) m =
                inj₂MUUnoptimized g
                    (methodStruct e'₂)
                    (methodStruct e)
                 m

  methodLift+ : {c c' : Component}(e : ComponentEls c)(e' : ComponentEls c')
                (g : Frame)(ee' : e <=c+ e')
                (m : methods e g)
                → methods e' g
  methodLift+ e .e g (in0= .e) m = m
  methodLift+ e e' g (in2= .e e'₁ .e' x ee'') m =
    methodLift+ e'₁ e' g ee'' (methodLift e e'₁ g x m)

data returnType (f : Frame) : Set where
    noChange           :  returnType f
    changedAttributes  :  properties f  →  returnType f
    changedGUI
      :  (fNew : Frame)  →  (properties fNew) → returnType f

nextStateFrame : (f : Frame)(r : returnType f) → Frame
nextStateFrame f noChange = f
nextStateFrame f (changedAttributes x) = f
nextStateFrame f (changedGUI fNew x) = fNew

handlerInterface : Interfaceˢ
handlerInterface .Stateˢ       = Frame
handlerInterface .Methodˢ f    = methodsG f
handlerInterface .Resultˢ f m  = returnType f
handlerInterface .nextˢ f m r  = nextStateFrame f r

HandlerObject : ∀ i → Frame → Set
HandlerObject i g =
  IOObjectˢ  GuiLev1Interface  handlerInterface i g

StateAndGuiObj : Set
StateAndGuiObj = Σ[ g ∈ Frame ] (properties g) × (HandlerObject ∞ g)

StateAndFFIComp : Set
StateAndFFIComp = Σ[ g ∈ Frame ] FFIcomponents g

--
-- Step 3 : create object of type HandlerObject
--

SingleMVar : {A : Set} → (mvar : MVar A) → VarList
SingleMVar {A} mvar = addVar mvar []

initHandlerMVar : (l : VarList) (g : Frame)
                     (a : properties g)
                     (f : HandlerObject ∞ g)
              → IOˢ GuiLev2Interface ∞
                    (λ s → Σ[ mvar ∈ MVar StateAndGuiObj ]
                    s ≡ addVar mvar l  ) l
initHandlerMVar l g a f = doˢ (createVar {_}{StateAndGuiObj} (g , a , f)) λ mvar →
                         returnˢ (mvar , refl)

initFFIMVar : (g : Frame)
              → (comp : (FFIcomponents g))
              → IOˢ GuiLev2Interface ∞
                    (λ s → Σ[ mvar ∈ MVar StateAndFFIComp ]
                    s ≡ SingleMVar mvar  ) []
initFFIMVar g comp = doˢ (createVar {_}{StateAndFFIComp} (g , comp)) λ mvar →
                        returnˢ (mvar , refl)

module _ where
  frameToEnclosing : (e : ComponentEls frame)(ffi : FFIcomponents e) → FFIFrame
  frameToEnclosing (createC x) ffi = ffi
  frameToEnclosing (add i e e₁ _) (proj₃ , proj₄) = frameToEnclosing e₁ proj₄

  componentToEnclosingIndex : (c : Component) → Set
  componentToEnclosingIndex frame = ⊥
  componentToEnclosingIndex atomicComp = ⊤

  componentToEnclosings : (c : Component)(i : componentToEnclosingIndex c) → Set
  componentToEnclosings frame ()
  componentToEnclosings atomicComp tt = FFIFrame

  createComp : {c : Component}{s : GuiLev2State}(e : ComponentEls c)
                    (enclosings : (i : componentToEnclosingIndex c) → componentToEnclosings c i)
                        → (existingFrame : Maybe FFIFrame) → IOₚˢ GuiLev2Interface ∞ (FFIcomponents e) s s

  createComp {frame} (createC fr) enc (just ffiFrame) = returnˢ (refl , ffiFrame)
  createComp {frame} (createC fr) enc nothing =
     doˢ (level1C createWxFrame) λ frFFI → returnˢ (refl , frFFI)

  createComp {frame} (add buttonFrame e frameEl _) enc maybeFr =
      createComp frameEl enc maybeFr >>=ₚˢ λ frameComp →
      createComp e (λ x → frameToEnclosing frameEl frameComp) maybeFr >>=ₚˢ λ buttonComp →
      returnˢ (refl , buttonComp , frameComp)
  createComp {atomicComp} (createC (button x)) enc maybeFr =
    doˢ (level1C (createButton (enc tt) x)) λ bt →
    returnˢ (refl , bt)

  createComp {atomicComp} (createC (txtbox x)) enc maybeFr =
    doˢ (level1C (createTextCtrl (enc tt) x)) λ txt →
    returnˢ (refl , txt)

  createComp {atomicComp} (add () e e₁ _) x y

  createFrame : (g : Frame) → IOₚˢ GuiLev2Interface ∞ (FFIcomponents g) [] []
  createFrame g = createComp {frame} g (λ x → ⊥-elim x) nothing

  reCreateFrame : {s : GuiLev2State}(g : Frame)(f : FFIFrame) → IOₚˢ GuiLev2Interface ∞ (FFIcomponents g) s s
  reCreateFrame g fr = createComp {frame} g (λ x → ⊥-elim x) (just fr)

module _ where
  ButtonComp : Set
  ButtonComp = ComponentEls atomicComp

  button2Frame : (bt  : ButtonComp)(g   : Frame)(ffi : FFIcomponents g)
               (rel : bt <=c+ g) → FFIFrame
  button2Frame bt g ffi (in2= {c' = frame} .bt .(add c'c bt e _) .g (addsub c'c .bt e _) rel) = ffiComponentsToFrame e (FFIcomponentsReduce+ e g aux ffi)
                       where
                            aux : e <=c+ g
                            aux = in2= e (add c'c bt e _) g (addlift c'c bt e _) rel
  button2Frame bt g ffi (in2= {c' = atomicComp} .bt .(add _ bt e _) .g (addsub () .bt e _) rel)
  button2Frame bt g ffi (in2= .bt .(add _ e'₁ bt _) .g (addlift {frame} () e'₁ .bt _) (in2= .(add _ e'₁ bt _) e' .g x rel))
  button2Frame bt g ffi (in2= .bt .(add _ e'₁ bt _) .g (addlift {atomicComp} () e'₁ .bt _) (in2= .(add _ e'₁ bt _) e' .g x rel))

  buttonHandleraux2 : ∀{i} → (bt  : ButtonComp)
                         (g   : Frame)
                         (ffi : FFIcomponents g)
                         (rel : bt <=c+ g)
                         (m   : methods bt g)
                         (a  : properties g)
                         (obj : HandlerObject ∞ g)
                         (r    : returnType g)
                         (obj' : IOObjectˢ GuiLev1Interface handlerInterface ∞
                                (nextStateFrame g r))
                         → IO GuiLev1Interface i StateAndGuiObj
  buttonHandleraux2 bt g ffi rel m a obj noChange obj' = return (g , a , obj')
  buttonHandleraux2 bt g ffi rel m a obj (changedAttributes a') obj' =
                    log "Changing Attributes Directly" λ _ →
                    return (g , a' , obj')
  buttonHandleraux2 (createC x) g ffi rel m a obj (changedGUI gNew a') obj' =
                    log "Firing GUI change ----> SEND FIRE" λ _ →
                    do (fireCustomEvent (button2Frame (createC x) g ffi rel)) λ _ →
                    return (gNew , a' , obj')

  buttonHandleraux2 (add () bt bt₁ _) g ffi rel m a obj (changedGUI gNew a') obj'

  buttonHandleraux : ∀{i} → (bt  : ButtonComp)
                         (g   : Frame)
                         (ffi : FFIcomponents g)
                         (rel : bt <=c+ g)
                         (m   : methods bt g)
                         (gNew  : Frame)
                         (a  : properties gNew)
                         (obj : HandlerObject ∞ gNew)
                         (dec : Dec (g ≡ gNew))
                         → IO GuiLev1Interface i StateAndGuiObj
  buttonHandleraux bt g ffi rel m .g a obj (Dec.yes refl)
               = method obj (methodLift+ bt g g  rel m) >>= λ { (r , obj') →
                 buttonHandleraux2 bt g ffi rel m a obj r obj'}
  buttonHandleraux bt g ffi rel m gNew a obj (Dec.no ¬p)
              = log "ERROR: button handler is called for wrong GUI !!" λ _ →
                return (gNew , a , obj)

  buttonHandler : ∀{i} → (bt  : ButtonComp)
                         (g   : Frame)
                         (ffi : FFIcomponents g)
                         (rel : bt <=c+ g)
                         (m   : methods bt g)
                         (obj : StateAndGuiObj)
                         → IO GuiLev1Interface i StateAndGuiObj
  buttonHandler {i} bt g ffi rel m (gNew , a , obj) = buttonHandleraux {i} bt g ffi rel m gNew a obj (g ≟Comp gNew)

  setHandler : ∀{i} → (c : Component)
                      (cels : ComponentEls c)
                      (g : Frame)
                      (ffiComp : FFIcomponents g)
                      (rel : cels <=c+ g)
                      (mvar : MVar StateAndGuiObj)
                      (restList : VarList)
                      → IOˢ GuiLev2Interface i (λ s' → s' ≡ addVar mvar restList  × Unit)
                                                (addVar mvar restList)

  setHandler .frame (add buttonFrame cels cels₁ _) g ffi rel mvar restList =
    setHandler frame cels₁ g ffi
                (in2= cels₁ (add buttonFrame cels cels₁ _) g (addlift buttonFrame cels cels₁ _) rel)
                mvar restList >>=ₚˢ λ r →
    setHandler atomicComp cels g ffi (in2= cels (add buttonFrame cels cels₁ _) g (addsub buttonFrame cels cels₁ _) rel)  mvar restList >>=ₚˢ λ r →
    returnˢ (refl , _)

  setHandler frame (createC tt) g ffi rel  mvar restList = returnˢ (refl , _)

  setHandler atomicComp (createC (button x)) g ffi (in2= .(createC (button x)) e' .g x₁ rel)  mvar restList =
     doˢ (setButtonHandler (FFIcomponentsReduce (createC (button x)) e' x₁
                              (FFIcomponentsReduce+ e' g rel ffi)  )

         [ (λ obj → buttonHandler (createC (button x)) g ffi
                      (in2= (createC (button x)) e' g x₁ rel) ffi (varListProj₁ restList obj)
                     >>= (λ { (g' , obj') → return (varListUpdateProj₁ restList  ( g' , obj') obj)}))]) λ _ →

     returnˢ (refl , _)

  setHandler atomicComp (createC (txtbox x)) g ffi (in2= .(createC (txtbox x)) e' .g x₁ rel)  mvar restList =      returnˢ (refl , _)

  setHandlerG : ∀{i} → (g : Frame)
                      (ffiComp : FFIcomponents g)
                      (mvar : MVar StateAndGuiObj)
                      (restList : VarList)
                      → IOˢ GuiLev2Interface i (λ s → s ≡ addVar mvar restList × Unit) (addVar mvar restList)
  setHandlerG g ffi mvar restList = setHandler frame g g ffi (in0= g) mvar restList

  deleteComp : {c : Component}{s : GuiLev2State}(e : ComponentEls c)(ffi : FFIcomponents e)
                          → IOₚˢ GuiLev2Interface ∞ Unit s s

  deleteComp {frame} (createC fr) _ = returnˢ (refl , _)

  deleteComp {frame} (add x be frameEl _) (ffi , ffis) =
    deleteComp be ffi >>=ₚˢ λ _ →
    deleteComp frameEl ffis >>=ₚˢ λ r →
    returnˢ (refl , _)

  deleteComp {atomicComp} (createC (button x)) ffiButton =
    doˢ (level1C (deleteButton ffiButton)) λ _ →
    returnˢ (refl , _)

  deleteComp {atomicComp} (createC (txtbox y)) ffiTextCtrl =
    doˢ (level1C (deleteTextCtrl ffiTextCtrl)) λ _ →
    returnˢ (refl , _)

  deleteComp {atomicComp} (add () a b _) y

  setAttributes : {c : Component}(i : Size)(e : ComponentEls c)(a : properties e)
                      (ffi : FFIcomponents e)
                          → IO GuiLev1Interface i ⊤

  setAttributes {frame} i (createC fr) (a , b , c , d) x =
    log " setting properties for Frame " λ _ →
    do (setChildredLayout x a b c d) λ _ →
    return tt

  setAttributes {frame} i (add x be frameEl _) (a , as) (ffi , ffis) =

    setAttributes i be a ffi >>= λ _ →
    setAttributes i frameEl as ffis >>= λ r →
    return tt

  setAttributes {atomicComp} i (createC (button x)) propColor ffiButton =
    do (setAttribButton ffiButton propColor) λ _ →
    return tt

  setAttributes {atomicComp} i (createC (txtbox y)) propColor ffiTextCtrl =
    do (setAttribTextCtrl ffiTextCtrl propColor) λ _ →
    return tt

  setAttributes {atomicComp} i (add () a b _) y z

getFrameGen : (g : Frame)(cp : FFIcomponents g) → FFIFrame
getFrameGen (createC x) cp = cp
getFrameGen (add buttonFrame g g₁ _) (compg , compg₁) = getFrameGen g₁ compg₁


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

open import HoTT
open import homotopy.EilenbergMacLane
open import homotopy.EilenbergMacLane1
open import homotopy.EilenbergMacLaneFunctor
open import homotopy.SmashFmapConn
open import homotopy.IterSuspSmash
open import cohomology.CupProduct.OnEM.InLowDegrees2

module cohomology.CupProduct.OnEM.InAllDegrees where

module _ {i} (A : AbGroup i) where

  private
    module A = AbGroup A
  open EMExplicit

  inv-path : A == A
  inv-path = uaᴬᴳ A A (inv-iso A)

  ⊙cond-neg : ∀ (k : ℕ) → Bool
    → ⊙EM A k ⊙→ ⊙EM A k
  ⊙cond-neg k b =
    ⊙transport (λ G → ⊙EM G k) {x = A} {y = A} (Bool-elim inv-path idp b)

  ⊙cond-neg-∘ : ∀ (k : ℕ) (b c : Bool)
    → ⊙cond-neg k b ◃⊙∘ ⊙cond-neg k c ◃⊙idf
      =⊙∘
      ⊙cond-neg k (xor b c) ◃⊙idf
  ⊙cond-neg-∘ k true true =
    ⊙transport (λ G → ⊙EM G k) {x = A} {y = A} inv-path ◃⊙∘
    ⊙transport (λ G → ⊙EM G k) {x = A} {y = A} inv-path ◃⊙idf
      =⊙∘₁⟨ 0 & 1 & ⊙transport-⊙EM-uaᴬᴳ A A (inv-iso A) k ⟩
    ⊙EM-fmap A A (–>ᴳ (inv-iso A)) k ◃⊙∘
    ⊙transport (λ G → ⊙EM G k) {x = A} {y = A} inv-path ◃⊙idf
      =⊙∘₁⟨ 1 & 1 & ⊙transport-⊙EM-uaᴬᴳ A A (inv-iso A) k ⟩
    ⊙EM-fmap A A (–>ᴳ (inv-iso A)) k ◃⊙∘
    ⊙EM-fmap A A (–>ᴳ (inv-iso A)) k ◃⊙idf
      =⊙∘₁⟨ ! $ ⊙EM-fmap-∘ A A A (–>ᴳ (inv-iso A)) (–>ᴳ (inv-iso A)) k ⟩
    ⊙EM-fmap A A (–>ᴳ (inv-iso A) ∘ᴳ –>ᴳ (inv-iso A)) k ◃⊙idf
      =⊙∘₁⟨ ap (λ φ → ⊙EM-fmap A A φ k) $
            group-hom= {ψ = idhom _} (λ= A.inv-inv) ⟩
    ⊙EM-fmap A A (idhom _) k ◃⊙idf
      =⊙∘₁⟨ ⊙EM-fmap-idhom A k ⟩
    ⊙idf _ ◃⊙idf ∎⊙∘
  ⊙cond-neg-∘ k true  false = =⊙∘-in idp
  ⊙cond-neg-∘ k false true  = =⊙∘-in (⊙λ= (⊙∘-unit-l (⊙cond-neg k true)))
  ⊙cond-neg-∘ k false false = =⊙∘-in idp

  ⊙maybe-Susp^-flip-⊙cond-neg : ∀ (k : ℕ) (b : Bool)
    → (k == 0 → b == false)
    → ⊙Trunc-fmap (⊙maybe-Susp^-flip k b) == ⊙cond-neg (S k) b
  ⊙maybe-Susp^-flip-⊙cond-neg O b h =
    ⊙Trunc-fmap (⊙idf (⊙EM₁ A.grp))
      =⟨ ⊙λ= ⊙Trunc-fmap-⊙idf ⟩
    ⊙idf (⊙EM A 1)
      =⟨ ap (⊙cond-neg 1) (! (h idp)) ⟩
    ⊙cond-neg 1 b =∎
  ⊙maybe-Susp^-flip-⊙cond-neg (S k) true h =
    ⊙Trunc-fmap (⊙Susp-flip (⊙Susp^ k (⊙EM₁ A.grp)))
      =⟨ ! (⊙EM-neg=⊙Trunc-fmap-⊙Susp-flip A k) ⟩
    ⊙EM-neg A (S (S k))
      =⟨ ! (⊙transport-⊙EM-uaᴬᴳ A A (inv-iso A) (S (S k))) ⟩
    ⊙transport (λ G → ⊙EM G (S (S k))) {x = A} {y = A} inv-path =∎
  ⊙maybe-Susp^-flip-⊙cond-neg (S k) false h = ⊙λ= (⊙Trunc-fmap-⊙idf)

  ⊙EM2-Susp-seq : ∀ (k : ℕ)
    → ⊙Susp^ k (⊙EM A 2) ⊙–→ ⊙EM A (S (S k))
  ⊙EM2-Susp-seq k =
    ⊙transport (λ l → ⊙Trunc l (⊙Susp^ (S k) (⊙EM₁ A.grp))) (+2+-comm ⟨ k ⟩₋₂ 2) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-swap k 1 {⊙EM₁ A.grp}) ◃⊙∘
    ⊙Susp^-Trunc-swap (⊙Susp (EM₁ A.grp)) 2 k ◃⊙idf

  ⊙EM2-Susp : ∀ (k : ℕ)
    → ⊙Susp^ k (⊙EM A 2) ⊙→ ⊙EM A (S (S k))
  ⊙EM2-Susp k = ⊙compose (⊙EM2-Susp-seq k)

  ⊙EM2-Susp-⊙maybe-Susp^-flip : ∀ (k : ℕ) (b : Bool)
    → (k == 0 → b == false)
    → ⊙EM2-Susp k ◃⊙∘
      ⊙maybe-Susp^-flip k b ◃⊙idf
      =⊙∘
      ⊙Trunc-fmap (⊙maybe-Susp^-flip {X = ⊙EM₁ A.grp} (S k) b) ◃⊙∘
      ⊙EM2-Susp k ◃⊙idf
  ⊙EM2-Susp-⊙maybe-Susp^-flip k b h =
    ⊙EM2-Susp k ◃⊙∘
    ⊙maybe-Susp^-flip k b ◃⊙idf
      =⊙∘⟨ 0 & 1 & ⊙expand (⊙EM2-Susp-seq k) ⟩
    ⊙transport (λ l → ⊙Trunc l (⊙Susp^ (S k) (⊙EM₁ A.grp))) (+2+-comm ⟨ k ⟩₋₂ 2) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-swap k 1 {⊙EM₁ A.grp}) ◃⊙∘
    ⊙Susp^-Trunc-swap (⊙Susp (EM₁ A.grp)) 2 k ◃⊙∘
    ⊙maybe-Susp^-flip k b ◃⊙idf
      =⊙∘⟨ 2 & 2 & ⊙Susp^-Trunc-swap-⊙maybe-Susp^-flip (⊙Susp (EM₁ A.grp)) 2 k b ⟩
    ⊙transport (λ l → ⊙Trunc l (⊙Susp^ (S k) (⊙EM₁ A.grp))) (+2+-comm ⟨ k ⟩₋₂ 2) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-swap k 1 {⊙EM₁ A.grp}) ◃⊙∘
    ⊙Trunc-fmap (⊙maybe-Susp^-flip k b) ◃⊙∘
    ⊙Susp^-Trunc-swap (⊙Susp (EM₁ A.grp)) 2 k ◃⊙idf
      =⊙∘⟨ 1 & 2 & ⊙Trunc-fmap-seq-=⊙∘ p ⟩
    ⊙transport (λ l → ⊙Trunc l (⊙Susp^ (S k) (⊙EM₁ A.grp))) (+2+-comm ⟨ k ⟩₋₂ 2) ◃⊙∘
    ⊙Trunc-fmap (⊙maybe-Susp-flip (⊙Susp^ k (⊙EM₁ A.grp)) b) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-swap k 1 {⊙EM₁ A.grp}) ◃⊙∘
    ⊙Susp^-Trunc-swap (⊙Susp (EM₁ A.grp)) 2 k ◃⊙idf
      =⊙∘⟨ 0 & 2 & !⊙∘ $
           ⊙transport-natural-=⊙∘
             (+2+-comm ⟨ k ⟩₋₂ 2)
             (λ l → ⊙Trunc-fmap {n = l} (⊙maybe-Susp^-flip (S k) b)) ⟩
    ⊙Trunc-fmap (⊙maybe-Susp-flip (⊙Susp^ k (⊙EM₁ A.grp)) b) ◃⊙∘
    ⊙transport (λ l → ⊙Trunc l (⊙Susp^ (S k) (⊙EM₁ A.grp))) (+2+-comm ⟨ k ⟩₋₂ 2) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-swap k 1 {⊙EM₁ A.grp}) ◃⊙∘
    ⊙Susp^-Trunc-swap (⊙Susp (EM₁ A.grp)) 2 k ◃⊙idf
      =⊙∘⟨ 1 & 3 & ⊙contract ⟩
    ⊙Trunc-fmap (⊙maybe-Susp-flip (⊙Susp^ k (⊙EM₁ A.grp)) b) ◃⊙∘
    ⊙EM2-Susp k ◃⊙idf ∎⊙∘
    where
    p : ⊙Susp^-swap k 1 {⊙EM₁ A.grp} ◃⊙∘
        ⊙maybe-Susp^-flip k b ◃⊙idf
        =⊙∘
        ⊙maybe-Susp^-flip {X = ⊙EM₁ A.grp} (S k) b ◃⊙∘
        ⊙Susp^-swap k 1 {⊙EM₁ A.grp} ◃⊙idf
    p =
      ⊙Susp^-swap k 1 {⊙EM₁ A.grp} ◃⊙∘
      ⊙maybe-Susp^-flip k b ◃⊙idf
        =⊙∘⟨ !⊙∘ $ ⊙maybe-Susp^-flip-⊙Susp^-comm (⊙EM₁ A.grp) k 1 b ⟩
      ⊙Susp-fmap (fst (⊙maybe-Susp^-flip k b)) ◃⊙∘
      ⊙coe (⊙Susp^-comm k 1) ◃⊙idf
        =⊙∘₁⟨ 0 & 1 & ap ⊙Susp-fmap (de⊙-⊙maybe-Susp^-flip k b) ∙
                      ⊙Susp-fmap-maybe-Susp^-flip k b h ⟩
      ⊙maybe-Susp-flip (⊙Susp^ k (⊙EM₁ A.grp)) b ◃⊙∘
      ⊙Susp^-swap k 1 ◃⊙idf ∎⊙∘

  ⊙cpₕₕ''-seq : ∀ (m n : ℕ)
    → ⊙Susp^ (m + n) (⊙EM A 2) ⊙–→ ⊙EM A (S m + S n)
  ⊙cpₕₕ''-seq m n =
    ⊙cond-neg (S m + S n) (odd n) ◃⊙∘
    ⊙transport (⊙EM A) (! (+-βr (S m) n)) ◃⊙∘
    ⊙EM2-Susp (m + n) ◃⊙idf

  ⊙cpₕₕ'' : ∀ (m n : ℕ)
    → ⊙Susp^ (m + n) (⊙EM A 2) ⊙→ ⊙EM A (S m + S n)
  ⊙cpₕₕ'' m n = ⊙compose (⊙cpₕₕ''-seq m n)

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  →-⊙→-uncurry : ∀ {k} {Z : Ptd k}
    → (de⊙ X → Y ⊙→ Z)
    → X ⊙× Y ⊙→ Z
  →-⊙→-uncurry f =
    uncurry (λ x y → fst (f x) y) , snd (f (pt X))

module _ {i} {j} (G : AbGroup i) (H : AbGroup j) where

  private
    module G = AbGroup G
    module H = AbGroup H
    module G⊗H = TensorProduct G H
  open EMExplicit

  ⊙∧-cpₕₕ'-seq : ∀ (m n : ℕ)
    → (⊙Susp^ m (⊙EM₁ G.grp) ⊙∧ ⊙Susp^ n (⊙EM₁ H.grp))
      ⊙–→
      ⊙EM G⊗H.abgroup (S m + S n)
  ⊙∧-cpₕₕ'-seq m n =
    ⊙cpₕₕ'' G⊗H.abgroup m n ◃⊙∘
    ⊙Susp^-fmap (m + n) (⊙∧-cp₁₁ G H) ◃⊙∘
    ⊙Σ^∧Σ^-out (⊙EM₁ G.grp) (⊙EM₁ H.grp) m n ◃⊙idf

  ⊙∧-cpₕₕ' : ∀ (m n : ℕ)
    → ⊙Susp^ m (⊙EM₁ G.grp) ⊙∧ ⊙Susp^ n (⊙EM₁ H.grp) ⊙→ ⊙EM G⊗H.abgroup (S m + S n)
  ⊙∧-cpₕₕ' m n = ⊙compose (⊙∧-cpₕₕ'-seq m n)

  ∧-cpₕₕ' : ∀ (m n : ℕ)
    → ⊙Susp^ m (⊙EM₁ G.grp) ∧ ⊙Susp^ n (⊙EM₁ H.grp)
    → EM G⊗H.abgroup (S m + S n)
  ∧-cpₕₕ' m n = fst (⊙∧-cpₕₕ' m n)

  ⊙smash-truncate : ∀ (m n : ℕ)
    → ⊙Susp^ m (⊙EM₁ G.grp) ⊙∧ ⊙Susp^ n (⊙EM₁ H.grp)
    ⊙→ ⊙EM G (S m) ⊙∧ ⊙EM H (S n)
  ⊙smash-truncate m n =
    ⊙∧-fmap
      ([_] {n = ⟨ S m ⟩} {A = Susp^ m (EM₁ G.grp)} , idp)
      ([_] {n = ⟨ S n ⟩} {A = Susp^ n (EM₁ H.grp)} , idp)

  smash-truncate : ∀ (m n : ℕ)
    → ⊙Susp^ m (⊙EM₁ G.grp) ∧ ⊙Susp^ n (⊙EM₁ H.grp)
    → ⊙EM G (S m) ∧ ⊙EM H (S n)
  smash-truncate m n = fst (⊙smash-truncate m n)

  smash-truncate-conn : ∀ (m n : ℕ)
    → has-conn-fibers ⟨ S m + S n ⟩ (smash-truncate m n)
  smash-truncate-conn m n =
    transport (λ k → has-conn-fibers k (smash-truncate m n)) p $
    ∧-fmap-conn
      ([_] {n = ⟨ S m ⟩} {A = Susp^ m (EM₁ G.grp)} , idp)
      ([_] {n = ⟨ S n ⟩} {A = Susp^ n (EM₁ H.grp)} , idp)
      (EM-conn G m)
      (⊙Susp^-conn' n {{EM₁-conn}})
      (trunc-proj-conn (Susp^ m (EM₁ G.grp)) ⟨ S m ⟩)
      (trunc-proj-conn (Susp^ n (EM₁ H.grp)) ⟨ S n ⟩)
    where
    p₁ : ⟨ n ⟩₋₁ +2+ ⟨ S m ⟩ == ⟨ S m + S n ⟩
    p₁ =
      ⟨ n ⟩₋₁ +2+ ⟨ S m ⟩
        =⟨ ! (+-+2+ (S n) (S (S (S m)))) ⟩
      ⟨ n + S (S (S m)) ⟩₋₁
        =⟨ ap ⟨_⟩₋₁ (+-βr n (S (S m))) ⟩
      ⟨ n + S (S m) ⟩
        =⟨ ap ⟨_⟩ (+-βr n (S m)) ⟩
      ⟨ S n + S m ⟩
        =⟨ ap ⟨_⟩ (+-comm (S n) (S m)) ⟩
      ⟨ S m + S n ⟩ =∎
    p₂ : ⟨ m ⟩₋₁ +2+ ⟨ S n ⟩ == ⟨ S m + S n ⟩
    p₂ =
      ⟨ m ⟩₋₁ +2+ ⟨ S n ⟩
        =⟨ ! (+-+2+ (S m) (S (S (S n)))) ⟩
      ⟨ m + S (S (S n)) ⟩₋₁
        =⟨ ap ⟨_⟩₋₁ (+-βr m (S (S n))) ⟩
      ⟨ m + S (S n) ⟩
        =⟨ ap ⟨_⟩ (+-βr m (S n)) ⟩
      ⟨ S m + S n ⟩ =∎
    p : minT (⟨ n ⟩₋₁ +2+ ⟨ S m ⟩) (⟨ m ⟩₋₁ +2+ ⟨ S n ⟩) == ⟨ S m + S n ⟩
    p =
      minT (⟨ n ⟩₋₁ +2+ ⟨ S m ⟩) (⟨ m ⟩₋₁ +2+ ⟨ S n ⟩)
        =⟨ ap2 minT p₁ p₂ ⟩
      minT ⟨ S m + S n ⟩ ⟨ S m + S n ⟩
        =⟨ minT-out-l ≤T-refl ⟩
      ⟨ S m + S n ⟩ =∎

  module SmashCPₕₕ (m n : ℕ) =
    ⊙ConnExtend
      {Z = ⊙EM G⊗H.abgroup (S m + S n)}
      {n = ⟨ S m + S n ⟩}
      (⊙smash-truncate m n)
      (smash-truncate-conn m n)
      (EM-level G⊗H.abgroup (S m + S n))

  ⊙∧-cpₕₕ : ∀ (m n : ℕ)
    → ⊙EM G (S m) ⊙∧ ⊙EM H (S n) ⊙→ ⊙EM G⊗H.abgroup (S m + S n)
  ⊙∧-cpₕₕ m n = SmashCPₕₕ.⊙ext m n (⊙∧-cpₕₕ' m n)

  ∧-cpₕₕ : ∀ (m n : ℕ)
    → ⊙EM G (S m) ∧ ⊙EM H (S n)
    → EM G⊗H.abgroup (S m + S n)
  ∧-cpₕₕ m n = fst (⊙∧-cpₕₕ m n)

  ⊙×-cpₕₕ-seq : ∀ (m n : ℕ)
    → ⊙EM G (S m) ⊙× ⊙EM H (S n) ⊙–→ ⊙EM G⊗H.abgroup (S m + S n)
  ⊙×-cpₕₕ-seq m n = ⊙∧-cpₕₕ m n ◃⊙∘ ×-⊙to-∧ ◃⊙idf

  ⊙×-cpₕₕ : ∀ (m n : ℕ)
    → ⊙EM G (S m) ⊙× ⊙EM H (S n) ⊙→ ⊙EM G⊗H.abgroup (S m + S n)
  ⊙×-cpₕₕ m n = ⊙compose (⊙×-cpₕₕ-seq m n)

  {-
  cp₀ₕ' : ∀ (n : ℕ) → G.El → EM H (S n) → EM G⊗H.abgroup (S n)
  cp₀ₕ' n g y = EM-fmap H G⊗H.abgroup (G⊗H.ins-r-hom g) (S n) y

  ×-cp₀ₕ' : ∀ (n : ℕ)
    → G.El × EM H (S n) → EM G⊗H.abgroup (S n)
  ×-cp₀ₕ' n = uncurry (cp₀ₕ' n)
  -}

  ⊙×-cp₀ₕ' : ∀ (n : ℕ)
    → G.⊙El ⊙× ⊙EM H (S n) ⊙→ ⊙EM G⊗H.abgroup (S n)
  ⊙×-cp₀ₕ' n =
    →-⊙→-uncurry (λ g → ⊙EM-fmap H G⊗H.abgroup (G⊗H.ins-r-hom g) (S n))
    -- ×-cp₀ₕ' n , snd (⊙EM-fmap H G⊗H.abgroup (G⊗H.ins-r-hom G.ident) (S n))

  ⊙×-cp₀ₕ-seq : ∀ (n : ℕ)
    → ⊙EM G 0 ⊙× ⊙EM H (S n) ⊙–→ ⊙EM G⊗H.abgroup (S n)
  ⊙×-cp₀ₕ-seq n =
    ⊙×-cp₀ₕ' n ◃⊙∘
    ⊙×-fmap (⊙<– (⊙emloop-equiv G.grp)) (⊙idf (⊙EM H (S n))) ◃⊙idf

  ⊙×-cp₀ₕ : ∀ (n : ℕ)
    → ⊙EM G 0 ⊙× ⊙EM H (S n) ⊙→ ⊙EM G⊗H.abgroup (S n)
  ⊙×-cp₀ₕ n = ⊙compose (⊙×-cp₀ₕ-seq n)

  ×-cp₀ₕ : ∀ (n : ℕ)
    → EM G 0 × EM H (S n) → EM G⊗H.abgroup (S n)
  ×-cp₀ₕ n = fst (⊙×-cp₀ₕ n)

  {-
  cpₕ₀' : ∀ (m : ℕ) → EM G (S m) → H.El → EM G⊗H.abgroup (S m)
  cpₕ₀' m x h = EM-fmap G G⊗H.abgroup (G⊗H.ins-l-hom h) (S m) x

  ×-cpₕ₀' : ∀ (m : ℕ)
    → EM G (S m) × H.El → EM G⊗H.abgroup (S m)
  ×-cpₕ₀' m = uncurry (cpₕ₀' m)
  -}

  ⊙×-cpₕ₀' : ∀ (m : ℕ)
    → ⊙EM G (S m) ⊙× H.⊙El ⊙→ ⊙EM G⊗H.abgroup (S m)
  ⊙×-cpₕ₀' m =
    →-⊙→-uncurry (λ h → ⊙EM-fmap G G⊗H.abgroup (G⊗H.ins-l-hom h) (S m)) ⊙∘
    ⊙×-swap
    -- ×-cpₕ₀' m , snd (⊙EM-fmap G G⊗H.abgroup (G⊗H.ins-l-hom H.ident) (S m))

  ⊙×-cpₕ₀-seq : ∀ (m : ℕ)
    → ⊙EM G (S m) ⊙× ⊙EM H 0 ⊙–→ ⊙EM G⊗H.abgroup (S m + 0)
  ⊙×-cpₕ₀-seq m =
    ⊙transport (⊙EM G⊗H.abgroup) (! (+-unit-r (S m))) ◃⊙∘
    ⊙×-cpₕ₀' m ◃⊙∘
    ⊙×-fmap (⊙idf (⊙EM G (S m))) (⊙<– (⊙emloop-equiv H.grp)) ◃⊙idf

  ⊙×-cpₕ₀ : ∀ (m : ℕ)
    → ⊙EM G (S m) ⊙× ⊙EM H 0 ⊙→ ⊙EM G⊗H.abgroup (S m + 0)
  ⊙×-cpₕ₀ m = ⊙compose (⊙×-cpₕ₀-seq m)

  ×-cpₕ₀ : ∀ (m : ℕ)
    → EM G (S m) × EM H 0 → EM G⊗H.abgroup (S m + 0)
  ×-cpₕ₀ m = fst (⊙×-cpₕ₀ m)

  ⊙×-cp : ∀ (m n : ℕ)
    → ⊙EM G m ⊙× ⊙EM H n
    ⊙→ ⊙EM G⊗H.abgroup (m + n)
  ⊙×-cp 0 0 = ⊙×-cp₀₀ G H
  ⊙×-cp 0 (S n) = ⊙×-cp₀ₕ n
  ⊙×-cp (S m) 0 = ⊙×-cpₕ₀ m
  ⊙×-cp (S m) (S n) = ⊙×-cpₕₕ m n


open import Agda.Builtin.Float

_ : Float
_ = 1.0xA


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Unary.Any directly.
------------------------------------------------------------------------

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

module Data.Vec.Any where

open import Data.Vec.Relation.Unary.Any public


------------------------------------------------------------------------
-- Lemmas related to application of substitutions
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Data.Application.Application221
  {i u e} {Uni : IndexedUniverse i u e}
  where

import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Data.Application.Application21
open import deBruijn.Substitution.Data.Basics
open import deBruijn.Substitution.Data.Map
open import deBruijn.Substitution.Data.Simple
open import Function using (_$_)
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

-- Lemmas related to application.

record Application₂₂₁
  {t₁} {T₁ : Term-like t₁}
  {t₂} {T₂ : Term-like t₂}

  -- Simple substitutions for the first kind of terms.
  (simple₁ : Simple T₁)

  -- Simple substitutions for the second kind of terms.
  (simple₂ : Simple T₂)

  -- A translation from the first to the second kind of terms.
  (trans : [ T₁ ⟶⁼ T₂ ])
  : Set (i ⊔ u ⊔ e ⊔ t₁ ⊔ t₂) where

  open Term-like T₂ using ([_]) renaming (_⊢_ to _⊢₂_; _≅-⊢_ to _≅-⊢₂_)
  open Simple simple₁
    using ()
    renaming ( wk to wk₁; wk[_] to wk₁[_]; wk-subst to wk-subst₁
             ; _↑ to _↑₁; _↑_ to _↑₁_; _↑⁺_ to _↑⁺₁_; _↑⁺⋆_ to _↑⁺⋆₁_
             )
  open Simple simple₂
    using ()
    renaming ( var to var₂
             ; weaken to weaken₂; weaken[_] to weaken₂[_]
             ; wk[_] to wk₂[_]
             ; wk-subst to wk-subst₂; wk-subst[_] to wk-subst₂[_]
             ; _↑ to _↑₂
             )

  field
    application₂₁ : Application₂₁ simple₁ simple₂ trans

  open Application₂₁ application₂₁

  field
    -- Lifts equalities valid for all variables and liftings to
    -- arbitrary terms.
    var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ :
      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs₁ : Subs T₁ ρ̂) (ρs₂ : Subs T₁ ρ̂) →
      (∀ Γ⁺ {σ} (x : Γ ++⁺ Γ⁺ ∋ σ) →
         var₂ · x /⊢⋆ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢₂ var₂ · x /⊢⋆ ρs₂ ↑⁺⋆₁ Γ⁺) →
      ∀ Γ⁺ {σ} (t : Γ ++⁺ Γ⁺ ⊢₂ σ) →
      t /⊢⋆ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢₂ t /⊢⋆ ρs₂ ↑⁺⋆₁ Γ⁺

    -- The wk substitution and the weaken function are equivalent.
    /⊢-wk : ∀ {Γ σ τ} (t : Γ ⊢₂ τ) →
            t /⊢ wk₁[ σ ] ≅-⊢₂ weaken₂[ σ ] · t

  abstract

    -- wk-subst is equivalent to composition with wk.

    ∘-wk : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₂ ρ̂) →
           ρ ∘ wk₁[ σ ] ≅-⇨ wk-subst₂[ σ ] ρ
    ∘-wk ρ = begin
      [ map (app wk₁) ρ ]  ≡⟨ map-cong-ext₁ P.refl /⊢-wk (P.refl {x = [ ρ ]}) ⟩
      [ map weaken₂   ρ ]  ∎

    -- The wk substitution commutes (modulo lifting etc.) with any
    -- other.
    --
    -- TODO: Prove this lemma using /⊢-/⊢-wk?

    wk-∘-↑ : ∀ {Γ Δ} σ {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₁ ρ̂) →
             map trans ρ ∘ wk₁[ σ / ρ ] ≅-⇨ wk₂[ σ ] ∘ ρ ↑₁
    wk-∘-↑ σ ρ = extensionality P.refl λ x → begin
      [ x /∋ map trans ρ ∘ wk₁         ]  ≡⟨ /∋-cong (P.refl {x = [ x ]}) (∘-wk (map trans ρ)) ⟩
      [ x /∋ wk-subst₂ (map trans ρ)   ]  ≡⟨ P.sym $ Simple.suc-/∋-↑ simple₂ σ x (map trans ρ) ⟩
      [ suc[ σ ] x /∋ map trans ρ ↑₂   ]  ≡⟨ /∋-cong (P.refl {x = [ suc[ σ ] x ]}) (P.sym $ map-trans-↑ ρ) ⟩
      [ suc[ σ ] x /∋ map trans (ρ ↑₁) ]  ≡⟨ /∋-map (suc[ σ ] x) trans (ρ ↑₁) ⟩
      [ trans · (suc[ σ ] x /∋ ρ ↑₁)   ]  ≡⟨ P.sym $ var-/⊢ (suc[ σ ] x) (ρ ↑₁) ⟩
      [ var₂ · suc[ σ ] x /⊢ ρ ↑₁      ]  ≡⟨ /⊢-cong (P.sym $ Simple./∋-wk simple₂ {σ = σ} x) (P.refl {x = [ ρ ↑₁ ]}) ⟩
      [ x /∋ wk₂[ σ ] /⊢ ρ ↑₁          ]  ≡⟨ P.sym $ /∋-∘ x wk₂[ σ ] (ρ ↑₁) ⟩
      [ x /∋ wk₂[ σ ] ∘ ρ ↑₁           ]  ∎

    -- A variant of suc-/∋-↑.

    var-suc-/⊢-↑ :
      ∀ {Γ Δ} σ {τ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ τ) (ρ : Sub T₁ ρ̂) →
      var₂ · suc[ σ ] x /⊢ ρ ↑₁ ≅-⊢₂
      var₂ · x /⊢ ρ /⊢ wk₁[ σ / ρ ]
    var-suc-/⊢-↑ σ x ρ =
      let lemma₁ = begin
            [ x /∋ map trans ρ ]  ≡⟨ /∋-map x trans ρ ⟩
            [ trans · (x /∋ ρ) ]  ≡⟨ P.sym $ var-/⊢ x ρ ⟩
            [ var₂ · x /⊢ ρ    ]  ∎

          lemma₂ = begin
            [ map trans (wk-subst₁ ρ) ]  ≡⟨ map-trans-wk-subst ρ ⟩
            [ wk-subst₂ (map trans ρ) ]  ≡⟨ P.sym $ ∘-wk (map trans ρ) ⟩
            [ map trans ρ ∘ wk₁       ]  ∎

      in begin
      [ var₂ · suc[ σ ] x /⊢ ρ ↑₁    ]  ≡⟨ var-/⊢ (suc[ σ ] x) (ρ ↑₁) ⟩
      [ trans · (suc[ σ ] x /∋ ρ ↑₁) ]  ≡⟨ trans-cong (Simple.suc-/∋-↑ simple₁ σ x ρ) ⟩
      [ trans · (x /∋ wk-subst₁ ρ)   ]  ≡⟨ P.sym $ /∋-map x trans (wk-subst₁ ρ) ⟩
      [ x /∋ map trans (wk-subst₁ ρ) ]  ≡⟨ /∋-cong (P.refl {x = [ x ]}) lemma₂ ⟩
      [ x /∋ map trans ρ ∘ wk₁       ]  ≡⟨ /∋-∘ x (map trans ρ) wk₁ ⟩
      [ x /∋ map trans ρ /⊢ wk₁      ]  ≡⟨ /⊢-cong lemma₁ (P.refl {x = [ wk₁ ]}) ⟩
      [ var₂ · x /⊢ ρ /⊢ wk₁         ]  ∎

    private

      -- wk ↑⁺ Γ⁺ and wk commute (more or less).
      --
      -- This lemma is an instance of /⊢-/⊢-wk, which is proved below
      -- using, among other things, this lemma.

      /⊢-wk-↑⁺-/⊢-wk :
        ∀ {Γ} σ Γ⁺ τ {υ} (t : Γ ++⁺ Γ⁺ ⊢₂ υ) →
        let wk-σ = wk₁[ σ ] ↑⁺₁ Γ⁺ in
        t /⊢ wk-σ /⊢ wk₁[ τ / wk-σ ] ≅-⊢₂
        t /⊢ wk₁ /⊢ wk₁[ σ ] ↑⁺₁ (Γ⁺ ▻ τ)
      /⊢-wk-↑⁺-/⊢-wk σ Γ⁺ τ t = var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆
        (ε ▻ wk₁[ σ ] ↑⁺₁ Γ⁺ ▻ wk₁[ τ / wk₁ ↑⁺₁ Γ⁺ ])
        (ε ▻ wk₁ ▻ wk₁ ↑⁺₁ (Γ⁺ ▻ τ))
        (λ Γ⁺⁺ x → begin
           [ var₂ · x /⊢⋆ (ε ▻ wk₁ ↑⁺₁ Γ⁺ ▻ wk₁) ↑⁺⋆₁ Γ⁺⁺            ]  ≡⟨ /⊢⋆-ε-▻-▻-↑⁺⋆ Γ⁺⁺ (var₂ · x) (wk₁ ↑⁺₁ Γ⁺) wk₁ ⟩
           [ var₂ · x /⊢ wk₁ ↑⁺₁ Γ⁺ ↑⁺₁ Γ⁺⁺ /⊢
               wk₁ ↑⁺₁ (Γ⁺⁺ /⁺ wk₁ ↑⁺₁ Γ⁺)                           ]  ≡⟨ /⊢-cong (var-/⊢-wk-↑⁺-↑⁺ Γ⁺ Γ⁺⁺ x) P.refl ⟩
           [ var₂ · (lift (lift weaken∋ Γ⁺) Γ⁺⁺ · x) /⊢
               wk₁ ↑⁺₁ (Γ⁺⁺ /⁺ wk₁ ↑⁺₁ Γ⁺)                           ]  ≡⟨ var-/⊢-wk-↑⁺ (Γ⁺⁺ /⁺ wk₁ ↑⁺₁ Γ⁺)
                                                                                (lift (lift weaken∋ Γ⁺) Γ⁺⁺ · x) ⟩
           [ var₂ · (lift weaken∋ (Γ⁺⁺ /⁺ wk₁ ↑⁺₁ Γ⁺) ·
                       (lift (lift weaken∋ Γ⁺) Γ⁺⁺ · x))             ]  ≡⟨ Simple.var-cong simple₂
                                                                             (lift-weaken∋-lift-lift-weaken∋ σ Γ⁺ τ Γ⁺⁺ x) ⟩
           [ var₂ · (lift (lift weaken∋ (Γ⁺ ▻ τ)) (Γ⁺⁺ /⁺ wk₁) ·
                       (lift weaken∋ Γ⁺⁺ · x))                       ]  ≡⟨ P.sym $ var-/⊢-wk-↑⁺-↑⁺ (Γ⁺ ▻ τ) (Γ⁺⁺ /⁺ wk₁)
                                                                                (lift weaken∋ Γ⁺⁺ · x) ⟩
           [ var₂ · (lift weaken∋ Γ⁺⁺ · x) /⊢
               wk₁[ σ ] ↑⁺₁ (Γ⁺ ▻ τ) ↑⁺₁ (Γ⁺⁺ /⁺ wk₁)                ]  ≡⟨ P.sym $ /⊢-cong (var-/⊢-wk-↑⁺ Γ⁺⁺ x) P.refl ⟩
           [ var₂ · x /⊢ wk₁ ↑⁺₁ Γ⁺⁺ /⊢
               wk₁[ σ ] ↑⁺₁ (Γ⁺ ▻ τ) ↑⁺₁ (Γ⁺⁺ /⁺ wk₁)                ]  ≡⟨ P.sym $ /⊢⋆-ε-▻-▻-↑⁺⋆ Γ⁺⁺ (var₂ · x) wk₁
                                                                                (wk₁[ σ ] ↑⁺₁ (Γ⁺ ▻ τ)) ⟩
           [ var₂ · x /⊢⋆ (ε ▻ wk₁ ▻ wk₁[ σ ] ↑⁺₁ (Γ⁺ ▻ τ)) ↑⁺⋆₁ Γ⁺⁺ ]  ∎)
        ε t

      -- Another lemma used in the proof of /⊢-/⊢-wk.

      var-/⊢-↑⁺-/⊢-wk-↑⁺ :
        ∀ {Γ Δ} σ {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₁ ρ̂) Γ⁺ {υ} (x : Γ ++⁺ Γ⁺ ∋ υ) →
        var₂ · x /⊢ ρ ↑⁺₁ Γ⁺ /⊢ wk₁[ σ / ρ ] ↑⁺₁ (Γ⁺ /⁺ ρ) ≅-⊢₂
        var₂ · (lift weaken∋[ σ ] Γ⁺ · x) /⊢ ρ ↑₁ ↑⁺₁ (Γ⁺ /⁺ wk₁)
      var-/⊢-↑⁺-/⊢-wk-↑⁺ σ ρ ε        x    = P.sym $ var-suc-/⊢-↑ σ x ρ
      var-/⊢-↑⁺-/⊢-wk-↑⁺ σ ρ (Γ⁺ ▻ τ) zero = begin
        [ var₂ · zero /⊢ ρ ↑⁺₁ (Γ⁺ ▻ τ) /⊢ wk₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ ρ) ]  ≡⟨ /⊢-cong (zero-/⊢-↑ τ (ρ ↑⁺₁ Γ⁺))
                                                                                (P.refl {x = [ wk₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ ρ) ]}) ⟩
        [ var₂ · zero /⊢ wk₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ ρ)                   ]  ≡⟨ zero-/⊢-↑ (τ / ρ ↑⁺₁ Γ⁺) (wk₁ ↑⁺₁ (Γ⁺ /⁺ ρ)) ⟩
        [ var₂ · zero                                              ]  ≡⟨ Simple.var-cong simple₂
                                                                           (zero-cong (/̂-↑̂⁺-/̂-ŵk-↑̂⁺ σ ⟦ ρ ⟧⇨ Γ⁺ τ)) ⟩
        [ var₂ · zero                                              ]  ≡⟨ P.sym $ zero-/⊢-↑ (τ / wk₁ ↑⁺₁ Γ⁺)
                                                                                (ρ ↑₁ σ ↑⁺₁ (Γ⁺ /⁺ wk₁)) ⟩
        [ var₂ · zero /⊢ ρ ↑₁ σ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ wk₁)              ]  ∎
      var-/⊢-↑⁺-/⊢-wk-↑⁺ σ ρ (Γ⁺ ▻ τ) (suc x) = begin
        [ var₂ · suc x /⊢ ρ ↑⁺₁ (Γ⁺ ▻ τ) /⊢ wk₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ ρ) ]  ≡⟨ /⊢-cong (var-suc-/⊢-↑ τ x (ρ ↑⁺₁ Γ⁺))
                                                                                (P.refl {x = [ wk₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ ρ) ]}) ⟩
        [ var₂ · x /⊢ ρ ↑⁺₁ Γ⁺ /⊢ wk₁ /⊢ wk₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ ρ)    ]  ≡⟨ P.sym $ /⊢-wk-↑⁺-/⊢-wk (σ / ρ) (Γ⁺ /⁺ ρ) (τ / ρ ↑⁺₁ Γ⁺)
                                                                                (var₂ · x /⊢ ρ ↑⁺₁ Γ⁺) ⟩
        [ var₂ · x /⊢ ρ ↑⁺₁ Γ⁺ /⊢ wk₁[ σ / ρ ] ↑⁺₁ (Γ⁺ /⁺ ρ)
            /⊢ wk₁[ τ / ρ ↑⁺₁ Γ⁺ / wk₁ ↑⁺₁ (Γ⁺ /⁺ ρ) ]              ]  ≡⟨ /⊢-cong
                                                                            (var-/⊢-↑⁺-/⊢-wk-↑⁺ σ ρ Γ⁺ x)
                                                                            (Simple.wk-cong simple₁ (/̂-↑̂⁺-/̂-ŵk-↑̂⁺ σ ⟦ ρ ⟧⇨ Γ⁺ τ)) ⟩
        [ var₂ · (lift weaken∋[ σ ] Γ⁺ · x) /⊢
            ρ ↑₁ ↑⁺₁ (Γ⁺ /⁺ wk₁) /⊢ wk₁                             ]  ≡⟨ P.sym $ var-suc-/⊢-↑ (τ / wk₁ ↑⁺₁ Γ⁺)
                                                                                (lift weaken∋[ σ ] Γ⁺ · x)
                                                                                (ρ ↑₁ ↑⁺₁ (Γ⁺ /⁺ wk₁)) ⟩
        [ var₂ · suc (lift weaken∋[ σ ] Γ⁺ · x) /⊢
            ρ ↑₁ ↑⁺₁ ((Γ⁺ ▻ τ) /⁺ wk₁)                              ]  ∎

    -- The wk substitution commutes (modulo lifting etc.) with any
    -- other.

    /⊢-/⊢-wk : ∀ {Γ Δ} σ {τ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ⊢₂ τ) (ρ : Sub T₁ ρ̂) →
               t /⊢ ρ /⊢ wk₁[ σ / ρ ] ≅-⊢₂ t /⊢ wk₁[ σ ] /⊢ ρ ↑₁
    /⊢-/⊢-wk σ t ρ = var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆
      (ε ▻ ρ ▻ wk₁)
      (ε ▻ wk₁[ σ ] ▻ ρ ↑₁)
      (λ Γ⁺ x → begin
         [ var₂ · x /⊢⋆ (ε ▻ ρ ▻ wk₁) ↑⁺⋆₁ Γ⁺                        ]  ≡⟨ /⊢⋆-ε-▻-▻-↑⁺⋆ Γ⁺ (var₂ · x) ρ wk₁ ⟩
         [ var₂ · x /⊢ ρ ↑⁺₁ Γ⁺ /⊢ wk₁ ↑⁺₁ (Γ⁺ /⁺ ρ)                 ]  ≡⟨ var-/⊢-↑⁺-/⊢-wk-↑⁺ σ ρ Γ⁺ x ⟩
         [ var₂ · (lift weaken∋[ σ ] Γ⁺ · x) /⊢ ρ ↑₁ ↑⁺₁ (Γ⁺ /⁺ wk₁) ]  ≡⟨ /⊢-cong (P.sym $ var-/⊢-wk-↑⁺ {σ = σ} Γ⁺ x)
                                                                                (P.refl {x = [ ρ ↑₁ ↑⁺₁ (Γ⁺ /⁺ wk₁) ]}) ⟩
         [ var₂ · x /⊢ wk₁[ σ ] ↑⁺₁ Γ⁺ /⊢ ρ ↑₁ ↑⁺₁ (Γ⁺ /⁺ wk₁)       ]  ≡⟨ P.sym $ /⊢⋆-ε-▻-▻-↑⁺⋆ Γ⁺ (var₂ · x) wk₁[ σ ] (ρ ↑₁) ⟩
         [ var₂ · x /⊢⋆ (ε ▻ wk₁[ σ ] ▻ ρ ↑₁) ↑⁺⋆₁ Γ⁺                ]  ∎) ε t

  open Application₂₁ application₂₁ public


{- 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
-}

open import LibraBFT.Base.Types
import      LibraBFT.Impl.Types.LedgerInfoWithSignatures as LedgerInfoWithSignatures
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import Optics.All
open import Util.KVMap as Map
open import Util.Hash
open import Util.Prelude

module LibraBFT.Impl.Types.Properties.LedgerInfoWithSignatures (self : LedgerInfoWithSignatures) (vv : ValidatorVerifier) where

  -- See comments in LibraBFT.Impl.Consensus.ConsensusTypes.Properties.QuorumCert

  postulate -- TODO-2: define and prove

    Contract : Set

    contract : LedgerInfoWithSignatures.verifySignatures self vv ≡ Right unit → Contract


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SmashProduct where

open import Cubical.HITs.SmashProduct.Base public

-- open import Cubical.HITs.SmashProduct.Properties public


-- Regression, introduced by the fix of issue 1759

module Issue1815 where

module _ (A : Set) where

  record R1 : Set where
    field f1 : A

  record R2 : Set where
    field f2 : R1
    open R1 f2 public

-- Parameter A is hidden in type of field f1 in R1 ...
test1 : ∀ A (r : R1 A) → A
test1 A r = R1.f1 r

-- ... and should be so in the type of field f1 in R2, too.
shouldFail : ∀ A (r : R2 A) → A
shouldFail A r = R2.f1 A r


-- Andreas, 2016-11-03, issue #2291, reported by Aerate

-- {-# OPTIONS -v interaction.helper:100 #-}

record Foo : Set where
  coinductive
  field one : Foo
open Foo

someFoo : Foo
someFoo .one = {! {R} -> Foo.one R !}

-- WAS: C-c C-h gives:
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs:1248

-- NOW:
-- Expected an argument of the form f e1 e2 .. en
-- when checking that the expression ? has type Foo


-- Andreas, 2015-05-06 issue reported by Jesper Cockx

{-# OPTIONS --copatterns #-}

record Foo (A : Set) : Set where
  field
    foo : A

open Foo {{...}} public

record ⊤ : Set where

instance
  Foo⊤ : Foo ⊤
  foo Foo⊤ = {!!}
  -- foo {{Foo⊤}} = {!!}

-- Error WAS:
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Rules/LHS/Split.hs:103

-- Better error:
-- Not a valid projection for a copattern: foo
-- when checking that the clause foo Foo⊤ = ? has type Foo ⊤